1 /* Array things 2 Copyright (C) 2000-2022 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5 This file is part of GCC. 6 7 GCC is free software; you can redistribute it and/or modify it under 8 the terms of the GNU General Public License as published by the Free 9 Software Foundation; either version 3, or (at your option) any later 10 version. 11 12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13 WARRANTY; without even the implied warranty of MERCHANTABILITY or 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15 for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with GCC; see the file COPYING3. If not see 19 <http://www.gnu.org/licenses/>. */ 20 21 #include "config.h" 22 #include "system.h" 23 #include "coretypes.h" 24 #include "options.h" 25 #include "gfortran.h" 26 #include "parse.h" 27 #include "match.h" 28 #include "constructor.h" 29 30 /**************** Array reference matching subroutines *****************/ 31 32 /* Copy an array reference structure. */ 33 34 gfc_array_ref * 35 gfc_copy_array_ref (gfc_array_ref *src) 36 { 37 gfc_array_ref *dest; 38 int i; 39 40 if (src == NULL) 41 return NULL; 42 43 dest = gfc_get_array_ref (); 44 45 *dest = *src; 46 47 for (i = 0; i < GFC_MAX_DIMENSIONS; i++) 48 { 49 dest->start[i] = gfc_copy_expr (src->start[i]); 50 dest->end[i] = gfc_copy_expr (src->end[i]); 51 dest->stride[i] = gfc_copy_expr (src->stride[i]); 52 } 53 54 return dest; 55 } 56 57 58 /* Match a single dimension of an array reference. This can be a 59 single element or an array section. Any modifications we've made 60 to the ar structure are cleaned up by the caller. If the init 61 is set, we require the subscript to be a valid initialization 62 expression. */ 63 64 static match 65 match_subscript (gfc_array_ref *ar, int init, bool match_star) 66 { 67 match m = MATCH_ERROR; 68 bool star = false; 69 int i; 70 bool saw_boz = false; 71 72 i = ar->dimen + ar->codimen; 73 74 gfc_gobble_whitespace (); 75 ar->c_where[i] = gfc_current_locus; 76 ar->start[i] = ar->end[i] = ar->stride[i] = NULL; 77 78 /* We can't be sure of the difference between DIMEN_ELEMENT and 79 DIMEN_VECTOR until we know the type of the element itself at 80 resolution time. */ 81 82 ar->dimen_type[i] = DIMEN_UNKNOWN; 83 84 if (gfc_match_char (':') == MATCH_YES) 85 goto end_element; 86 87 /* Get start element. */ 88 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) 89 star = true; 90 91 if (!star && init) 92 m = gfc_match_init_expr (&ar->start[i]); 93 else if (!star) 94 m = gfc_match_expr (&ar->start[i]); 95 96 if (ar->start[i] && ar->start[i]->ts.type == BT_BOZ) 97 { 98 gfc_error ("Invalid BOZ literal constant used in subscript at %C"); 99 saw_boz = true; 100 } 101 102 if (m == MATCH_NO) 103 gfc_error ("Expected array subscript at %C"); 104 if (m != MATCH_YES) 105 return MATCH_ERROR; 106 107 if (gfc_match_char (':') == MATCH_NO) 108 goto matched; 109 110 if (star) 111 { 112 gfc_error ("Unexpected %<*%> in coarray subscript at %C"); 113 return MATCH_ERROR; 114 } 115 116 /* Get an optional end element. Because we've seen the colon, we 117 definitely have a range along this dimension. */ 118 end_element: 119 ar->dimen_type[i] = DIMEN_RANGE; 120 121 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) 122 star = true; 123 else if (init) 124 m = gfc_match_init_expr (&ar->end[i]); 125 else 126 m = gfc_match_expr (&ar->end[i]); 127 128 if (ar->end[i] && ar->end[i]->ts.type == BT_BOZ) 129 { 130 gfc_error ("Invalid BOZ literal constant used in subscript at %C"); 131 saw_boz = true; 132 } 133 134 if (m == MATCH_ERROR) 135 return MATCH_ERROR; 136 137 if (star && ar->start[i] == NULL) 138 { 139 gfc_error ("Missing lower bound in assumed size " 140 "coarray specification at %C"); 141 return MATCH_ERROR; 142 } 143 144 /* See if we have an optional stride. */ 145 if (gfc_match_char (':') == MATCH_YES) 146 { 147 if (star) 148 { 149 gfc_error ("Strides not allowed in coarray subscript at %C"); 150 return MATCH_ERROR; 151 } 152 153 m = init ? gfc_match_init_expr (&ar->stride[i]) 154 : gfc_match_expr (&ar->stride[i]); 155 156 if (ar->stride[i] && ar->stride[i]->ts.type == BT_BOZ) 157 { 158 gfc_error ("Invalid BOZ literal constant used in subscript at %C"); 159 saw_boz = true; 160 } 161 162 if (m == MATCH_NO) 163 gfc_error ("Expected array subscript stride at %C"); 164 if (m != MATCH_YES) 165 return MATCH_ERROR; 166 } 167 168 matched: 169 if (star) 170 ar->dimen_type[i] = DIMEN_STAR; 171 172 return (saw_boz ? MATCH_ERROR : MATCH_YES); 173 } 174 175 176 /* Match an array reference, whether it is the whole array or particular 177 elements or a section. If init is set, the reference has to consist 178 of init expressions. */ 179 180 match 181 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, 182 int corank) 183 { 184 match m; 185 bool matched_bracket = false; 186 gfc_expr *tmp; 187 bool stat_just_seen = false; 188 bool team_just_seen = false; 189 190 memset (ar, '\0', sizeof (*ar)); 191 192 ar->where = gfc_current_locus; 193 ar->as = as; 194 ar->type = AR_UNKNOWN; 195 196 if (gfc_match_char ('[') == MATCH_YES) 197 { 198 matched_bracket = true; 199 goto coarray; 200 } 201 202 if (gfc_match_char ('(') != MATCH_YES) 203 { 204 ar->type = AR_FULL; 205 ar->dimen = 0; 206 return MATCH_YES; 207 } 208 209 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) 210 { 211 m = match_subscript (ar, init, false); 212 if (m == MATCH_ERROR) 213 return MATCH_ERROR; 214 215 if (gfc_match_char (')') == MATCH_YES) 216 { 217 ar->dimen++; 218 goto coarray; 219 } 220 221 if (gfc_match_char (',') != MATCH_YES) 222 { 223 gfc_error ("Invalid form of array reference at %C"); 224 return MATCH_ERROR; 225 } 226 } 227 228 if (ar->dimen >= 7 229 && !gfc_notify_std (GFC_STD_F2008, 230 "Array reference at %C has more than 7 dimensions")) 231 return MATCH_ERROR; 232 233 gfc_error ("Array reference at %C cannot have more than %d dimensions", 234 GFC_MAX_DIMENSIONS); 235 return MATCH_ERROR; 236 237 coarray: 238 if (!matched_bracket && gfc_match_char ('[') != MATCH_YES) 239 { 240 if (ar->dimen > 0) 241 return MATCH_YES; 242 else 243 return MATCH_ERROR; 244 } 245 246 if (flag_coarray == GFC_FCOARRAY_NONE) 247 { 248 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 249 return MATCH_ERROR; 250 } 251 252 if (corank == 0) 253 { 254 gfc_error ("Unexpected coarray designator at %C"); 255 return MATCH_ERROR; 256 } 257 258 ar->stat = NULL; 259 260 for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) 261 { 262 m = match_subscript (ar, init, true); 263 if (m == MATCH_ERROR) 264 return MATCH_ERROR; 265 266 team_just_seen = false; 267 stat_just_seen = false; 268 if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL) 269 { 270 ar->team = tmp; 271 team_just_seen = true; 272 } 273 274 if (ar->team && !team_just_seen) 275 { 276 gfc_error ("TEAM= attribute in %C misplaced"); 277 return MATCH_ERROR; 278 } 279 280 if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL) 281 { 282 ar->stat = tmp; 283 stat_just_seen = true; 284 } 285 286 if (ar->stat && !stat_just_seen) 287 { 288 gfc_error ("STAT= attribute in %C misplaced"); 289 return MATCH_ERROR; 290 } 291 292 if (gfc_match_char (']') == MATCH_YES) 293 { 294 ar->codimen++; 295 if (ar->codimen < corank) 296 { 297 gfc_error ("Too few codimensions at %C, expected %d not %d", 298 corank, ar->codimen); 299 return MATCH_ERROR; 300 } 301 if (ar->codimen > corank) 302 { 303 gfc_error ("Too many codimensions at %C, expected %d not %d", 304 corank, ar->codimen); 305 return MATCH_ERROR; 306 } 307 return MATCH_YES; 308 } 309 310 if (gfc_match_char (',') != MATCH_YES) 311 { 312 if (gfc_match_char ('*') == MATCH_YES) 313 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", 314 ar->codimen + 1, corank); 315 else 316 gfc_error ("Invalid form of coarray reference at %C"); 317 return MATCH_ERROR; 318 } 319 else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR) 320 { 321 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", 322 ar->codimen + 1, corank); 323 return MATCH_ERROR; 324 } 325 326 if (ar->codimen >= corank) 327 { 328 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist", 329 ar->codimen + 1, corank); 330 return MATCH_ERROR; 331 } 332 } 333 334 gfc_error ("Array reference at %C cannot have more than %d dimensions", 335 GFC_MAX_DIMENSIONS); 336 return MATCH_ERROR; 337 338 } 339 340 341 /************** Array specification matching subroutines ***************/ 342 343 /* Free all of the expressions associated with array bounds 344 specifications. */ 345 346 void 347 gfc_free_array_spec (gfc_array_spec *as) 348 { 349 int i; 350 351 if (as == NULL) 352 return; 353 354 if (as->corank == 0) 355 { 356 for (i = 0; i < as->rank; i++) 357 { 358 gfc_free_expr (as->lower[i]); 359 gfc_free_expr (as->upper[i]); 360 } 361 } 362 else 363 { 364 int n = as->rank + as->corank - (as->cotype == AS_EXPLICIT ? 1 : 0); 365 for (i = 0; i < n; i++) 366 { 367 gfc_free_expr (as->lower[i]); 368 gfc_free_expr (as->upper[i]); 369 } 370 } 371 372 free (as); 373 } 374 375 376 /* Take an array bound, resolves the expression, that make up the 377 shape and check associated constraints. */ 378 379 static bool 380 resolve_array_bound (gfc_expr *e, int check_constant) 381 { 382 if (e == NULL) 383 return true; 384 385 if (!gfc_resolve_expr (e) 386 || !gfc_specification_expr (e)) 387 return false; 388 389 if (check_constant && !gfc_is_constant_expr (e)) 390 { 391 if (e->expr_type == EXPR_VARIABLE) 392 gfc_error ("Variable %qs at %L in this context must be constant", 393 e->symtree->n.sym->name, &e->where); 394 else 395 gfc_error ("Expression at %L in this context must be constant", 396 &e->where); 397 return false; 398 } 399 400 return true; 401 } 402 403 404 /* Takes an array specification, resolves the expressions that make up 405 the shape and make sure everything is integral. */ 406 407 bool 408 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) 409 { 410 gfc_expr *e; 411 int i; 412 413 if (as == NULL) 414 return true; 415 416 if (as->resolved) 417 return true; 418 419 for (i = 0; i < as->rank + as->corank; i++) 420 { 421 if (i == GFC_MAX_DIMENSIONS) 422 return false; 423 424 e = as->lower[i]; 425 if (!resolve_array_bound (e, check_constant)) 426 return false; 427 428 e = as->upper[i]; 429 if (!resolve_array_bound (e, check_constant)) 430 return false; 431 432 if ((as->lower[i] == NULL) || (as->upper[i] == NULL)) 433 continue; 434 435 /* If the size is negative in this dimension, set it to zero. */ 436 if (as->lower[i]->expr_type == EXPR_CONSTANT 437 && as->upper[i]->expr_type == EXPR_CONSTANT 438 && mpz_cmp (as->upper[i]->value.integer, 439 as->lower[i]->value.integer) < 0) 440 { 441 gfc_free_expr (as->upper[i]); 442 as->upper[i] = gfc_copy_expr (as->lower[i]); 443 mpz_sub_ui (as->upper[i]->value.integer, 444 as->upper[i]->value.integer, 1); 445 } 446 } 447 448 as->resolved = true; 449 450 return true; 451 } 452 453 454 /* Match a single array element specification. The return values as 455 well as the upper and lower bounds of the array spec are filled 456 in according to what we see on the input. The caller makes sure 457 individual specifications make sense as a whole. 458 459 460 Parsed Lower Upper Returned 461 ------------------------------------ 462 : NULL NULL AS_DEFERRED (*) 463 x 1 x AS_EXPLICIT 464 x: x NULL AS_ASSUMED_SHAPE 465 x:y x y AS_EXPLICIT 466 x:* x NULL AS_ASSUMED_SIZE 467 * 1 NULL AS_ASSUMED_SIZE 468 469 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This 470 is fixed during the resolution of formal interfaces. 471 472 Anything else AS_UNKNOWN. */ 473 474 static array_type 475 match_array_element_spec (gfc_array_spec *as) 476 { 477 gfc_expr **upper, **lower; 478 match m; 479 int rank; 480 481 rank = as->rank == -1 ? 0 : as->rank; 482 lower = &as->lower[rank + as->corank - 1]; 483 upper = &as->upper[rank + as->corank - 1]; 484 485 if (gfc_match_char ('*') == MATCH_YES) 486 { 487 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 488 return AS_ASSUMED_SIZE; 489 } 490 491 if (gfc_match_char (':') == MATCH_YES) 492 return AS_DEFERRED; 493 494 m = gfc_match_expr (upper); 495 if (m == MATCH_NO) 496 gfc_error ("Expected expression in array specification at %C"); 497 if (m != MATCH_YES) 498 return AS_UNKNOWN; 499 if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) 500 return AS_UNKNOWN; 501 502 if (((*upper)->expr_type == EXPR_CONSTANT 503 && (*upper)->ts.type != BT_INTEGER) || 504 ((*upper)->expr_type == EXPR_FUNCTION 505 && (*upper)->ts.type == BT_UNKNOWN 506 && (*upper)->symtree 507 && strcmp ((*upper)->symtree->name, "null") == 0)) 508 { 509 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s", 510 gfc_basic_typename ((*upper)->ts.type)); 511 return AS_UNKNOWN; 512 } 513 514 if (gfc_match_char (':') == MATCH_NO) 515 { 516 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 517 return AS_EXPLICIT; 518 } 519 520 *lower = *upper; 521 *upper = NULL; 522 523 if (gfc_match_char ('*') == MATCH_YES) 524 return AS_ASSUMED_SIZE; 525 526 m = gfc_match_expr (upper); 527 if (m == MATCH_ERROR) 528 return AS_UNKNOWN; 529 if (m == MATCH_NO) 530 return AS_ASSUMED_SHAPE; 531 if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) 532 return AS_UNKNOWN; 533 534 if (((*upper)->expr_type == EXPR_CONSTANT 535 && (*upper)->ts.type != BT_INTEGER) || 536 ((*upper)->expr_type == EXPR_FUNCTION 537 && (*upper)->ts.type == BT_UNKNOWN 538 && (*upper)->symtree 539 && strcmp ((*upper)->symtree->name, "null") == 0)) 540 { 541 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s", 542 gfc_basic_typename ((*upper)->ts.type)); 543 return AS_UNKNOWN; 544 } 545 546 return AS_EXPLICIT; 547 } 548 549 550 /* Matches an array specification, incidentally figuring out what sort 551 it is. Match either a normal array specification, or a coarray spec 552 or both. Optionally allow [:] for coarrays. */ 553 554 match 555 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) 556 { 557 array_type current_type; 558 gfc_array_spec *as; 559 int i; 560 561 as = gfc_get_array_spec (); 562 563 if (!match_dim) 564 goto coarray; 565 566 if (gfc_match_char ('(') != MATCH_YES) 567 { 568 if (!match_codim) 569 goto done; 570 goto coarray; 571 } 572 573 if (gfc_match (" .. )") == MATCH_YES) 574 { 575 as->type = AS_ASSUMED_RANK; 576 as->rank = -1; 577 578 if (!gfc_notify_std (GFC_STD_F2018, "Assumed-rank array at %C")) 579 goto cleanup; 580 581 if (!match_codim) 582 goto done; 583 goto coarray; 584 } 585 586 for (;;) 587 { 588 as->rank++; 589 current_type = match_array_element_spec (as); 590 591 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size 592 and implied-shape specifications. If the rank is at least 2, we can 593 distinguish between them. But for rank 1, we currently return 594 ASSUMED_SIZE; this gets adjusted later when we know for sure 595 whether the symbol parsed is a PARAMETER or not. */ 596 597 if (as->rank == 1) 598 { 599 if (current_type == AS_UNKNOWN) 600 goto cleanup; 601 as->type = current_type; 602 } 603 else 604 switch (as->type) 605 { /* See how current spec meshes with the existing. */ 606 case AS_UNKNOWN: 607 goto cleanup; 608 609 case AS_IMPLIED_SHAPE: 610 if (current_type != AS_ASSUMED_SIZE) 611 { 612 gfc_error ("Bad array specification for implied-shape" 613 " array at %C"); 614 goto cleanup; 615 } 616 break; 617 618 case AS_EXPLICIT: 619 if (current_type == AS_ASSUMED_SIZE) 620 { 621 as->type = AS_ASSUMED_SIZE; 622 break; 623 } 624 625 if (current_type == AS_EXPLICIT) 626 break; 627 628 gfc_error ("Bad array specification for an explicitly shaped " 629 "array at %C"); 630 631 goto cleanup; 632 633 case AS_ASSUMED_SHAPE: 634 if ((current_type == AS_ASSUMED_SHAPE) 635 || (current_type == AS_DEFERRED)) 636 break; 637 638 gfc_error ("Bad array specification for assumed shape " 639 "array at %C"); 640 goto cleanup; 641 642 case AS_DEFERRED: 643 if (current_type == AS_DEFERRED) 644 break; 645 646 if (current_type == AS_ASSUMED_SHAPE) 647 { 648 as->type = AS_ASSUMED_SHAPE; 649 break; 650 } 651 652 gfc_error ("Bad specification for deferred shape array at %C"); 653 goto cleanup; 654 655 case AS_ASSUMED_SIZE: 656 if (as->rank == 2 && current_type == AS_ASSUMED_SIZE) 657 { 658 as->type = AS_IMPLIED_SHAPE; 659 break; 660 } 661 662 gfc_error ("Bad specification for assumed size array at %C"); 663 goto cleanup; 664 665 case AS_ASSUMED_RANK: 666 gcc_unreachable (); 667 } 668 669 if (gfc_match_char (')') == MATCH_YES) 670 break; 671 672 if (gfc_match_char (',') != MATCH_YES) 673 { 674 gfc_error ("Expected another dimension in array declaration at %C"); 675 goto cleanup; 676 } 677 678 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) 679 { 680 gfc_error ("Array specification at %C has more than %d dimensions", 681 GFC_MAX_DIMENSIONS); 682 goto cleanup; 683 } 684 685 if (as->corank + as->rank >= 7 686 && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C " 687 "with more than 7 dimensions")) 688 goto cleanup; 689 } 690 691 if (!match_codim) 692 goto done; 693 694 coarray: 695 if (gfc_match_char ('[') != MATCH_YES) 696 goto done; 697 698 if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C")) 699 goto cleanup; 700 701 if (flag_coarray == GFC_FCOARRAY_NONE) 702 { 703 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 704 goto cleanup; 705 } 706 707 if (as->rank >= GFC_MAX_DIMENSIONS) 708 { 709 gfc_error ("Array specification at %C has more than %d " 710 "dimensions", GFC_MAX_DIMENSIONS); 711 goto cleanup; 712 } 713 714 for (;;) 715 { 716 as->corank++; 717 current_type = match_array_element_spec (as); 718 719 if (current_type == AS_UNKNOWN) 720 goto cleanup; 721 722 if (as->corank == 1) 723 as->cotype = current_type; 724 else 725 switch (as->cotype) 726 { /* See how current spec meshes with the existing. */ 727 case AS_IMPLIED_SHAPE: 728 case AS_UNKNOWN: 729 goto cleanup; 730 731 case AS_EXPLICIT: 732 if (current_type == AS_ASSUMED_SIZE) 733 { 734 as->cotype = AS_ASSUMED_SIZE; 735 break; 736 } 737 738 if (current_type == AS_EXPLICIT) 739 break; 740 741 gfc_error ("Bad array specification for an explicitly " 742 "shaped array at %C"); 743 744 goto cleanup; 745 746 case AS_ASSUMED_SHAPE: 747 if ((current_type == AS_ASSUMED_SHAPE) 748 || (current_type == AS_DEFERRED)) 749 break; 750 751 gfc_error ("Bad array specification for assumed shape " 752 "array at %C"); 753 goto cleanup; 754 755 case AS_DEFERRED: 756 if (current_type == AS_DEFERRED) 757 break; 758 759 if (current_type == AS_ASSUMED_SHAPE) 760 { 761 as->cotype = AS_ASSUMED_SHAPE; 762 break; 763 } 764 765 gfc_error ("Bad specification for deferred shape array at %C"); 766 goto cleanup; 767 768 case AS_ASSUMED_SIZE: 769 gfc_error ("Bad specification for assumed size array at %C"); 770 goto cleanup; 771 772 case AS_ASSUMED_RANK: 773 gcc_unreachable (); 774 } 775 776 if (gfc_match_char (']') == MATCH_YES) 777 break; 778 779 if (gfc_match_char (',') != MATCH_YES) 780 { 781 gfc_error ("Expected another dimension in array declaration at %C"); 782 goto cleanup; 783 } 784 785 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) 786 { 787 gfc_error ("Array specification at %C has more than %d " 788 "dimensions", GFC_MAX_DIMENSIONS); 789 goto cleanup; 790 } 791 } 792 793 if (current_type == AS_EXPLICIT) 794 { 795 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C"); 796 goto cleanup; 797 } 798 799 if (as->cotype == AS_ASSUMED_SIZE) 800 as->cotype = AS_EXPLICIT; 801 802 if (as->rank == 0) 803 as->type = as->cotype; 804 805 done: 806 if (as->rank == 0 && as->corank == 0) 807 { 808 *asp = NULL; 809 gfc_free_array_spec (as); 810 return MATCH_NO; 811 } 812 813 /* If a lower bounds of an assumed shape array is blank, put in one. */ 814 if (as->type == AS_ASSUMED_SHAPE) 815 { 816 for (i = 0; i < as->rank + as->corank; i++) 817 { 818 if (as->lower[i] == NULL) 819 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 820 } 821 } 822 823 *asp = as; 824 825 return MATCH_YES; 826 827 cleanup: 828 /* Something went wrong. */ 829 gfc_free_array_spec (as); 830 return MATCH_ERROR; 831 } 832 833 /* Given a symbol and an array specification, modify the symbol to 834 have that array specification. The error locus is needed in case 835 something goes wrong. On failure, the caller must free the spec. */ 836 837 bool 838 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) 839 { 840 int i; 841 symbol_attribute *attr; 842 843 if (as == NULL) 844 return true; 845 846 /* If the symbol corresponds to a submodule module procedure the array spec is 847 already set, so do not attempt to set it again here. */ 848 attr = &sym->attr; 849 if (gfc_submodule_procedure(attr)) 850 return true; 851 852 if (as->rank 853 && !gfc_add_dimension (&sym->attr, sym->name, error_loc)) 854 return false; 855 856 if (as->corank 857 && !gfc_add_codimension (&sym->attr, sym->name, error_loc)) 858 return false; 859 860 if (sym->as == NULL) 861 { 862 sym->as = as; 863 return true; 864 } 865 866 if ((sym->as->type == AS_ASSUMED_RANK && as->corank) 867 || (as->type == AS_ASSUMED_RANK && sym->as->corank)) 868 { 869 gfc_error ("The assumed-rank array %qs at %L shall not have a " 870 "codimension", sym->name, error_loc); 871 return false; 872 } 873 874 /* Check F2018:C822. */ 875 if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) 876 goto too_many; 877 878 if (as->corank) 879 { 880 sym->as->cotype = as->cotype; 881 sym->as->corank = as->corank; 882 /* Check F2018:C822. */ 883 if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) 884 goto too_many; 885 886 for (i = 0; i < as->corank; i++) 887 { 888 sym->as->lower[sym->as->rank + i] = as->lower[i]; 889 sym->as->upper[sym->as->rank + i] = as->upper[i]; 890 } 891 } 892 else 893 { 894 /* The "sym" has no rank (checked via gfc_add_dimension). Thus 895 the dimension is added - but first the codimensions (if existing 896 need to be shifted to make space for the dimension. */ 897 gcc_assert (as->corank == 0 && sym->as->rank == 0); 898 899 sym->as->rank = as->rank; 900 sym->as->type = as->type; 901 sym->as->cray_pointee = as->cray_pointee; 902 sym->as->cp_was_assumed = as->cp_was_assumed; 903 904 /* Check F2018:C822. */ 905 if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) 906 goto too_many; 907 908 for (i = sym->as->corank - 1; i >= 0; i--) 909 { 910 sym->as->lower[as->rank + i] = sym->as->lower[i]; 911 sym->as->upper[as->rank + i] = sym->as->upper[i]; 912 } 913 for (i = 0; i < as->rank; i++) 914 { 915 sym->as->lower[i] = as->lower[i]; 916 sym->as->upper[i] = as->upper[i]; 917 } 918 } 919 920 free (as); 921 return true; 922 923 too_many: 924 925 gfc_error ("rank + corank of %qs exceeds %d at %C", sym->name, 926 GFC_MAX_DIMENSIONS); 927 return false; 928 } 929 930 931 /* Copy an array specification. */ 932 933 gfc_array_spec * 934 gfc_copy_array_spec (gfc_array_spec *src) 935 { 936 gfc_array_spec *dest; 937 int i; 938 939 if (src == NULL) 940 return NULL; 941 942 dest = gfc_get_array_spec (); 943 944 *dest = *src; 945 946 for (i = 0; i < dest->rank + dest->corank; i++) 947 { 948 dest->lower[i] = gfc_copy_expr (dest->lower[i]); 949 dest->upper[i] = gfc_copy_expr (dest->upper[i]); 950 } 951 952 return dest; 953 } 954 955 956 /* Returns nonzero if the two expressions are equal. 957 We should not need to support more than constant values, as that’s what is 958 allowed in derived type component array spec. However, we may create types 959 with non-constant array spec for dummy variable class container types, for 960 which the _data component holds the array spec of the variable declaration. 961 So we have to support non-constant bounds as well. */ 962 963 static bool 964 compare_bounds (gfc_expr *bound1, gfc_expr *bound2) 965 { 966 if (bound1 == NULL || bound2 == NULL 967 || bound1->ts.type != BT_INTEGER 968 || bound2->ts.type != BT_INTEGER) 969 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered"); 970 971 /* What qualifies as identical bounds? We could probably just check that the 972 expressions are exact clones. We avoid rewriting a specific comparison 973 function and re-use instead the rather involved gfc_dep_compare_expr which 974 is just a bit more permissive, as it can also detect identical values for 975 some mismatching expressions (extra parenthesis, swapped operands, unary 976 plus, etc). It probably only makes a difference in corner cases. */ 977 return gfc_dep_compare_expr (bound1, bound2) == 0; 978 } 979 980 981 /* Compares two array specifications. They must be constant or deferred 982 shape. */ 983 984 int 985 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) 986 { 987 int i; 988 989 if (as1 == NULL && as2 == NULL) 990 return 1; 991 992 if (as1 == NULL || as2 == NULL) 993 return 0; 994 995 if (as1->rank != as2->rank) 996 return 0; 997 998 if (as1->corank != as2->corank) 999 return 0; 1000 1001 if (as1->rank == 0) 1002 return 1; 1003 1004 if (as1->type != as2->type) 1005 return 0; 1006 1007 if (as1->type == AS_EXPLICIT) 1008 for (i = 0; i < as1->rank + as1->corank; i++) 1009 { 1010 if (!compare_bounds (as1->lower[i], as2->lower[i])) 1011 return 0; 1012 1013 if (!compare_bounds (as1->upper[i], as2->upper[i])) 1014 return 0; 1015 } 1016 1017 return 1; 1018 } 1019 1020 1021 /****************** Array constructor functions ******************/ 1022 1023 1024 /* Given an expression node that might be an array constructor and a 1025 symbol, make sure that no iterators in this or child constructors 1026 use the symbol as an implied-DO iterator. Returns nonzero if a 1027 duplicate was found. */ 1028 1029 static int 1030 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) 1031 { 1032 gfc_constructor *c; 1033 gfc_expr *e; 1034 1035 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 1036 { 1037 e = c->expr; 1038 1039 if (e->expr_type == EXPR_ARRAY 1040 && check_duplicate_iterator (e->value.constructor, master)) 1041 return 1; 1042 1043 if (c->iterator == NULL) 1044 continue; 1045 1046 if (c->iterator->var->symtree->n.sym == master) 1047 { 1048 gfc_error ("DO-iterator %qs at %L is inside iterator of the " 1049 "same name", master->name, &c->where); 1050 1051 return 1; 1052 } 1053 } 1054 1055 return 0; 1056 } 1057 1058 1059 /* Forward declaration because these functions are mutually recursive. */ 1060 static match match_array_cons_element (gfc_constructor_base *); 1061 1062 /* Match a list of array elements. */ 1063 1064 static match 1065 match_array_list (gfc_constructor_base *result) 1066 { 1067 gfc_constructor_base head; 1068 gfc_constructor *p; 1069 gfc_iterator iter; 1070 locus old_loc; 1071 gfc_expr *e; 1072 match m; 1073 int n; 1074 1075 old_loc = gfc_current_locus; 1076 1077 if (gfc_match_char ('(') == MATCH_NO) 1078 return MATCH_NO; 1079 1080 memset (&iter, '\0', sizeof (gfc_iterator)); 1081 head = NULL; 1082 1083 m = match_array_cons_element (&head); 1084 if (m != MATCH_YES) 1085 goto cleanup; 1086 1087 if (gfc_match_char (',') != MATCH_YES) 1088 { 1089 m = MATCH_NO; 1090 goto cleanup; 1091 } 1092 1093 for (n = 1;; n++) 1094 { 1095 m = gfc_match_iterator (&iter, 0); 1096 if (m == MATCH_YES) 1097 break; 1098 if (m == MATCH_ERROR) 1099 goto cleanup; 1100 1101 m = match_array_cons_element (&head); 1102 if (m == MATCH_ERROR) 1103 goto cleanup; 1104 if (m == MATCH_NO) 1105 { 1106 if (n > 2) 1107 goto syntax; 1108 m = MATCH_NO; 1109 goto cleanup; /* Could be a complex constant */ 1110 } 1111 1112 if (gfc_match_char (',') != MATCH_YES) 1113 { 1114 if (n > 2) 1115 goto syntax; 1116 m = MATCH_NO; 1117 goto cleanup; 1118 } 1119 } 1120 1121 if (gfc_match_char (')') != MATCH_YES) 1122 goto syntax; 1123 1124 if (check_duplicate_iterator (head, iter.var->symtree->n.sym)) 1125 { 1126 m = MATCH_ERROR; 1127 goto cleanup; 1128 } 1129 1130 e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc); 1131 e->value.constructor = head; 1132 1133 p = gfc_constructor_append_expr (result, e, &gfc_current_locus); 1134 p->iterator = gfc_get_iterator (); 1135 *p->iterator = iter; 1136 1137 return MATCH_YES; 1138 1139 syntax: 1140 gfc_error ("Syntax error in array constructor at %C"); 1141 m = MATCH_ERROR; 1142 1143 cleanup: 1144 gfc_constructor_free (head); 1145 gfc_free_iterator (&iter, 0); 1146 gfc_current_locus = old_loc; 1147 return m; 1148 } 1149 1150 1151 /* Match a single element of an array constructor, which can be a 1152 single expression or a list of elements. */ 1153 1154 static match 1155 match_array_cons_element (gfc_constructor_base *result) 1156 { 1157 gfc_expr *expr; 1158 match m; 1159 1160 m = match_array_list (result); 1161 if (m != MATCH_NO) 1162 return m; 1163 1164 m = gfc_match_expr (&expr); 1165 if (m != MATCH_YES) 1166 return m; 1167 1168 if (expr->ts.type == BT_BOZ) 1169 { 1170 gfc_error ("BOZ literal constant at %L cannot appear in an " 1171 "array constructor", &expr->where); 1172 goto done; 1173 } 1174 1175 if (expr->expr_type == EXPR_FUNCTION 1176 && expr->ts.type == BT_UNKNOWN 1177 && strcmp(expr->symtree->name, "null") == 0) 1178 { 1179 gfc_error ("NULL() at %C cannot appear in an array constructor"); 1180 goto done; 1181 } 1182 1183 gfc_constructor_append_expr (result, expr, &gfc_current_locus); 1184 return MATCH_YES; 1185 1186 done: 1187 gfc_free_expr (expr); 1188 return MATCH_ERROR; 1189 } 1190 1191 1192 /* Convert components of an array constructor to the type in ts. */ 1193 1194 static match 1195 walk_array_constructor (gfc_typespec *ts, gfc_constructor_base head) 1196 { 1197 gfc_constructor *c; 1198 gfc_expr *e; 1199 match m; 1200 1201 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) 1202 { 1203 e = c->expr; 1204 if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_UNKNOWN 1205 && !e->ref && e->value.constructor) 1206 { 1207 m = walk_array_constructor (ts, e->value.constructor); 1208 if (m == MATCH_ERROR) 1209 return m; 1210 } 1211 else if (!gfc_convert_type_warn (e, ts, 1, 1, true) 1212 && e->ts.type != BT_UNKNOWN) 1213 return MATCH_ERROR; 1214 } 1215 return MATCH_YES; 1216 } 1217 1218 /* Match an array constructor. */ 1219 1220 match 1221 gfc_match_array_constructor (gfc_expr **result) 1222 { 1223 gfc_constructor *c; 1224 gfc_constructor_base head; 1225 gfc_expr *expr; 1226 gfc_typespec ts; 1227 locus where; 1228 match m; 1229 const char *end_delim; 1230 bool seen_ts; 1231 1232 head = NULL; 1233 seen_ts = false; 1234 1235 if (gfc_match (" (/") == MATCH_NO) 1236 { 1237 if (gfc_match (" [") == MATCH_NO) 1238 return MATCH_NO; 1239 else 1240 { 1241 if (!gfc_notify_std (GFC_STD_F2003, "[...] " 1242 "style array constructors at %C")) 1243 return MATCH_ERROR; 1244 end_delim = " ]"; 1245 } 1246 } 1247 else 1248 end_delim = " /)"; 1249 1250 where = gfc_current_locus; 1251 1252 /* Try to match an optional "type-spec ::" */ 1253 gfc_clear_ts (&ts); 1254 m = gfc_match_type_spec (&ts); 1255 if (m == MATCH_YES) 1256 { 1257 seen_ts = (gfc_match (" ::") == MATCH_YES); 1258 1259 if (seen_ts) 1260 { 1261 if (!gfc_notify_std (GFC_STD_F2003, "Array constructor " 1262 "including type specification at %C")) 1263 goto cleanup; 1264 1265 if (ts.deferred) 1266 { 1267 gfc_error ("Type-spec at %L cannot contain a deferred " 1268 "type parameter", &where); 1269 goto cleanup; 1270 } 1271 1272 if (ts.type == BT_CHARACTER 1273 && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec) 1274 { 1275 gfc_error ("Type-spec at %L cannot contain an asterisk for a " 1276 "type parameter", &where); 1277 goto cleanup; 1278 } 1279 } 1280 } 1281 else if (m == MATCH_ERROR) 1282 goto cleanup; 1283 1284 if (!seen_ts) 1285 gfc_current_locus = where; 1286 1287 if (gfc_match (end_delim) == MATCH_YES) 1288 { 1289 if (seen_ts) 1290 goto done; 1291 else 1292 { 1293 gfc_error ("Empty array constructor at %C is not allowed"); 1294 goto cleanup; 1295 } 1296 } 1297 1298 for (;;) 1299 { 1300 m = match_array_cons_element (&head); 1301 if (m == MATCH_ERROR) 1302 goto cleanup; 1303 if (m == MATCH_NO) 1304 goto syntax; 1305 1306 if (gfc_match_char (',') == MATCH_NO) 1307 break; 1308 } 1309 1310 if (gfc_match (end_delim) == MATCH_NO) 1311 goto syntax; 1312 1313 done: 1314 /* Size must be calculated at resolution time. */ 1315 if (seen_ts) 1316 { 1317 expr = gfc_get_array_expr (ts.type, ts.kind, &where); 1318 expr->ts = ts; 1319 1320 /* If the typespec is CHARACTER, check that array elements can 1321 be converted. See PR fortran/67803. */ 1322 if (ts.type == BT_CHARACTER) 1323 { 1324 c = gfc_constructor_first (head); 1325 for (; c; c = gfc_constructor_next (c)) 1326 { 1327 if (gfc_numeric_ts (&c->expr->ts) 1328 || c->expr->ts.type == BT_LOGICAL) 1329 { 1330 gfc_error ("Incompatible typespec for array element at %L", 1331 &c->expr->where); 1332 return MATCH_ERROR; 1333 } 1334 1335 /* Special case null(). */ 1336 if (c->expr->expr_type == EXPR_FUNCTION 1337 && c->expr->ts.type == BT_UNKNOWN 1338 && strcmp (c->expr->symtree->name, "null") == 0) 1339 { 1340 gfc_error ("Incompatible typespec for array element at %L", 1341 &c->expr->where); 1342 return MATCH_ERROR; 1343 } 1344 } 1345 } 1346 1347 /* Walk the constructor, and if possible, do type conversion for 1348 numeric types. */ 1349 if (gfc_numeric_ts (&ts)) 1350 { 1351 m = walk_array_constructor (&ts, head); 1352 if (m == MATCH_ERROR) 1353 return m; 1354 } 1355 } 1356 else 1357 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); 1358 1359 expr->value.constructor = head; 1360 if (expr->ts.u.cl) 1361 expr->ts.u.cl->length_from_typespec = seen_ts; 1362 1363 *result = expr; 1364 1365 return MATCH_YES; 1366 1367 syntax: 1368 gfc_error ("Syntax error in array constructor at %C"); 1369 1370 cleanup: 1371 gfc_constructor_free (head); 1372 return MATCH_ERROR; 1373 } 1374 1375 1376 1377 /************** Check array constructors for correctness **************/ 1378 1379 /* Given an expression, compare it's type with the type of the current 1380 constructor. Returns nonzero if an error was issued. The 1381 cons_state variable keeps track of whether the type of the 1382 constructor being read or resolved is known to be good, bad or just 1383 starting out. */ 1384 1385 static gfc_typespec constructor_ts; 1386 static enum 1387 { CONS_START, CONS_GOOD, CONS_BAD } 1388 cons_state; 1389 1390 static int 1391 check_element_type (gfc_expr *expr, bool convert) 1392 { 1393 if (cons_state == CONS_BAD) 1394 return 0; /* Suppress further errors */ 1395 1396 if (cons_state == CONS_START) 1397 { 1398 if (expr->ts.type == BT_UNKNOWN) 1399 cons_state = CONS_BAD; 1400 else 1401 { 1402 cons_state = CONS_GOOD; 1403 constructor_ts = expr->ts; 1404 } 1405 1406 return 0; 1407 } 1408 1409 if (gfc_compare_types (&constructor_ts, &expr->ts)) 1410 return 0; 1411 1412 if (convert) 1413 return gfc_convert_type_warn (expr, &constructor_ts, 1, 1, true) ? 0 : 1; 1414 1415 gfc_error ("Element in %s array constructor at %L is %s", 1416 gfc_typename (&constructor_ts), &expr->where, 1417 gfc_typename (expr)); 1418 1419 cons_state = CONS_BAD; 1420 return 1; 1421 } 1422 1423 1424 /* Recursive work function for gfc_check_constructor_type(). */ 1425 1426 static bool 1427 check_constructor_type (gfc_constructor_base base, bool convert) 1428 { 1429 gfc_constructor *c; 1430 gfc_expr *e; 1431 1432 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 1433 { 1434 e = c->expr; 1435 1436 if (e->expr_type == EXPR_ARRAY) 1437 { 1438 if (!check_constructor_type (e->value.constructor, convert)) 1439 return false; 1440 1441 continue; 1442 } 1443 1444 if (check_element_type (e, convert)) 1445 return false; 1446 } 1447 1448 return true; 1449 } 1450 1451 1452 /* Check that all elements of an array constructor are the same type. 1453 On false, an error has been generated. */ 1454 1455 bool 1456 gfc_check_constructor_type (gfc_expr *e) 1457 { 1458 bool t; 1459 1460 if (e->ts.type != BT_UNKNOWN) 1461 { 1462 cons_state = CONS_GOOD; 1463 constructor_ts = e->ts; 1464 } 1465 else 1466 { 1467 cons_state = CONS_START; 1468 gfc_clear_ts (&constructor_ts); 1469 } 1470 1471 /* If e->ts.type != BT_UNKNOWN, the array constructor included a 1472 typespec, and we will now convert the values on the fly. */ 1473 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN); 1474 if (t && e->ts.type == BT_UNKNOWN) 1475 e->ts = constructor_ts; 1476 1477 return t; 1478 } 1479 1480 1481 1482 typedef struct cons_stack 1483 { 1484 gfc_iterator *iterator; 1485 struct cons_stack *previous; 1486 } 1487 cons_stack; 1488 1489 static cons_stack *base; 1490 1491 static bool check_constructor (gfc_constructor_base, bool (*) (gfc_expr *)); 1492 1493 /* Check an EXPR_VARIABLE expression in a constructor to make sure 1494 that that variable is an iteration variable. */ 1495 1496 bool 1497 gfc_check_iter_variable (gfc_expr *expr) 1498 { 1499 gfc_symbol *sym; 1500 cons_stack *c; 1501 1502 sym = expr->symtree->n.sym; 1503 1504 for (c = base; c && c->iterator; c = c->previous) 1505 if (sym == c->iterator->var->symtree->n.sym) 1506 return true; 1507 1508 return false; 1509 } 1510 1511 1512 /* Recursive work function for gfc_check_constructor(). This amounts 1513 to calling the check function for each expression in the 1514 constructor, giving variables with the names of iterators a pass. */ 1515 1516 static bool 1517 check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *)) 1518 { 1519 cons_stack element; 1520 gfc_expr *e; 1521 bool t; 1522 gfc_constructor *c; 1523 1524 for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c)) 1525 { 1526 e = c->expr; 1527 1528 if (!e) 1529 continue; 1530 1531 if (e->expr_type != EXPR_ARRAY) 1532 { 1533 if (!(*check_function)(e)) 1534 return false; 1535 continue; 1536 } 1537 1538 element.previous = base; 1539 element.iterator = c->iterator; 1540 1541 base = &element; 1542 t = check_constructor (e->value.constructor, check_function); 1543 base = element.previous; 1544 1545 if (!t) 1546 return false; 1547 } 1548 1549 /* Nothing went wrong, so all OK. */ 1550 return true; 1551 } 1552 1553 1554 /* Checks a constructor to see if it is a particular kind of 1555 expression -- specification, restricted, or initialization as 1556 determined by the check_function. */ 1557 1558 bool 1559 gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *)) 1560 { 1561 cons_stack *base_save; 1562 bool t; 1563 1564 base_save = base; 1565 base = NULL; 1566 1567 t = check_constructor (expr->value.constructor, check_function); 1568 base = base_save; 1569 1570 return t; 1571 } 1572 1573 1574 1575 /**************** Simplification of array constructors ****************/ 1576 1577 iterator_stack *iter_stack; 1578 1579 typedef struct 1580 { 1581 gfc_constructor_base base; 1582 int extract_count, extract_n; 1583 gfc_expr *extracted; 1584 mpz_t *count; 1585 1586 mpz_t *offset; 1587 gfc_component *component; 1588 mpz_t *repeat; 1589 1590 bool (*expand_work_function) (gfc_expr *); 1591 } 1592 expand_info; 1593 1594 static expand_info current_expand; 1595 1596 static bool expand_constructor (gfc_constructor_base); 1597 1598 1599 /* Work function that counts the number of elements present in a 1600 constructor. */ 1601 1602 static bool 1603 count_elements (gfc_expr *e) 1604 { 1605 mpz_t result; 1606 1607 if (e->rank == 0) 1608 mpz_add_ui (*current_expand.count, *current_expand.count, 1); 1609 else 1610 { 1611 if (!gfc_array_size (e, &result)) 1612 { 1613 gfc_free_expr (e); 1614 return false; 1615 } 1616 1617 mpz_add (*current_expand.count, *current_expand.count, result); 1618 mpz_clear (result); 1619 } 1620 1621 gfc_free_expr (e); 1622 return true; 1623 } 1624 1625 1626 /* Work function that extracts a particular element from an array 1627 constructor, freeing the rest. */ 1628 1629 static bool 1630 extract_element (gfc_expr *e) 1631 { 1632 if (e->rank != 0) 1633 { /* Something unextractable */ 1634 gfc_free_expr (e); 1635 return false; 1636 } 1637 1638 if (current_expand.extract_count == current_expand.extract_n) 1639 current_expand.extracted = e; 1640 else 1641 gfc_free_expr (e); 1642 1643 current_expand.extract_count++; 1644 1645 return true; 1646 } 1647 1648 1649 /* Work function that constructs a new constructor out of the old one, 1650 stringing new elements together. */ 1651 1652 static bool 1653 expand (gfc_expr *e) 1654 { 1655 gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base, 1656 e, &e->where); 1657 1658 c->n.component = current_expand.component; 1659 return true; 1660 } 1661 1662 1663 /* Given an initialization expression that is a variable reference, 1664 substitute the current value of the iteration variable. */ 1665 1666 void 1667 gfc_simplify_iterator_var (gfc_expr *e) 1668 { 1669 iterator_stack *p; 1670 1671 for (p = iter_stack; p; p = p->prev) 1672 if (e->symtree == p->variable) 1673 break; 1674 1675 if (p == NULL) 1676 return; /* Variable not found */ 1677 1678 gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); 1679 1680 mpz_set (e->value.integer, p->value); 1681 1682 return; 1683 } 1684 1685 1686 /* Expand an expression with that is inside of a constructor, 1687 recursing into other constructors if present. */ 1688 1689 static bool 1690 expand_expr (gfc_expr *e) 1691 { 1692 if (e->expr_type == EXPR_ARRAY) 1693 return expand_constructor (e->value.constructor); 1694 1695 e = gfc_copy_expr (e); 1696 1697 if (!gfc_simplify_expr (e, 1)) 1698 { 1699 gfc_free_expr (e); 1700 return false; 1701 } 1702 1703 return current_expand.expand_work_function (e); 1704 } 1705 1706 1707 static bool 1708 expand_iterator (gfc_constructor *c) 1709 { 1710 gfc_expr *start, *end, *step; 1711 iterator_stack frame; 1712 mpz_t trip; 1713 bool t; 1714 1715 end = step = NULL; 1716 1717 t = false; 1718 1719 mpz_init (trip); 1720 mpz_init (frame.value); 1721 frame.prev = NULL; 1722 1723 start = gfc_copy_expr (c->iterator->start); 1724 if (!gfc_simplify_expr (start, 1)) 1725 goto cleanup; 1726 1727 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER) 1728 goto cleanup; 1729 1730 end = gfc_copy_expr (c->iterator->end); 1731 if (!gfc_simplify_expr (end, 1)) 1732 goto cleanup; 1733 1734 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER) 1735 goto cleanup; 1736 1737 step = gfc_copy_expr (c->iterator->step); 1738 if (!gfc_simplify_expr (step, 1)) 1739 goto cleanup; 1740 1741 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER) 1742 goto cleanup; 1743 1744 if (mpz_sgn (step->value.integer) == 0) 1745 { 1746 gfc_error ("Iterator step at %L cannot be zero", &step->where); 1747 goto cleanup; 1748 } 1749 1750 /* Calculate the trip count of the loop. */ 1751 mpz_sub (trip, end->value.integer, start->value.integer); 1752 mpz_add (trip, trip, step->value.integer); 1753 mpz_tdiv_q (trip, trip, step->value.integer); 1754 1755 mpz_set (frame.value, start->value.integer); 1756 1757 frame.prev = iter_stack; 1758 frame.variable = c->iterator->var->symtree; 1759 iter_stack = &frame; 1760 1761 while (mpz_sgn (trip) > 0) 1762 { 1763 if (!expand_expr (c->expr)) 1764 goto cleanup; 1765 1766 mpz_add (frame.value, frame.value, step->value.integer); 1767 mpz_sub_ui (trip, trip, 1); 1768 } 1769 1770 t = true; 1771 1772 cleanup: 1773 gfc_free_expr (start); 1774 gfc_free_expr (end); 1775 gfc_free_expr (step); 1776 1777 mpz_clear (trip); 1778 mpz_clear (frame.value); 1779 1780 iter_stack = frame.prev; 1781 1782 return t; 1783 } 1784 1785 /* Variables for noticing if all constructors are empty, and 1786 if any of them had a type. */ 1787 1788 static bool empty_constructor; 1789 static gfc_typespec empty_ts; 1790 1791 /* Expand a constructor into constant constructors without any 1792 iterators, calling the work function for each of the expanded 1793 expressions. The work function needs to either save or free the 1794 passed expression. */ 1795 1796 static bool 1797 expand_constructor (gfc_constructor_base base) 1798 { 1799 gfc_constructor *c; 1800 gfc_expr *e; 1801 1802 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c)) 1803 { 1804 if (c->iterator != NULL) 1805 { 1806 if (!expand_iterator (c)) 1807 return false; 1808 continue; 1809 } 1810 1811 e = c->expr; 1812 1813 if (e == NULL) 1814 return false; 1815 1816 if (empty_constructor) 1817 empty_ts = e->ts; 1818 1819 /* Simplify constant array expression/section within constructor. */ 1820 if (e->expr_type == EXPR_VARIABLE && e->rank > 0 && e->ref 1821 && e->symtree && e->symtree->n.sym 1822 && e->symtree->n.sym->attr.flavor == FL_PARAMETER) 1823 gfc_simplify_expr (e, 0); 1824 1825 if (e->expr_type == EXPR_ARRAY) 1826 { 1827 if (!expand_constructor (e->value.constructor)) 1828 return false; 1829 1830 continue; 1831 } 1832 1833 empty_constructor = false; 1834 e = gfc_copy_expr (e); 1835 if (!gfc_simplify_expr (e, 1)) 1836 { 1837 gfc_free_expr (e); 1838 return false; 1839 } 1840 e->from_constructor = 1; 1841 current_expand.offset = &c->offset; 1842 current_expand.repeat = &c->repeat; 1843 current_expand.component = c->n.component; 1844 if (!current_expand.expand_work_function(e)) 1845 return false; 1846 } 1847 return true; 1848 } 1849 1850 1851 /* Given an array expression and an element number (starting at zero), 1852 return a pointer to the array element. NULL is returned if the 1853 size of the array has been exceeded. The expression node returned 1854 remains a part of the array and should not be freed. Access is not 1855 efficient at all, but this is another place where things do not 1856 have to be particularly fast. */ 1857 1858 static gfc_expr * 1859 gfc_get_array_element (gfc_expr *array, int element) 1860 { 1861 expand_info expand_save; 1862 gfc_expr *e; 1863 bool rc; 1864 1865 expand_save = current_expand; 1866 current_expand.extract_n = element; 1867 current_expand.expand_work_function = extract_element; 1868 current_expand.extracted = NULL; 1869 current_expand.extract_count = 0; 1870 1871 iter_stack = NULL; 1872 1873 rc = expand_constructor (array->value.constructor); 1874 e = current_expand.extracted; 1875 current_expand = expand_save; 1876 1877 if (!rc) 1878 return NULL; 1879 1880 return e; 1881 } 1882 1883 1884 /* Top level subroutine for expanding constructors. We only expand 1885 constructor if they are small enough. */ 1886 1887 bool 1888 gfc_expand_constructor (gfc_expr *e, bool fatal) 1889 { 1890 expand_info expand_save; 1891 gfc_expr *f; 1892 bool rc; 1893 1894 if (gfc_is_size_zero_array (e)) 1895 return true; 1896 1897 /* If we can successfully get an array element at the max array size then 1898 the array is too big to expand, so we just return. */ 1899 f = gfc_get_array_element (e, flag_max_array_constructor); 1900 if (f != NULL) 1901 { 1902 gfc_free_expr (f); 1903 if (fatal) 1904 { 1905 gfc_error ("The number of elements in the array constructor " 1906 "at %L requires an increase of the allowed %d " 1907 "upper limit. See %<-fmax-array-constructor%> " 1908 "option", &e->where, flag_max_array_constructor); 1909 return false; 1910 } 1911 return true; 1912 } 1913 1914 /* We now know the array is not too big so go ahead and try to expand it. */ 1915 expand_save = current_expand; 1916 current_expand.base = NULL; 1917 1918 iter_stack = NULL; 1919 1920 empty_constructor = true; 1921 gfc_clear_ts (&empty_ts); 1922 current_expand.expand_work_function = expand; 1923 1924 if (!expand_constructor (e->value.constructor)) 1925 { 1926 gfc_constructor_free (current_expand.base); 1927 rc = false; 1928 goto done; 1929 } 1930 1931 /* If we don't have an explicit constructor type, and there 1932 were only empty constructors, then take the type from 1933 them. */ 1934 1935 if (constructor_ts.type == BT_UNKNOWN && empty_constructor) 1936 e->ts = empty_ts; 1937 1938 gfc_constructor_free (e->value.constructor); 1939 e->value.constructor = current_expand.base; 1940 1941 rc = true; 1942 1943 done: 1944 current_expand = expand_save; 1945 1946 return rc; 1947 } 1948 1949 1950 /* Work function for checking that an element of a constructor is a 1951 constant, after removal of any iteration variables. We return 1952 false if not so. */ 1953 1954 static bool 1955 is_constant_element (gfc_expr *e) 1956 { 1957 int rv; 1958 1959 rv = gfc_is_constant_expr (e); 1960 gfc_free_expr (e); 1961 1962 return rv ? true : false; 1963 } 1964 1965 1966 /* Given an array constructor, determine if the constructor is 1967 constant or not by expanding it and making sure that all elements 1968 are constants. This is a bit of a hack since something like (/ (i, 1969 i=1,100000000) /) will take a while as* opposed to a more clever 1970 function that traverses the expression tree. FIXME. */ 1971 1972 int 1973 gfc_constant_ac (gfc_expr *e) 1974 { 1975 expand_info expand_save; 1976 bool rc; 1977 1978 iter_stack = NULL; 1979 expand_save = current_expand; 1980 current_expand.expand_work_function = is_constant_element; 1981 1982 rc = expand_constructor (e->value.constructor); 1983 1984 current_expand = expand_save; 1985 if (!rc) 1986 return 0; 1987 1988 return 1; 1989 } 1990 1991 1992 /* Returns nonzero if an array constructor has been completely 1993 expanded (no iterators) and zero if iterators are present. */ 1994 1995 int 1996 gfc_expanded_ac (gfc_expr *e) 1997 { 1998 gfc_constructor *c; 1999 2000 if (e->expr_type == EXPR_ARRAY) 2001 for (c = gfc_constructor_first (e->value.constructor); 2002 c; c = gfc_constructor_next (c)) 2003 if (c->iterator != NULL || !gfc_expanded_ac (c->expr)) 2004 return 0; 2005 2006 return 1; 2007 } 2008 2009 2010 /*************** Type resolution of array constructors ***************/ 2011 2012 2013 /* The symbol expr_is_sought_symbol_ref will try to find. */ 2014 static const gfc_symbol *sought_symbol = NULL; 2015 2016 2017 /* Tells whether the expression E is a variable reference to the symbol 2018 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE 2019 accordingly. 2020 To be used with gfc_expr_walker: if a reference is found we don't need 2021 to look further so we return 1 to skip any further walk. */ 2022 2023 static int 2024 expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 2025 void *where) 2026 { 2027 gfc_expr *expr = *e; 2028 locus *sym_loc = (locus *)where; 2029 2030 if (expr->expr_type == EXPR_VARIABLE 2031 && expr->symtree->n.sym == sought_symbol) 2032 { 2033 *sym_loc = expr->where; 2034 return 1; 2035 } 2036 2037 return 0; 2038 } 2039 2040 2041 /* Tells whether the expression EXPR contains a reference to the symbol 2042 SYM and in that case sets the position SYM_LOC where the reference is. */ 2043 2044 static bool 2045 find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc) 2046 { 2047 int ret; 2048 2049 sought_symbol = sym; 2050 ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc); 2051 sought_symbol = NULL; 2052 return ret; 2053 } 2054 2055 2056 /* Recursive array list resolution function. All of the elements must 2057 be of the same type. */ 2058 2059 static bool 2060 resolve_array_list (gfc_constructor_base base) 2061 { 2062 bool t; 2063 gfc_constructor *c; 2064 gfc_iterator *iter; 2065 2066 t = true; 2067 2068 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 2069 { 2070 iter = c->iterator; 2071 if (iter != NULL) 2072 { 2073 gfc_symbol *iter_var; 2074 locus iter_var_loc; 2075 2076 if (!gfc_resolve_iterator (iter, false, true)) 2077 t = false; 2078 2079 /* Check for bounds referencing the iterator variable. */ 2080 gcc_assert (iter->var->expr_type == EXPR_VARIABLE); 2081 iter_var = iter->var->symtree->n.sym; 2082 if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc)) 2083 { 2084 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial " 2085 "expression references control variable " 2086 "at %L", &iter_var_loc)) 2087 t = false; 2088 } 2089 if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc)) 2090 { 2091 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final " 2092 "expression references control variable " 2093 "at %L", &iter_var_loc)) 2094 t = false; 2095 } 2096 if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc)) 2097 { 2098 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step " 2099 "expression references control variable " 2100 "at %L", &iter_var_loc)) 2101 t = false; 2102 } 2103 } 2104 2105 if (!gfc_resolve_expr (c->expr)) 2106 t = false; 2107 2108 if (UNLIMITED_POLY (c->expr)) 2109 { 2110 gfc_error ("Array constructor value at %L shall not be unlimited " 2111 "polymorphic [F2008: C4106]", &c->expr->where); 2112 t = false; 2113 } 2114 } 2115 2116 return t; 2117 } 2118 2119 /* Resolve character array constructor. If it has a specified constant character 2120 length, pad/truncate the elements here; if the length is not specified and 2121 all elements are of compile-time known length, emit an error as this is 2122 invalid. */ 2123 2124 bool 2125 gfc_resolve_character_array_constructor (gfc_expr *expr) 2126 { 2127 gfc_constructor *p; 2128 HOST_WIDE_INT found_length; 2129 2130 gcc_assert (expr->expr_type == EXPR_ARRAY); 2131 gcc_assert (expr->ts.type == BT_CHARACTER); 2132 2133 if (expr->ts.u.cl == NULL) 2134 { 2135 for (p = gfc_constructor_first (expr->value.constructor); 2136 p; p = gfc_constructor_next (p)) 2137 if (p->expr->ts.u.cl != NULL) 2138 { 2139 /* Ensure that if there is a char_len around that it is 2140 used; otherwise the middle-end confuses them! */ 2141 expr->ts.u.cl = p->expr->ts.u.cl; 2142 goto got_charlen; 2143 } 2144 2145 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 2146 } 2147 2148 got_charlen: 2149 2150 /* Early exit for zero size arrays. */ 2151 if (expr->shape) 2152 { 2153 mpz_t size; 2154 HOST_WIDE_INT arraysize; 2155 2156 gfc_array_size (expr, &size); 2157 arraysize = mpz_get_ui (size); 2158 mpz_clear (size); 2159 2160 if (arraysize == 0) 2161 return true; 2162 } 2163 2164 found_length = -1; 2165 2166 if (expr->ts.u.cl->length == NULL) 2167 { 2168 /* Check that all constant string elements have the same length until 2169 we reach the end or find a variable-length one. */ 2170 2171 for (p = gfc_constructor_first (expr->value.constructor); 2172 p; p = gfc_constructor_next (p)) 2173 { 2174 HOST_WIDE_INT current_length = -1; 2175 gfc_ref *ref; 2176 for (ref = p->expr->ref; ref; ref = ref->next) 2177 if (ref->type == REF_SUBSTRING 2178 && ref->u.ss.start 2179 && ref->u.ss.start->expr_type == EXPR_CONSTANT 2180 && ref->u.ss.end 2181 && ref->u.ss.end->expr_type == EXPR_CONSTANT) 2182 break; 2183 2184 if (p->expr->expr_type == EXPR_CONSTANT) 2185 current_length = p->expr->value.character.length; 2186 else if (ref) 2187 current_length = gfc_mpz_get_hwi (ref->u.ss.end->value.integer) 2188 - gfc_mpz_get_hwi (ref->u.ss.start->value.integer) + 1; 2189 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length 2190 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) 2191 current_length = gfc_mpz_get_hwi (p->expr->ts.u.cl->length->value.integer); 2192 else 2193 return true; 2194 2195 if (current_length < 0) 2196 current_length = 0; 2197 2198 if (found_length == -1) 2199 found_length = current_length; 2200 else if (found_length != current_length) 2201 { 2202 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array" 2203 " constructor at %L", (long) found_length, 2204 (long) current_length, &p->expr->where); 2205 return false; 2206 } 2207 2208 gcc_assert (found_length == current_length); 2209 } 2210 2211 gcc_assert (found_length != -1); 2212 2213 /* Update the character length of the array constructor. */ 2214 expr->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, 2215 NULL, found_length); 2216 } 2217 else 2218 { 2219 /* We've got a character length specified. It should be an integer, 2220 otherwise an error is signalled elsewhere. */ 2221 gcc_assert (expr->ts.u.cl->length); 2222 2223 /* If we've got a constant character length, pad according to this. 2224 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets 2225 max_length only if they pass. */ 2226 gfc_extract_hwi (expr->ts.u.cl->length, &found_length); 2227 2228 /* Now pad/truncate the elements accordingly to the specified character 2229 length. This is ok inside this conditional, as in the case above 2230 (without typespec) all elements are verified to have the same length 2231 anyway. */ 2232 if (found_length != -1) 2233 for (p = gfc_constructor_first (expr->value.constructor); 2234 p; p = gfc_constructor_next (p)) 2235 if (p->expr->expr_type == EXPR_CONSTANT) 2236 { 2237 gfc_expr *cl = NULL; 2238 HOST_WIDE_INT current_length = -1; 2239 bool has_ts; 2240 2241 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) 2242 { 2243 cl = p->expr->ts.u.cl->length; 2244 gfc_extract_hwi (cl, ¤t_length); 2245 } 2246 2247 /* If gfc_extract_int above set current_length, we implicitly 2248 know the type is BT_INTEGER and it's EXPR_CONSTANT. */ 2249 2250 has_ts = expr->ts.u.cl->length_from_typespec; 2251 2252 if (! cl 2253 || (current_length != -1 && current_length != found_length)) 2254 gfc_set_constant_character_len (found_length, p->expr, 2255 has_ts ? -1 : found_length); 2256 } 2257 } 2258 2259 return true; 2260 } 2261 2262 2263 /* Resolve all of the expressions in an array list. */ 2264 2265 bool 2266 gfc_resolve_array_constructor (gfc_expr *expr) 2267 { 2268 bool t; 2269 2270 t = resolve_array_list (expr->value.constructor); 2271 if (t) 2272 t = gfc_check_constructor_type (expr); 2273 2274 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after 2275 the call to this function, so we don't need to call it here; if it was 2276 called twice, an error message there would be duplicated. */ 2277 2278 return t; 2279 } 2280 2281 2282 /* Copy an iterator structure. */ 2283 2284 gfc_iterator * 2285 gfc_copy_iterator (gfc_iterator *src) 2286 { 2287 gfc_iterator *dest; 2288 2289 if (src == NULL) 2290 return NULL; 2291 2292 dest = gfc_get_iterator (); 2293 2294 dest->var = gfc_copy_expr (src->var); 2295 dest->start = gfc_copy_expr (src->start); 2296 dest->end = gfc_copy_expr (src->end); 2297 dest->step = gfc_copy_expr (src->step); 2298 dest->unroll = src->unroll; 2299 dest->ivdep = src->ivdep; 2300 dest->vector = src->vector; 2301 dest->novector = src->novector; 2302 2303 return dest; 2304 } 2305 2306 2307 /********* Subroutines for determining the size of an array *********/ 2308 2309 /* These are needed just to accommodate RESHAPE(). There are no 2310 diagnostics here, we just return false if something goes wrong. */ 2311 2312 2313 /* Get the size of single dimension of an array specification. The 2314 array is guaranteed to be one dimensional. */ 2315 2316 bool 2317 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result) 2318 { 2319 if (as == NULL) 2320 return false; 2321 2322 if (dimen < 0 || dimen > as->rank - 1) 2323 gfc_internal_error ("spec_dimen_size(): Bad dimension"); 2324 2325 if (as->type != AS_EXPLICIT 2326 || !as->lower[dimen] 2327 || !as->upper[dimen]) 2328 return false; 2329 2330 if (as->lower[dimen]->expr_type != EXPR_CONSTANT 2331 || as->upper[dimen]->expr_type != EXPR_CONSTANT 2332 || as->lower[dimen]->ts.type != BT_INTEGER 2333 || as->upper[dimen]->ts.type != BT_INTEGER) 2334 return false; 2335 2336 mpz_init (*result); 2337 2338 mpz_sub (*result, as->upper[dimen]->value.integer, 2339 as->lower[dimen]->value.integer); 2340 2341 mpz_add_ui (*result, *result, 1); 2342 2343 if (mpz_cmp_si (*result, 0) < 0) 2344 mpz_set_si (*result, 0); 2345 2346 return true; 2347 } 2348 2349 2350 bool 2351 spec_size (gfc_array_spec *as, mpz_t *result) 2352 { 2353 mpz_t size; 2354 int d; 2355 2356 if (!as || as->type == AS_ASSUMED_RANK) 2357 return false; 2358 2359 mpz_init_set_ui (*result, 1); 2360 2361 for (d = 0; d < as->rank; d++) 2362 { 2363 if (!spec_dimen_size (as, d, &size)) 2364 { 2365 mpz_clear (*result); 2366 return false; 2367 } 2368 2369 mpz_mul (*result, *result, size); 2370 mpz_clear (size); 2371 } 2372 2373 return true; 2374 } 2375 2376 2377 /* Get the number of elements in an array section. Optionally, also supply 2378 the end value. */ 2379 2380 bool 2381 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end) 2382 { 2383 mpz_t upper, lower, stride; 2384 mpz_t diff; 2385 bool t; 2386 gfc_expr *stride_expr = NULL; 2387 2388 if (dimen < 0 || ar == NULL) 2389 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension"); 2390 2391 if (dimen > ar->dimen - 1) 2392 { 2393 gfc_error ("Bad array dimension at %L", &ar->c_where[dimen]); 2394 return false; 2395 } 2396 2397 switch (ar->dimen_type[dimen]) 2398 { 2399 case DIMEN_ELEMENT: 2400 mpz_init (*result); 2401 mpz_set_ui (*result, 1); 2402 t = true; 2403 break; 2404 2405 case DIMEN_VECTOR: 2406 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */ 2407 break; 2408 2409 case DIMEN_RANGE: 2410 2411 mpz_init (stride); 2412 2413 if (ar->stride[dimen] == NULL) 2414 mpz_set_ui (stride, 1); 2415 else 2416 { 2417 stride_expr = gfc_copy_expr(ar->stride[dimen]); 2418 2419 if (!gfc_simplify_expr (stride_expr, 1) 2420 || stride_expr->expr_type != EXPR_CONSTANT 2421 || mpz_cmp_ui (stride_expr->value.integer, 0) == 0) 2422 { 2423 gfc_free_expr (stride_expr); 2424 mpz_clear (stride); 2425 return false; 2426 } 2427 mpz_set (stride, stride_expr->value.integer); 2428 gfc_free_expr(stride_expr); 2429 } 2430 2431 /* Calculate the number of elements via gfc_dep_difference, but only if 2432 start and end are both supplied in the reference or the array spec. 2433 This is to guard against strange but valid code like 2434 2435 subroutine foo(a,n) 2436 real a(1:n) 2437 n = 3 2438 print *,size(a(n-1:)) 2439 2440 where the user changes the value of a variable. If we have to 2441 determine end as well, we cannot do this using gfc_dep_difference. 2442 Fall back to the constants-only code then. */ 2443 2444 if (end == NULL) 2445 { 2446 bool use_dep; 2447 2448 use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen], 2449 &diff); 2450 if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL) 2451 use_dep = gfc_dep_difference (ar->as->upper[dimen], 2452 ar->as->lower[dimen], &diff); 2453 2454 if (use_dep) 2455 { 2456 mpz_init (*result); 2457 mpz_add (*result, diff, stride); 2458 mpz_div (*result, *result, stride); 2459 if (mpz_cmp_ui (*result, 0) < 0) 2460 mpz_set_ui (*result, 0); 2461 2462 mpz_clear (stride); 2463 mpz_clear (diff); 2464 return true; 2465 } 2466 2467 } 2468 2469 /* Constant-only code here, which covers more cases 2470 like a(:4) etc. */ 2471 mpz_init (upper); 2472 mpz_init (lower); 2473 t = false; 2474 2475 if (ar->start[dimen] == NULL) 2476 { 2477 if (ar->as->lower[dimen] == NULL 2478 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT 2479 || ar->as->lower[dimen]->ts.type != BT_INTEGER) 2480 goto cleanup; 2481 mpz_set (lower, ar->as->lower[dimen]->value.integer); 2482 } 2483 else 2484 { 2485 if (ar->start[dimen]->expr_type != EXPR_CONSTANT) 2486 goto cleanup; 2487 mpz_set (lower, ar->start[dimen]->value.integer); 2488 } 2489 2490 if (ar->end[dimen] == NULL) 2491 { 2492 if (ar->as->upper[dimen] == NULL 2493 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT 2494 || ar->as->upper[dimen]->ts.type != BT_INTEGER) 2495 goto cleanup; 2496 mpz_set (upper, ar->as->upper[dimen]->value.integer); 2497 } 2498 else 2499 { 2500 if (ar->end[dimen]->expr_type != EXPR_CONSTANT) 2501 goto cleanup; 2502 mpz_set (upper, ar->end[dimen]->value.integer); 2503 } 2504 2505 mpz_init (*result); 2506 mpz_sub (*result, upper, lower); 2507 mpz_add (*result, *result, stride); 2508 mpz_div (*result, *result, stride); 2509 2510 /* Zero stride caught earlier. */ 2511 if (mpz_cmp_ui (*result, 0) < 0) 2512 mpz_set_ui (*result, 0); 2513 t = true; 2514 2515 if (end) 2516 { 2517 mpz_init (*end); 2518 2519 mpz_sub_ui (*end, *result, 1UL); 2520 mpz_mul (*end, *end, stride); 2521 mpz_add (*end, *end, lower); 2522 } 2523 2524 cleanup: 2525 mpz_clear (upper); 2526 mpz_clear (lower); 2527 mpz_clear (stride); 2528 return t; 2529 2530 default: 2531 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type"); 2532 } 2533 2534 return t; 2535 } 2536 2537 2538 static bool 2539 ref_size (gfc_array_ref *ar, mpz_t *result) 2540 { 2541 mpz_t size; 2542 int d; 2543 2544 mpz_init_set_ui (*result, 1); 2545 2546 for (d = 0; d < ar->dimen; d++) 2547 { 2548 if (!gfc_ref_dimen_size (ar, d, &size, NULL)) 2549 { 2550 mpz_clear (*result); 2551 return false; 2552 } 2553 2554 mpz_mul (*result, *result, size); 2555 mpz_clear (size); 2556 } 2557 2558 return true; 2559 } 2560 2561 2562 /* Given an array expression and a dimension, figure out how many 2563 elements it has along that dimension. Returns true if we were 2564 able to return a result in the 'result' variable, false 2565 otherwise. */ 2566 2567 bool 2568 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) 2569 { 2570 gfc_ref *ref; 2571 int i; 2572 2573 gcc_assert (array != NULL); 2574 2575 if (array->ts.type == BT_CLASS) 2576 return false; 2577 2578 if (array->rank == -1) 2579 return false; 2580 2581 if (dimen < 0 || dimen > array->rank - 1) 2582 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension"); 2583 2584 switch (array->expr_type) 2585 { 2586 case EXPR_VARIABLE: 2587 case EXPR_FUNCTION: 2588 for (ref = array->ref; ref; ref = ref->next) 2589 { 2590 if (ref->type != REF_ARRAY) 2591 continue; 2592 2593 if (ref->u.ar.type == AR_FULL) 2594 return spec_dimen_size (ref->u.ar.as, dimen, result); 2595 2596 if (ref->u.ar.type == AR_SECTION) 2597 { 2598 for (i = 0; dimen >= 0; i++) 2599 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) 2600 dimen--; 2601 2602 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL); 2603 } 2604 } 2605 2606 if (array->shape) 2607 { 2608 mpz_init_set (*result, array->shape[dimen]); 2609 return true; 2610 } 2611 2612 if (array->symtree->n.sym->attr.generic 2613 && array->value.function.esym != NULL) 2614 { 2615 if (!spec_dimen_size (array->value.function.esym->as, dimen, result)) 2616 return false; 2617 } 2618 else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result)) 2619 return false; 2620 2621 break; 2622 2623 case EXPR_ARRAY: 2624 if (array->shape == NULL) { 2625 /* Expressions with rank > 1 should have "shape" properly set */ 2626 if ( array->rank != 1 ) 2627 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr"); 2628 return gfc_array_size(array, result); 2629 } 2630 2631 /* Fall through */ 2632 default: 2633 if (array->shape == NULL) 2634 return false; 2635 2636 mpz_init_set (*result, array->shape[dimen]); 2637 2638 break; 2639 } 2640 2641 return true; 2642 } 2643 2644 2645 /* Given an array expression, figure out how many elements are in the 2646 array. Returns true if this is possible, and sets the 'result' 2647 variable. Otherwise returns false. */ 2648 2649 bool 2650 gfc_array_size (gfc_expr *array, mpz_t *result) 2651 { 2652 expand_info expand_save; 2653 gfc_ref *ref; 2654 int i; 2655 bool t; 2656 2657 if (array->ts.type == BT_CLASS) 2658 return false; 2659 2660 switch (array->expr_type) 2661 { 2662 case EXPR_ARRAY: 2663 gfc_push_suppress_errors (); 2664 2665 expand_save = current_expand; 2666 2667 current_expand.count = result; 2668 mpz_init_set_ui (*result, 0); 2669 2670 current_expand.expand_work_function = count_elements; 2671 iter_stack = NULL; 2672 2673 t = expand_constructor (array->value.constructor); 2674 2675 gfc_pop_suppress_errors (); 2676 2677 if (!t) 2678 mpz_clear (*result); 2679 current_expand = expand_save; 2680 return t; 2681 2682 case EXPR_VARIABLE: 2683 for (ref = array->ref; ref; ref = ref->next) 2684 { 2685 if (ref->type != REF_ARRAY) 2686 continue; 2687 2688 if (ref->u.ar.type == AR_FULL) 2689 return spec_size (ref->u.ar.as, result); 2690 2691 if (ref->u.ar.type == AR_SECTION) 2692 return ref_size (&ref->u.ar, result); 2693 } 2694 2695 return spec_size (array->symtree->n.sym->as, result); 2696 2697 2698 default: 2699 if (array->rank == 0 || array->shape == NULL) 2700 return false; 2701 2702 mpz_init_set_ui (*result, 1); 2703 2704 for (i = 0; i < array->rank; i++) 2705 mpz_mul (*result, *result, array->shape[i]); 2706 2707 break; 2708 } 2709 2710 return true; 2711 } 2712 2713 2714 /* Given an array reference, return the shape of the reference in an 2715 array of mpz_t integers. */ 2716 2717 bool 2718 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape) 2719 { 2720 int d; 2721 int i; 2722 2723 d = 0; 2724 2725 switch (ar->type) 2726 { 2727 case AR_FULL: 2728 for (; d < ar->as->rank; d++) 2729 if (!spec_dimen_size (ar->as, d, &shape[d])) 2730 goto cleanup; 2731 2732 return true; 2733 2734 case AR_SECTION: 2735 for (i = 0; i < ar->dimen; i++) 2736 { 2737 if (ar->dimen_type[i] != DIMEN_ELEMENT) 2738 { 2739 if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL)) 2740 goto cleanup; 2741 d++; 2742 } 2743 } 2744 2745 return true; 2746 2747 default: 2748 break; 2749 } 2750 2751 cleanup: 2752 gfc_clear_shape (shape, d); 2753 return false; 2754 } 2755 2756 2757 /* Given an array expression, find the array reference structure that 2758 characterizes the reference. */ 2759 2760 gfc_array_ref * 2761 gfc_find_array_ref (gfc_expr *e, bool allow_null) 2762 { 2763 gfc_ref *ref; 2764 2765 for (ref = e->ref; ref; ref = ref->next) 2766 if (ref->type == REF_ARRAY 2767 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION)) 2768 break; 2769 2770 if (ref == NULL) 2771 { 2772 if (allow_null) 2773 return NULL; 2774 else 2775 gfc_internal_error ("gfc_find_array_ref(): No ref found"); 2776 } 2777 2778 return &ref->u.ar; 2779 } 2780 2781 2782 /* Find out if an array shape is known at compile time. */ 2783 2784 bool 2785 gfc_is_compile_time_shape (gfc_array_spec *as) 2786 { 2787 if (as->type != AS_EXPLICIT) 2788 return false; 2789 2790 for (int i = 0; i < as->rank; i++) 2791 if (!gfc_is_constant_expr (as->lower[i]) 2792 || !gfc_is_constant_expr (as->upper[i])) 2793 return false; 2794 2795 return true; 2796 } 2797