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