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