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