1 /* Routines for manipulation of expression nodes. 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 "arith.h" 27 #include "match.h" 28 #include "target-memory.h" /* for gfc_convert_boz */ 29 #include "constructor.h" 30 #include "tree.h" 31 32 33 /* The following set of functions provide access to gfc_expr* of 34 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. 35 36 There are two functions available elsewhere that provide 37 slightly different flavours of variables. Namely: 38 expr.c (gfc_get_variable_expr) 39 symbol.c (gfc_lval_expr_from_sym) 40 TODO: Merge these functions, if possible. */ 41 42 /* Get a new expression node. */ 43 44 gfc_expr * 45 gfc_get_expr (void) 46 { 47 gfc_expr *e; 48 49 e = XCNEW (gfc_expr); 50 gfc_clear_ts (&e->ts); 51 e->shape = NULL; 52 e->ref = NULL; 53 e->symtree = NULL; 54 return e; 55 } 56 57 58 /* Get a new expression node that is an array constructor 59 of given type and kind. */ 60 61 gfc_expr * 62 gfc_get_array_expr (bt type, int kind, locus *where) 63 { 64 gfc_expr *e; 65 66 e = gfc_get_expr (); 67 e->expr_type = EXPR_ARRAY; 68 e->value.constructor = NULL; 69 e->rank = 1; 70 e->shape = NULL; 71 72 e->ts.type = type; 73 e->ts.kind = kind; 74 if (where) 75 e->where = *where; 76 77 return e; 78 } 79 80 81 /* Get a new expression node that is the NULL expression. */ 82 83 gfc_expr * 84 gfc_get_null_expr (locus *where) 85 { 86 gfc_expr *e; 87 88 e = gfc_get_expr (); 89 e->expr_type = EXPR_NULL; 90 e->ts.type = BT_UNKNOWN; 91 92 if (where) 93 e->where = *where; 94 95 return e; 96 } 97 98 99 /* Get a new expression node that is an operator expression node. */ 100 101 gfc_expr * 102 gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, 103 gfc_expr *op1, gfc_expr *op2) 104 { 105 gfc_expr *e; 106 107 e = gfc_get_expr (); 108 e->expr_type = EXPR_OP; 109 e->value.op.op = op; 110 e->value.op.op1 = op1; 111 e->value.op.op2 = op2; 112 113 if (where) 114 e->where = *where; 115 116 return e; 117 } 118 119 120 /* Get a new expression node that is an structure constructor 121 of given type and kind. */ 122 123 gfc_expr * 124 gfc_get_structure_constructor_expr (bt type, int kind, locus *where) 125 { 126 gfc_expr *e; 127 128 e = gfc_get_expr (); 129 e->expr_type = EXPR_STRUCTURE; 130 e->value.constructor = NULL; 131 132 e->ts.type = type; 133 e->ts.kind = kind; 134 if (where) 135 e->where = *where; 136 137 return e; 138 } 139 140 141 /* Get a new expression node that is an constant of given type and kind. */ 142 143 gfc_expr * 144 gfc_get_constant_expr (bt type, int kind, locus *where) 145 { 146 gfc_expr *e; 147 148 if (!where) 149 gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be " 150 "NULL"); 151 152 e = gfc_get_expr (); 153 154 e->expr_type = EXPR_CONSTANT; 155 e->ts.type = type; 156 e->ts.kind = kind; 157 e->where = *where; 158 159 switch (type) 160 { 161 case BT_INTEGER: 162 mpz_init (e->value.integer); 163 break; 164 165 case BT_REAL: 166 gfc_set_model_kind (kind); 167 mpfr_init (e->value.real); 168 break; 169 170 case BT_COMPLEX: 171 gfc_set_model_kind (kind); 172 mpc_init2 (e->value.complex, mpfr_get_default_prec()); 173 break; 174 175 default: 176 break; 177 } 178 179 return e; 180 } 181 182 183 /* Get a new expression node that is an string constant. 184 If no string is passed, a string of len is allocated, 185 blanked and null-terminated. */ 186 187 gfc_expr * 188 gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len) 189 { 190 gfc_expr *e; 191 gfc_char_t *dest; 192 193 if (!src) 194 { 195 dest = gfc_get_wide_string (len + 1); 196 gfc_wide_memset (dest, ' ', len); 197 dest[len] = '\0'; 198 } 199 else 200 dest = gfc_char_to_widechar (src); 201 202 e = gfc_get_constant_expr (BT_CHARACTER, kind, 203 where ? where : &gfc_current_locus); 204 e->value.character.string = dest; 205 e->value.character.length = len; 206 207 return e; 208 } 209 210 211 /* Get a new expression node that is an integer constant. */ 212 213 gfc_expr * 214 gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value) 215 { 216 gfc_expr *p; 217 p = gfc_get_constant_expr (BT_INTEGER, kind, 218 where ? where : &gfc_current_locus); 219 220 const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT); 221 wi::to_mpz (w, p->value.integer, SIGNED); 222 223 return p; 224 } 225 226 227 /* Get a new expression node that is a logical constant. */ 228 229 gfc_expr * 230 gfc_get_logical_expr (int kind, locus *where, bool value) 231 { 232 gfc_expr *p; 233 p = gfc_get_constant_expr (BT_LOGICAL, kind, 234 where ? where : &gfc_current_locus); 235 236 p->value.logical = value; 237 238 return p; 239 } 240 241 242 gfc_expr * 243 gfc_get_iokind_expr (locus *where, io_kind k) 244 { 245 gfc_expr *e; 246 247 /* Set the types to something compatible with iokind. This is needed to 248 get through gfc_free_expr later since iokind really has no Basic Type, 249 BT, of its own. */ 250 251 e = gfc_get_expr (); 252 e->expr_type = EXPR_CONSTANT; 253 e->ts.type = BT_LOGICAL; 254 e->value.iokind = k; 255 e->where = *where; 256 257 return e; 258 } 259 260 261 /* Given an expression pointer, return a copy of the expression. This 262 subroutine is recursive. */ 263 264 gfc_expr * 265 gfc_copy_expr (gfc_expr *p) 266 { 267 gfc_expr *q; 268 gfc_char_t *s; 269 char *c; 270 271 if (p == NULL) 272 return NULL; 273 274 q = gfc_get_expr (); 275 *q = *p; 276 277 switch (q->expr_type) 278 { 279 case EXPR_SUBSTRING: 280 s = gfc_get_wide_string (p->value.character.length + 1); 281 q->value.character.string = s; 282 memcpy (s, p->value.character.string, 283 (p->value.character.length + 1) * sizeof (gfc_char_t)); 284 break; 285 286 case EXPR_CONSTANT: 287 /* Copy target representation, if it exists. */ 288 if (p->representation.string) 289 { 290 c = XCNEWVEC (char, p->representation.length + 1); 291 q->representation.string = c; 292 memcpy (c, p->representation.string, (p->representation.length + 1)); 293 } 294 295 /* Copy the values of any pointer components of p->value. */ 296 switch (q->ts.type) 297 { 298 case BT_INTEGER: 299 mpz_init_set (q->value.integer, p->value.integer); 300 break; 301 302 case BT_REAL: 303 gfc_set_model_kind (q->ts.kind); 304 mpfr_init (q->value.real); 305 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); 306 break; 307 308 case BT_COMPLEX: 309 gfc_set_model_kind (q->ts.kind); 310 mpc_init2 (q->value.complex, mpfr_get_default_prec()); 311 mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); 312 break; 313 314 case BT_CHARACTER: 315 if (p->representation.string) 316 q->value.character.string 317 = gfc_char_to_widechar (q->representation.string); 318 else 319 { 320 s = gfc_get_wide_string (p->value.character.length + 1); 321 q->value.character.string = s; 322 323 /* This is the case for the C_NULL_CHAR named constant. */ 324 if (p->value.character.length == 0 325 && (p->ts.is_c_interop || p->ts.is_iso_c)) 326 { 327 *s = '\0'; 328 /* Need to set the length to 1 to make sure the NUL 329 terminator is copied. */ 330 q->value.character.length = 1; 331 } 332 else 333 memcpy (s, p->value.character.string, 334 (p->value.character.length + 1) * sizeof (gfc_char_t)); 335 } 336 break; 337 338 case BT_HOLLERITH: 339 case BT_LOGICAL: 340 case_bt_struct: 341 case BT_CLASS: 342 case BT_ASSUMED: 343 break; /* Already done. */ 344 345 case BT_PROCEDURE: 346 case BT_VOID: 347 /* Should never be reached. */ 348 case BT_UNKNOWN: 349 gfc_internal_error ("gfc_copy_expr(): Bad expr node"); 350 /* Not reached. */ 351 } 352 353 break; 354 355 case EXPR_OP: 356 switch (q->value.op.op) 357 { 358 case INTRINSIC_NOT: 359 case INTRINSIC_PARENTHESES: 360 case INTRINSIC_UPLUS: 361 case INTRINSIC_UMINUS: 362 q->value.op.op1 = gfc_copy_expr (p->value.op.op1); 363 break; 364 365 default: /* Binary operators. */ 366 q->value.op.op1 = gfc_copy_expr (p->value.op.op1); 367 q->value.op.op2 = gfc_copy_expr (p->value.op.op2); 368 break; 369 } 370 371 break; 372 373 case EXPR_FUNCTION: 374 q->value.function.actual = 375 gfc_copy_actual_arglist (p->value.function.actual); 376 break; 377 378 case EXPR_COMPCALL: 379 case EXPR_PPC: 380 q->value.compcall.actual = 381 gfc_copy_actual_arglist (p->value.compcall.actual); 382 q->value.compcall.tbp = p->value.compcall.tbp; 383 break; 384 385 case EXPR_STRUCTURE: 386 case EXPR_ARRAY: 387 q->value.constructor = gfc_constructor_copy (p->value.constructor); 388 break; 389 390 case EXPR_VARIABLE: 391 case EXPR_NULL: 392 break; 393 394 case EXPR_UNKNOWN: 395 gcc_unreachable (); 396 } 397 398 q->shape = gfc_copy_shape (p->shape, p->rank); 399 400 q->ref = gfc_copy_ref (p->ref); 401 402 if (p->param_list) 403 q->param_list = gfc_copy_actual_arglist (p->param_list); 404 405 return q; 406 } 407 408 409 void 410 gfc_clear_shape (mpz_t *shape, int rank) 411 { 412 int i; 413 414 for (i = 0; i < rank; i++) 415 mpz_clear (shape[i]); 416 } 417 418 419 void 420 gfc_free_shape (mpz_t **shape, int rank) 421 { 422 if (*shape == NULL) 423 return; 424 425 gfc_clear_shape (*shape, rank); 426 free (*shape); 427 *shape = NULL; 428 } 429 430 431 /* Workhorse function for gfc_free_expr() that frees everything 432 beneath an expression node, but not the node itself. This is 433 useful when we want to simplify a node and replace it with 434 something else or the expression node belongs to another structure. */ 435 436 static void 437 free_expr0 (gfc_expr *e) 438 { 439 switch (e->expr_type) 440 { 441 case EXPR_CONSTANT: 442 /* Free any parts of the value that need freeing. */ 443 switch (e->ts.type) 444 { 445 case BT_INTEGER: 446 mpz_clear (e->value.integer); 447 break; 448 449 case BT_REAL: 450 mpfr_clear (e->value.real); 451 break; 452 453 case BT_CHARACTER: 454 free (e->value.character.string); 455 break; 456 457 case BT_COMPLEX: 458 mpc_clear (e->value.complex); 459 break; 460 461 default: 462 break; 463 } 464 465 /* Free the representation. */ 466 free (e->representation.string); 467 468 break; 469 470 case EXPR_OP: 471 if (e->value.op.op1 != NULL) 472 gfc_free_expr (e->value.op.op1); 473 if (e->value.op.op2 != NULL) 474 gfc_free_expr (e->value.op.op2); 475 break; 476 477 case EXPR_FUNCTION: 478 gfc_free_actual_arglist (e->value.function.actual); 479 break; 480 481 case EXPR_COMPCALL: 482 case EXPR_PPC: 483 gfc_free_actual_arglist (e->value.compcall.actual); 484 break; 485 486 case EXPR_VARIABLE: 487 break; 488 489 case EXPR_ARRAY: 490 case EXPR_STRUCTURE: 491 gfc_constructor_free (e->value.constructor); 492 break; 493 494 case EXPR_SUBSTRING: 495 free (e->value.character.string); 496 break; 497 498 case EXPR_NULL: 499 break; 500 501 default: 502 gfc_internal_error ("free_expr0(): Bad expr type"); 503 } 504 505 /* Free a shape array. */ 506 gfc_free_shape (&e->shape, e->rank); 507 508 gfc_free_ref_list (e->ref); 509 510 gfc_free_actual_arglist (e->param_list); 511 512 memset (e, '\0', sizeof (gfc_expr)); 513 } 514 515 516 /* Free an expression node and everything beneath it. */ 517 518 void 519 gfc_free_expr (gfc_expr *e) 520 { 521 if (e == NULL) 522 return; 523 free_expr0 (e); 524 free (e); 525 } 526 527 528 /* Free an argument list and everything below it. */ 529 530 void 531 gfc_free_actual_arglist (gfc_actual_arglist *a1) 532 { 533 gfc_actual_arglist *a2; 534 535 while (a1) 536 { 537 a2 = a1->next; 538 if (a1->expr) 539 gfc_free_expr (a1->expr); 540 free (a1); 541 a1 = a2; 542 } 543 } 544 545 546 /* Copy an arglist structure and all of the arguments. */ 547 548 gfc_actual_arglist * 549 gfc_copy_actual_arglist (gfc_actual_arglist *p) 550 { 551 gfc_actual_arglist *head, *tail, *new_arg; 552 553 head = tail = NULL; 554 555 for (; p; p = p->next) 556 { 557 new_arg = gfc_get_actual_arglist (); 558 *new_arg = *p; 559 560 new_arg->expr = gfc_copy_expr (p->expr); 561 new_arg->next = NULL; 562 563 if (head == NULL) 564 head = new_arg; 565 else 566 tail->next = new_arg; 567 568 tail = new_arg; 569 } 570 571 return head; 572 } 573 574 575 /* Free a list of reference structures. */ 576 577 void 578 gfc_free_ref_list (gfc_ref *p) 579 { 580 gfc_ref *q; 581 int i; 582 583 for (; p; p = q) 584 { 585 q = p->next; 586 587 switch (p->type) 588 { 589 case REF_ARRAY: 590 for (i = 0; i < GFC_MAX_DIMENSIONS; i++) 591 { 592 gfc_free_expr (p->u.ar.start[i]); 593 gfc_free_expr (p->u.ar.end[i]); 594 gfc_free_expr (p->u.ar.stride[i]); 595 } 596 597 break; 598 599 case REF_SUBSTRING: 600 gfc_free_expr (p->u.ss.start); 601 gfc_free_expr (p->u.ss.end); 602 break; 603 604 case REF_COMPONENT: 605 case REF_INQUIRY: 606 break; 607 } 608 609 free (p); 610 } 611 } 612 613 614 /* Graft the *src expression onto the *dest subexpression. */ 615 616 void 617 gfc_replace_expr (gfc_expr *dest, gfc_expr *src) 618 { 619 free_expr0 (dest); 620 *dest = *src; 621 free (src); 622 } 623 624 625 /* Try to extract an integer constant from the passed expression node. 626 Return true if some error occurred, false on success. If REPORT_ERROR 627 is non-zero, emit error, for positive REPORT_ERROR using gfc_error, 628 for negative using gfc_error_now. */ 629 630 bool 631 gfc_extract_int (gfc_expr *expr, int *result, int report_error) 632 { 633 gfc_ref *ref; 634 635 /* A KIND component is a parameter too. The expression for it 636 is stored in the initializer and should be consistent with 637 the tests below. */ 638 if (gfc_expr_attr(expr).pdt_kind) 639 { 640 for (ref = expr->ref; ref; ref = ref->next) 641 { 642 if (ref->u.c.component->attr.pdt_kind) 643 expr = ref->u.c.component->initializer; 644 } 645 } 646 647 if (expr->expr_type != EXPR_CONSTANT) 648 { 649 if (report_error > 0) 650 gfc_error ("Constant expression required at %C"); 651 else if (report_error < 0) 652 gfc_error_now ("Constant expression required at %C"); 653 return true; 654 } 655 656 if (expr->ts.type != BT_INTEGER) 657 { 658 if (report_error > 0) 659 gfc_error ("Integer expression required at %C"); 660 else if (report_error < 0) 661 gfc_error_now ("Integer expression required at %C"); 662 return true; 663 } 664 665 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) 666 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) 667 { 668 if (report_error > 0) 669 gfc_error ("Integer value too large in expression at %C"); 670 else if (report_error < 0) 671 gfc_error_now ("Integer value too large in expression at %C"); 672 return true; 673 } 674 675 *result = (int) mpz_get_si (expr->value.integer); 676 677 return false; 678 } 679 680 681 /* Same as gfc_extract_int, but use a HWI. */ 682 683 bool 684 gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error) 685 { 686 gfc_ref *ref; 687 688 /* A KIND component is a parameter too. The expression for it is 689 stored in the initializer and should be consistent with the tests 690 below. */ 691 if (gfc_expr_attr(expr).pdt_kind) 692 { 693 for (ref = expr->ref; ref; ref = ref->next) 694 { 695 if (ref->u.c.component->attr.pdt_kind) 696 expr = ref->u.c.component->initializer; 697 } 698 } 699 700 if (expr->expr_type != EXPR_CONSTANT) 701 { 702 if (report_error > 0) 703 gfc_error ("Constant expression required at %C"); 704 else if (report_error < 0) 705 gfc_error_now ("Constant expression required at %C"); 706 return true; 707 } 708 709 if (expr->ts.type != BT_INTEGER) 710 { 711 if (report_error > 0) 712 gfc_error ("Integer expression required at %C"); 713 else if (report_error < 0) 714 gfc_error_now ("Integer expression required at %C"); 715 return true; 716 } 717 718 /* Use long_long_integer_type_node to determine when to saturate. */ 719 const wide_int val = wi::from_mpz (long_long_integer_type_node, 720 expr->value.integer, false); 721 722 if (!wi::fits_shwi_p (val)) 723 { 724 if (report_error > 0) 725 gfc_error ("Integer value too large in expression at %C"); 726 else if (report_error < 0) 727 gfc_error_now ("Integer value too large in expression at %C"); 728 return true; 729 } 730 731 *result = val.to_shwi (); 732 733 return false; 734 } 735 736 737 /* Recursively copy a list of reference structures. */ 738 739 gfc_ref * 740 gfc_copy_ref (gfc_ref *src) 741 { 742 gfc_array_ref *ar; 743 gfc_ref *dest; 744 745 if (src == NULL) 746 return NULL; 747 748 dest = gfc_get_ref (); 749 dest->type = src->type; 750 751 switch (src->type) 752 { 753 case REF_ARRAY: 754 ar = gfc_copy_array_ref (&src->u.ar); 755 dest->u.ar = *ar; 756 free (ar); 757 break; 758 759 case REF_COMPONENT: 760 dest->u.c = src->u.c; 761 break; 762 763 case REF_INQUIRY: 764 dest->u.i = src->u.i; 765 break; 766 767 case REF_SUBSTRING: 768 dest->u.ss = src->u.ss; 769 dest->u.ss.start = gfc_copy_expr (src->u.ss.start); 770 dest->u.ss.end = gfc_copy_expr (src->u.ss.end); 771 break; 772 } 773 774 dest->next = gfc_copy_ref (src->next); 775 776 return dest; 777 } 778 779 780 /* Detect whether an expression has any vector index array references. */ 781 782 int 783 gfc_has_vector_index (gfc_expr *e) 784 { 785 gfc_ref *ref; 786 int i; 787 for (ref = e->ref; ref; ref = ref->next) 788 if (ref->type == REF_ARRAY) 789 for (i = 0; i < ref->u.ar.dimen; i++) 790 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 791 return 1; 792 return 0; 793 } 794 795 796 /* Copy a shape array. */ 797 798 mpz_t * 799 gfc_copy_shape (mpz_t *shape, int rank) 800 { 801 mpz_t *new_shape; 802 int n; 803 804 if (shape == NULL) 805 return NULL; 806 807 new_shape = gfc_get_shape (rank); 808 809 for (n = 0; n < rank; n++) 810 mpz_init_set (new_shape[n], shape[n]); 811 812 return new_shape; 813 } 814 815 816 /* Copy a shape array excluding dimension N, where N is an integer 817 constant expression. Dimensions are numbered in Fortran style -- 818 starting with ONE. 819 820 So, if the original shape array contains R elements 821 { s1 ... sN-1 sN sN+1 ... sR-1 sR} 822 the result contains R-1 elements: 823 { s1 ... sN-1 sN+1 ... sR-1} 824 825 If anything goes wrong -- N is not a constant, its value is out 826 of range -- or anything else, just returns NULL. */ 827 828 mpz_t * 829 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) 830 { 831 mpz_t *new_shape, *s; 832 int i, n; 833 834 if (shape == NULL 835 || rank <= 1 836 || dim == NULL 837 || dim->expr_type != EXPR_CONSTANT 838 || dim->ts.type != BT_INTEGER) 839 return NULL; 840 841 n = mpz_get_si (dim->value.integer); 842 n--; /* Convert to zero based index. */ 843 if (n < 0 || n >= rank) 844 return NULL; 845 846 s = new_shape = gfc_get_shape (rank - 1); 847 848 for (i = 0; i < rank; i++) 849 { 850 if (i == n) 851 continue; 852 mpz_init_set (*s, shape[i]); 853 s++; 854 } 855 856 return new_shape; 857 } 858 859 860 /* Return the maximum kind of two expressions. In general, higher 861 kind numbers mean more precision for numeric types. */ 862 863 int 864 gfc_kind_max (gfc_expr *e1, gfc_expr *e2) 865 { 866 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; 867 } 868 869 870 /* Returns nonzero if the type is numeric, zero otherwise. */ 871 872 static int 873 numeric_type (bt type) 874 { 875 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; 876 } 877 878 879 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */ 880 881 int 882 gfc_numeric_ts (gfc_typespec *ts) 883 { 884 return numeric_type (ts->type); 885 } 886 887 888 /* Return an expression node with an optional argument list attached. 889 A variable number of gfc_expr pointers are strung together in an 890 argument list with a NULL pointer terminating the list. */ 891 892 gfc_expr * 893 gfc_build_conversion (gfc_expr *e) 894 { 895 gfc_expr *p; 896 897 p = gfc_get_expr (); 898 p->expr_type = EXPR_FUNCTION; 899 p->symtree = NULL; 900 p->value.function.actual = gfc_get_actual_arglist (); 901 p->value.function.actual->expr = e; 902 903 return p; 904 } 905 906 907 /* Given an expression node with some sort of numeric binary 908 expression, insert type conversions required to make the operands 909 have the same type. Conversion warnings are disabled if wconversion 910 is set to 0. 911 912 The exception is that the operands of an exponential don't have to 913 have the same type. If possible, the base is promoted to the type 914 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but 915 1.0**2 stays as it is. */ 916 917 void 918 gfc_type_convert_binary (gfc_expr *e, int wconversion) 919 { 920 gfc_expr *op1, *op2; 921 922 op1 = e->value.op.op1; 923 op2 = e->value.op.op2; 924 925 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) 926 { 927 gfc_clear_ts (&e->ts); 928 return; 929 } 930 931 /* Kind conversions of same type. */ 932 if (op1->ts.type == op2->ts.type) 933 { 934 if (op1->ts.kind == op2->ts.kind) 935 { 936 /* No type conversions. */ 937 e->ts = op1->ts; 938 goto done; 939 } 940 941 if (op1->ts.kind > op2->ts.kind) 942 gfc_convert_type_warn (op2, &op1->ts, 2, wconversion); 943 else 944 gfc_convert_type_warn (op1, &op2->ts, 2, wconversion); 945 946 e->ts = op1->ts; 947 goto done; 948 } 949 950 /* Integer combined with real or complex. */ 951 if (op2->ts.type == BT_INTEGER) 952 { 953 e->ts = op1->ts; 954 955 /* Special case for ** operator. */ 956 if (e->value.op.op == INTRINSIC_POWER) 957 goto done; 958 959 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); 960 goto done; 961 } 962 963 if (op1->ts.type == BT_INTEGER) 964 { 965 e->ts = op2->ts; 966 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); 967 goto done; 968 } 969 970 /* Real combined with complex. */ 971 e->ts.type = BT_COMPLEX; 972 if (op1->ts.kind > op2->ts.kind) 973 e->ts.kind = op1->ts.kind; 974 else 975 e->ts.kind = op2->ts.kind; 976 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) 977 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); 978 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) 979 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); 980 981 done: 982 return; 983 } 984 985 986 /* Determine if an expression is constant in the sense of F08:7.1.12. 987 * This function expects that the expression has already been simplified. */ 988 989 bool 990 gfc_is_constant_expr (gfc_expr *e) 991 { 992 gfc_constructor *c; 993 gfc_actual_arglist *arg; 994 995 if (e == NULL) 996 return true; 997 998 switch (e->expr_type) 999 { 1000 case EXPR_OP: 1001 return (gfc_is_constant_expr (e->value.op.op1) 1002 && (e->value.op.op2 == NULL 1003 || gfc_is_constant_expr (e->value.op.op2))); 1004 1005 case EXPR_VARIABLE: 1006 /* The only context in which this can occur is in a parameterized 1007 derived type declaration, so returning true is OK. */ 1008 if (e->symtree->n.sym->attr.pdt_len 1009 || e->symtree->n.sym->attr.pdt_kind) 1010 return true; 1011 return false; 1012 1013 case EXPR_FUNCTION: 1014 case EXPR_PPC: 1015 case EXPR_COMPCALL: 1016 gcc_assert (e->symtree || e->value.function.esym 1017 || e->value.function.isym); 1018 1019 /* Call to intrinsic with at least one argument. */ 1020 if (e->value.function.isym && e->value.function.actual) 1021 { 1022 for (arg = e->value.function.actual; arg; arg = arg->next) 1023 if (!gfc_is_constant_expr (arg->expr)) 1024 return false; 1025 } 1026 1027 if (e->value.function.isym 1028 && (e->value.function.isym->elemental 1029 || e->value.function.isym->pure 1030 || e->value.function.isym->inquiry 1031 || e->value.function.isym->transformational)) 1032 return true; 1033 1034 return false; 1035 1036 case EXPR_CONSTANT: 1037 case EXPR_NULL: 1038 return true; 1039 1040 case EXPR_SUBSTRING: 1041 return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) 1042 && gfc_is_constant_expr (e->ref->u.ss.end)); 1043 1044 case EXPR_ARRAY: 1045 case EXPR_STRUCTURE: 1046 c = gfc_constructor_first (e->value.constructor); 1047 if ((e->expr_type == EXPR_ARRAY) && c && c->iterator) 1048 return gfc_constant_ac (e); 1049 1050 for (; c; c = gfc_constructor_next (c)) 1051 if (!gfc_is_constant_expr (c->expr)) 1052 return false; 1053 1054 return true; 1055 1056 1057 default: 1058 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); 1059 return false; 1060 } 1061 } 1062 1063 1064 /* Is true if the expression or symbol is a passed CFI descriptor. */ 1065 bool 1066 is_CFI_desc (gfc_symbol *sym, gfc_expr *e) 1067 { 1068 if (sym == NULL 1069 && e && e->expr_type == EXPR_VARIABLE) 1070 sym = e->symtree->n.sym; 1071 1072 if (sym && sym->attr.dummy 1073 && sym->ns->proc_name->attr.is_bind_c 1074 && sym->attr.dimension 1075 && (sym->attr.pointer 1076 || sym->attr.allocatable 1077 || sym->as->type == AS_ASSUMED_SHAPE 1078 || sym->as->type == AS_ASSUMED_RANK)) 1079 return true; 1080 1081 return false; 1082 } 1083 1084 1085 /* Is true if an array reference is followed by a component or substring 1086 reference. */ 1087 bool 1088 is_subref_array (gfc_expr * e) 1089 { 1090 gfc_ref * ref; 1091 bool seen_array; 1092 gfc_symbol *sym; 1093 1094 if (e->expr_type != EXPR_VARIABLE) 1095 return false; 1096 1097 sym = e->symtree->n.sym; 1098 1099 if (sym->attr.subref_array_pointer) 1100 return true; 1101 1102 seen_array = false; 1103 1104 for (ref = e->ref; ref; ref = ref->next) 1105 { 1106 /* If we haven't seen the array reference and this is an intrinsic, 1107 what follows cannot be a subreference array, unless there is a 1108 substring reference. */ 1109 if (!seen_array && ref->type == REF_COMPONENT 1110 && ref->u.c.component->ts.type != BT_CHARACTER 1111 && ref->u.c.component->ts.type != BT_CLASS 1112 && !gfc_bt_struct (ref->u.c.component->ts.type)) 1113 return false; 1114 1115 if (ref->type == REF_ARRAY 1116 && ref->u.ar.type != AR_ELEMENT) 1117 seen_array = true; 1118 1119 if (seen_array 1120 && ref->type != REF_ARRAY) 1121 return seen_array; 1122 } 1123 1124 if (sym->ts.type == BT_CLASS 1125 && sym->attr.dummy 1126 && CLASS_DATA (sym)->attr.dimension 1127 && CLASS_DATA (sym)->attr.class_pointer) 1128 return true; 1129 1130 return false; 1131 } 1132 1133 1134 /* Try to collapse intrinsic expressions. */ 1135 1136 static bool 1137 simplify_intrinsic_op (gfc_expr *p, int type) 1138 { 1139 gfc_intrinsic_op op; 1140 gfc_expr *op1, *op2, *result; 1141 1142 if (p->value.op.op == INTRINSIC_USER) 1143 return true; 1144 1145 op1 = p->value.op.op1; 1146 op2 = p->value.op.op2; 1147 op = p->value.op.op; 1148 1149 if (!gfc_simplify_expr (op1, type)) 1150 return false; 1151 if (!gfc_simplify_expr (op2, type)) 1152 return false; 1153 1154 if (!gfc_is_constant_expr (op1) 1155 || (op2 != NULL && !gfc_is_constant_expr (op2))) 1156 return true; 1157 1158 /* Rip p apart. */ 1159 p->value.op.op1 = NULL; 1160 p->value.op.op2 = NULL; 1161 1162 switch (op) 1163 { 1164 case INTRINSIC_PARENTHESES: 1165 result = gfc_parentheses (op1); 1166 break; 1167 1168 case INTRINSIC_UPLUS: 1169 result = gfc_uplus (op1); 1170 break; 1171 1172 case INTRINSIC_UMINUS: 1173 result = gfc_uminus (op1); 1174 break; 1175 1176 case INTRINSIC_PLUS: 1177 result = gfc_add (op1, op2); 1178 break; 1179 1180 case INTRINSIC_MINUS: 1181 result = gfc_subtract (op1, op2); 1182 break; 1183 1184 case INTRINSIC_TIMES: 1185 result = gfc_multiply (op1, op2); 1186 break; 1187 1188 case INTRINSIC_DIVIDE: 1189 result = gfc_divide (op1, op2); 1190 break; 1191 1192 case INTRINSIC_POWER: 1193 result = gfc_power (op1, op2); 1194 break; 1195 1196 case INTRINSIC_CONCAT: 1197 result = gfc_concat (op1, op2); 1198 break; 1199 1200 case INTRINSIC_EQ: 1201 case INTRINSIC_EQ_OS: 1202 result = gfc_eq (op1, op2, op); 1203 break; 1204 1205 case INTRINSIC_NE: 1206 case INTRINSIC_NE_OS: 1207 result = gfc_ne (op1, op2, op); 1208 break; 1209 1210 case INTRINSIC_GT: 1211 case INTRINSIC_GT_OS: 1212 result = gfc_gt (op1, op2, op); 1213 break; 1214 1215 case INTRINSIC_GE: 1216 case INTRINSIC_GE_OS: 1217 result = gfc_ge (op1, op2, op); 1218 break; 1219 1220 case INTRINSIC_LT: 1221 case INTRINSIC_LT_OS: 1222 result = gfc_lt (op1, op2, op); 1223 break; 1224 1225 case INTRINSIC_LE: 1226 case INTRINSIC_LE_OS: 1227 result = gfc_le (op1, op2, op); 1228 break; 1229 1230 case INTRINSIC_NOT: 1231 result = gfc_not (op1); 1232 break; 1233 1234 case INTRINSIC_AND: 1235 result = gfc_and (op1, op2); 1236 break; 1237 1238 case INTRINSIC_OR: 1239 result = gfc_or (op1, op2); 1240 break; 1241 1242 case INTRINSIC_EQV: 1243 result = gfc_eqv (op1, op2); 1244 break; 1245 1246 case INTRINSIC_NEQV: 1247 result = gfc_neqv (op1, op2); 1248 break; 1249 1250 default: 1251 gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); 1252 } 1253 1254 if (result == NULL) 1255 { 1256 gfc_free_expr (op1); 1257 gfc_free_expr (op2); 1258 return false; 1259 } 1260 1261 result->rank = p->rank; 1262 result->where = p->where; 1263 gfc_replace_expr (p, result); 1264 1265 return true; 1266 } 1267 1268 1269 /* Subroutine to simplify constructor expressions. Mutually recursive 1270 with gfc_simplify_expr(). */ 1271 1272 static bool 1273 simplify_constructor (gfc_constructor_base base, int type) 1274 { 1275 gfc_constructor *c; 1276 gfc_expr *p; 1277 1278 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 1279 { 1280 if (c->iterator 1281 && (!gfc_simplify_expr(c->iterator->start, type) 1282 || !gfc_simplify_expr (c->iterator->end, type) 1283 || !gfc_simplify_expr (c->iterator->step, type))) 1284 return false; 1285 1286 if (c->expr) 1287 { 1288 /* Try and simplify a copy. Replace the original if successful 1289 but keep going through the constructor at all costs. Not 1290 doing so can make a dog's dinner of complicated things. */ 1291 p = gfc_copy_expr (c->expr); 1292 1293 if (!gfc_simplify_expr (p, type)) 1294 { 1295 gfc_free_expr (p); 1296 continue; 1297 } 1298 1299 gfc_replace_expr (c->expr, p); 1300 } 1301 } 1302 1303 return true; 1304 } 1305 1306 1307 /* Pull a single array element out of an array constructor. */ 1308 1309 static bool 1310 find_array_element (gfc_constructor_base base, gfc_array_ref *ar, 1311 gfc_constructor **rval) 1312 { 1313 unsigned long nelemen; 1314 int i; 1315 mpz_t delta; 1316 mpz_t offset; 1317 mpz_t span; 1318 mpz_t tmp; 1319 gfc_constructor *cons; 1320 gfc_expr *e; 1321 bool t; 1322 1323 t = true; 1324 e = NULL; 1325 1326 mpz_init_set_ui (offset, 0); 1327 mpz_init (delta); 1328 mpz_init (tmp); 1329 mpz_init_set_ui (span, 1); 1330 for (i = 0; i < ar->dimen; i++) 1331 { 1332 if (!gfc_reduce_init_expr (ar->as->lower[i]) 1333 || !gfc_reduce_init_expr (ar->as->upper[i])) 1334 { 1335 t = false; 1336 cons = NULL; 1337 goto depart; 1338 } 1339 1340 e = ar->start[i]; 1341 if (e->expr_type != EXPR_CONSTANT) 1342 { 1343 cons = NULL; 1344 goto depart; 1345 } 1346 1347 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT 1348 && ar->as->lower[i]->expr_type == EXPR_CONSTANT); 1349 1350 /* Check the bounds. */ 1351 if ((ar->as->upper[i] 1352 && mpz_cmp (e->value.integer, 1353 ar->as->upper[i]->value.integer) > 0) 1354 || (mpz_cmp (e->value.integer, 1355 ar->as->lower[i]->value.integer) < 0)) 1356 { 1357 gfc_error ("Index in dimension %d is out of bounds " 1358 "at %L", i + 1, &ar->c_where[i]); 1359 cons = NULL; 1360 t = false; 1361 goto depart; 1362 } 1363 1364 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); 1365 mpz_mul (delta, delta, span); 1366 mpz_add (offset, offset, delta); 1367 1368 mpz_set_ui (tmp, 1); 1369 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer); 1370 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); 1371 mpz_mul (span, span, tmp); 1372 } 1373 1374 for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); 1375 cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) 1376 { 1377 if (cons->iterator) 1378 { 1379 cons = NULL; 1380 goto depart; 1381 } 1382 } 1383 1384 depart: 1385 mpz_clear (delta); 1386 mpz_clear (offset); 1387 mpz_clear (span); 1388 mpz_clear (tmp); 1389 *rval = cons; 1390 return t; 1391 } 1392 1393 1394 /* Find a component of a structure constructor. */ 1395 1396 static gfc_constructor * 1397 find_component_ref (gfc_constructor_base base, gfc_ref *ref) 1398 { 1399 gfc_component *pick = ref->u.c.component; 1400 gfc_constructor *c = gfc_constructor_first (base); 1401 1402 gfc_symbol *dt = ref->u.c.sym; 1403 int ext = dt->attr.extension; 1404 1405 /* For extended types, check if the desired component is in one of the 1406 * parent types. */ 1407 while (ext > 0 && gfc_find_component (dt->components->ts.u.derived, 1408 pick->name, true, true, NULL)) 1409 { 1410 dt = dt->components->ts.u.derived; 1411 c = gfc_constructor_first (c->expr->value.constructor); 1412 ext--; 1413 } 1414 1415 gfc_component *comp = dt->components; 1416 while (comp != pick) 1417 { 1418 comp = comp->next; 1419 c = gfc_constructor_next (c); 1420 } 1421 1422 return c; 1423 } 1424 1425 1426 /* Replace an expression with the contents of a constructor, removing 1427 the subobject reference in the process. */ 1428 1429 static void 1430 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) 1431 { 1432 gfc_expr *e; 1433 1434 if (cons) 1435 { 1436 e = cons->expr; 1437 cons->expr = NULL; 1438 } 1439 else 1440 e = gfc_copy_expr (p); 1441 e->ref = p->ref->next; 1442 p->ref->next = NULL; 1443 gfc_replace_expr (p, e); 1444 } 1445 1446 1447 /* Pull an array section out of an array constructor. */ 1448 1449 static bool 1450 find_array_section (gfc_expr *expr, gfc_ref *ref) 1451 { 1452 int idx; 1453 int rank; 1454 int d; 1455 int shape_i; 1456 int limit; 1457 long unsigned one = 1; 1458 bool incr_ctr; 1459 mpz_t start[GFC_MAX_DIMENSIONS]; 1460 mpz_t end[GFC_MAX_DIMENSIONS]; 1461 mpz_t stride[GFC_MAX_DIMENSIONS]; 1462 mpz_t delta[GFC_MAX_DIMENSIONS]; 1463 mpz_t ctr[GFC_MAX_DIMENSIONS]; 1464 mpz_t delta_mpz; 1465 mpz_t tmp_mpz; 1466 mpz_t nelts; 1467 mpz_t ptr; 1468 gfc_constructor_base base; 1469 gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; 1470 gfc_expr *begin; 1471 gfc_expr *finish; 1472 gfc_expr *step; 1473 gfc_expr *upper; 1474 gfc_expr *lower; 1475 bool t; 1476 1477 t = true; 1478 1479 base = expr->value.constructor; 1480 expr->value.constructor = NULL; 1481 1482 rank = ref->u.ar.as->rank; 1483 1484 if (expr->shape == NULL) 1485 expr->shape = gfc_get_shape (rank); 1486 1487 mpz_init_set_ui (delta_mpz, one); 1488 mpz_init_set_ui (nelts, one); 1489 mpz_init (tmp_mpz); 1490 1491 /* Do the initialization now, so that we can cleanup without 1492 keeping track of where we were. */ 1493 for (d = 0; d < rank; d++) 1494 { 1495 mpz_init (delta[d]); 1496 mpz_init (start[d]); 1497 mpz_init (end[d]); 1498 mpz_init (ctr[d]); 1499 mpz_init (stride[d]); 1500 vecsub[d] = NULL; 1501 } 1502 1503 /* Build the counters to clock through the array reference. */ 1504 shape_i = 0; 1505 for (d = 0; d < rank; d++) 1506 { 1507 /* Make this stretch of code easier on the eye! */ 1508 begin = ref->u.ar.start[d]; 1509 finish = ref->u.ar.end[d]; 1510 step = ref->u.ar.stride[d]; 1511 lower = ref->u.ar.as->lower[d]; 1512 upper = ref->u.ar.as->upper[d]; 1513 1514 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ 1515 { 1516 gfc_constructor *ci; 1517 gcc_assert (begin); 1518 1519 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) 1520 { 1521 t = false; 1522 goto cleanup; 1523 } 1524 1525 gcc_assert (begin->rank == 1); 1526 /* Zero-sized arrays have no shape and no elements, stop early. */ 1527 if (!begin->shape) 1528 { 1529 mpz_init_set_ui (nelts, 0); 1530 break; 1531 } 1532 1533 vecsub[d] = gfc_constructor_first (begin->value.constructor); 1534 mpz_set (ctr[d], vecsub[d]->expr->value.integer); 1535 mpz_mul (nelts, nelts, begin->shape[0]); 1536 mpz_set (expr->shape[shape_i++], begin->shape[0]); 1537 1538 /* Check bounds. */ 1539 for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) 1540 { 1541 if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 1542 || mpz_cmp (ci->expr->value.integer, 1543 lower->value.integer) < 0) 1544 { 1545 gfc_error ("index in dimension %d is out of bounds " 1546 "at %L", d + 1, &ref->u.ar.c_where[d]); 1547 t = false; 1548 goto cleanup; 1549 } 1550 } 1551 } 1552 else 1553 { 1554 if ((begin && begin->expr_type != EXPR_CONSTANT) 1555 || (finish && finish->expr_type != EXPR_CONSTANT) 1556 || (step && step->expr_type != EXPR_CONSTANT)) 1557 { 1558 t = false; 1559 goto cleanup; 1560 } 1561 1562 /* Obtain the stride. */ 1563 if (step) 1564 mpz_set (stride[d], step->value.integer); 1565 else 1566 mpz_set_ui (stride[d], one); 1567 1568 if (mpz_cmp_ui (stride[d], 0) == 0) 1569 mpz_set_ui (stride[d], one); 1570 1571 /* Obtain the start value for the index. */ 1572 if (begin) 1573 mpz_set (start[d], begin->value.integer); 1574 else 1575 mpz_set (start[d], lower->value.integer); 1576 1577 mpz_set (ctr[d], start[d]); 1578 1579 /* Obtain the end value for the index. */ 1580 if (finish) 1581 mpz_set (end[d], finish->value.integer); 1582 else 1583 mpz_set (end[d], upper->value.integer); 1584 1585 /* Separate 'if' because elements sometimes arrive with 1586 non-null end. */ 1587 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) 1588 mpz_set (end [d], begin->value.integer); 1589 1590 /* Check the bounds. */ 1591 if (mpz_cmp (ctr[d], upper->value.integer) > 0 1592 || mpz_cmp (end[d], upper->value.integer) > 0 1593 || mpz_cmp (ctr[d], lower->value.integer) < 0 1594 || mpz_cmp (end[d], lower->value.integer) < 0) 1595 { 1596 gfc_error ("index in dimension %d is out of bounds " 1597 "at %L", d + 1, &ref->u.ar.c_where[d]); 1598 t = false; 1599 goto cleanup; 1600 } 1601 1602 /* Calculate the number of elements and the shape. */ 1603 mpz_set (tmp_mpz, stride[d]); 1604 mpz_add (tmp_mpz, end[d], tmp_mpz); 1605 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); 1606 mpz_div (tmp_mpz, tmp_mpz, stride[d]); 1607 mpz_mul (nelts, nelts, tmp_mpz); 1608 1609 /* An element reference reduces the rank of the expression; don't 1610 add anything to the shape array. */ 1611 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) 1612 mpz_set (expr->shape[shape_i++], tmp_mpz); 1613 } 1614 1615 /* Calculate the 'stride' (=delta) for conversion of the 1616 counter values into the index along the constructor. */ 1617 mpz_set (delta[d], delta_mpz); 1618 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); 1619 mpz_add_ui (tmp_mpz, tmp_mpz, one); 1620 mpz_mul (delta_mpz, delta_mpz, tmp_mpz); 1621 } 1622 1623 mpz_init (ptr); 1624 cons = gfc_constructor_first (base); 1625 1626 /* Now clock through the array reference, calculating the index in 1627 the source constructor and transferring the elements to the new 1628 constructor. */ 1629 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) 1630 { 1631 mpz_init_set_ui (ptr, 0); 1632 1633 incr_ctr = true; 1634 for (d = 0; d < rank; d++) 1635 { 1636 mpz_set (tmp_mpz, ctr[d]); 1637 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer); 1638 mpz_mul (tmp_mpz, tmp_mpz, delta[d]); 1639 mpz_add (ptr, ptr, tmp_mpz); 1640 1641 if (!incr_ctr) continue; 1642 1643 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ 1644 { 1645 gcc_assert(vecsub[d]); 1646 1647 if (!gfc_constructor_next (vecsub[d])) 1648 vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); 1649 else 1650 { 1651 vecsub[d] = gfc_constructor_next (vecsub[d]); 1652 incr_ctr = false; 1653 } 1654 mpz_set (ctr[d], vecsub[d]->expr->value.integer); 1655 } 1656 else 1657 { 1658 mpz_add (ctr[d], ctr[d], stride[d]); 1659 1660 if (mpz_cmp_ui (stride[d], 0) > 0 1661 ? mpz_cmp (ctr[d], end[d]) > 0 1662 : mpz_cmp (ctr[d], end[d]) < 0) 1663 mpz_set (ctr[d], start[d]); 1664 else 1665 incr_ctr = false; 1666 } 1667 } 1668 1669 limit = mpz_get_ui (ptr); 1670 if (limit >= flag_max_array_constructor) 1671 { 1672 gfc_error ("The number of elements in the array constructor " 1673 "at %L requires an increase of the allowed %d " 1674 "upper limit. See %<-fmax-array-constructor%> " 1675 "option", &expr->where, flag_max_array_constructor); 1676 return false; 1677 } 1678 1679 cons = gfc_constructor_lookup (base, limit); 1680 gcc_assert (cons); 1681 gfc_constructor_append_expr (&expr->value.constructor, 1682 gfc_copy_expr (cons->expr), NULL); 1683 } 1684 1685 mpz_clear (ptr); 1686 1687 cleanup: 1688 1689 mpz_clear (delta_mpz); 1690 mpz_clear (tmp_mpz); 1691 mpz_clear (nelts); 1692 for (d = 0; d < rank; d++) 1693 { 1694 mpz_clear (delta[d]); 1695 mpz_clear (start[d]); 1696 mpz_clear (end[d]); 1697 mpz_clear (ctr[d]); 1698 mpz_clear (stride[d]); 1699 } 1700 gfc_constructor_free (base); 1701 return t; 1702 } 1703 1704 /* Pull a substring out of an expression. */ 1705 1706 static bool 1707 find_substring_ref (gfc_expr *p, gfc_expr **newp) 1708 { 1709 gfc_charlen_t end; 1710 gfc_charlen_t start; 1711 gfc_charlen_t length; 1712 gfc_char_t *chr; 1713 1714 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT 1715 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) 1716 return false; 1717 1718 *newp = gfc_copy_expr (p); 1719 free ((*newp)->value.character.string); 1720 1721 end = (gfc_charlen_t) mpz_get_ui (p->ref->u.ss.end->value.integer); 1722 start = (gfc_charlen_t) mpz_get_ui (p->ref->u.ss.start->value.integer); 1723 if (end >= start) 1724 length = end - start + 1; 1725 else 1726 length = 0; 1727 1728 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); 1729 (*newp)->value.character.length = length; 1730 memcpy (chr, &p->value.character.string[start - 1], 1731 length * sizeof (gfc_char_t)); 1732 chr[length] = '\0'; 1733 return true; 1734 } 1735 1736 1737 /* Pull an inquiry result out of an expression. */ 1738 1739 static bool 1740 find_inquiry_ref (gfc_expr *p, gfc_expr **newp) 1741 { 1742 gfc_ref *ref; 1743 gfc_ref *inquiry = NULL; 1744 gfc_expr *tmp; 1745 1746 tmp = gfc_copy_expr (p); 1747 1748 if (tmp->ref && tmp->ref->type == REF_INQUIRY) 1749 { 1750 inquiry = tmp->ref; 1751 tmp->ref = NULL; 1752 } 1753 else 1754 { 1755 for (ref = tmp->ref; ref; ref = ref->next) 1756 if (ref->next && ref->next->type == REF_INQUIRY) 1757 { 1758 inquiry = ref->next; 1759 ref->next = NULL; 1760 } 1761 } 1762 1763 if (!inquiry) 1764 { 1765 gfc_free_expr (tmp); 1766 return false; 1767 } 1768 1769 gfc_resolve_expr (tmp); 1770 1771 /* In principle there can be more than one inquiry reference. */ 1772 for (; inquiry; inquiry = inquiry->next) 1773 { 1774 switch (inquiry->u.i) 1775 { 1776 case INQUIRY_LEN: 1777 if (tmp->ts.type != BT_CHARACTER) 1778 goto cleanup; 1779 1780 if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) 1781 goto cleanup; 1782 1783 if (tmp->ts.u.cl->length 1784 && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) 1785 *newp = gfc_copy_expr (tmp->ts.u.cl->length); 1786 else if (tmp->expr_type == EXPR_CONSTANT) 1787 *newp = gfc_get_int_expr (gfc_default_integer_kind, 1788 NULL, tmp->value.character.length); 1789 else 1790 goto cleanup; 1791 1792 break; 1793 1794 case INQUIRY_KIND: 1795 if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS) 1796 goto cleanup; 1797 1798 if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) 1799 goto cleanup; 1800 1801 *newp = gfc_get_int_expr (gfc_default_integer_kind, 1802 NULL, tmp->ts.kind); 1803 break; 1804 1805 case INQUIRY_RE: 1806 if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) 1807 goto cleanup; 1808 1809 if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) 1810 goto cleanup; 1811 1812 *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); 1813 mpfr_set ((*newp)->value.real, 1814 mpc_realref (tmp->value.complex), GFC_RND_MODE); 1815 break; 1816 1817 case INQUIRY_IM: 1818 if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) 1819 goto cleanup; 1820 1821 if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) 1822 goto cleanup; 1823 1824 *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); 1825 mpfr_set ((*newp)->value.real, 1826 mpc_imagref (tmp->value.complex), GFC_RND_MODE); 1827 break; 1828 } 1829 tmp = gfc_copy_expr (*newp); 1830 } 1831 1832 if (!(*newp)) 1833 goto cleanup; 1834 else if ((*newp)->expr_type != EXPR_CONSTANT) 1835 { 1836 gfc_free_expr (*newp); 1837 goto cleanup; 1838 } 1839 1840 gfc_free_expr (tmp); 1841 return true; 1842 1843 cleanup: 1844 gfc_free_expr (tmp); 1845 return false; 1846 } 1847 1848 1849 1850 /* Simplify a subobject reference of a constructor. This occurs when 1851 parameter variable values are substituted. */ 1852 1853 static bool 1854 simplify_const_ref (gfc_expr *p) 1855 { 1856 gfc_constructor *cons, *c; 1857 gfc_expr *newp = NULL; 1858 gfc_ref *last_ref; 1859 1860 while (p->ref) 1861 { 1862 switch (p->ref->type) 1863 { 1864 case REF_ARRAY: 1865 switch (p->ref->u.ar.type) 1866 { 1867 case AR_ELEMENT: 1868 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr 1869 will generate this. */ 1870 if (p->expr_type != EXPR_ARRAY) 1871 { 1872 remove_subobject_ref (p, NULL); 1873 break; 1874 } 1875 if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons)) 1876 return false; 1877 1878 if (!cons) 1879 return true; 1880 1881 remove_subobject_ref (p, cons); 1882 break; 1883 1884 case AR_SECTION: 1885 if (!find_array_section (p, p->ref)) 1886 return false; 1887 p->ref->u.ar.type = AR_FULL; 1888 1889 /* Fall through. */ 1890 1891 case AR_FULL: 1892 if (p->ref->next != NULL 1893 && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type))) 1894 { 1895 for (c = gfc_constructor_first (p->value.constructor); 1896 c; c = gfc_constructor_next (c)) 1897 { 1898 c->expr->ref = gfc_copy_ref (p->ref->next); 1899 if (!simplify_const_ref (c->expr)) 1900 return false; 1901 } 1902 1903 if (gfc_bt_struct (p->ts.type) 1904 && p->ref->next 1905 && (c = gfc_constructor_first (p->value.constructor))) 1906 { 1907 /* There may have been component references. */ 1908 p->ts = c->expr->ts; 1909 } 1910 1911 last_ref = p->ref; 1912 for (; last_ref->next; last_ref = last_ref->next) {}; 1913 1914 if (p->ts.type == BT_CHARACTER 1915 && last_ref->type == REF_SUBSTRING) 1916 { 1917 /* If this is a CHARACTER array and we possibly took 1918 a substring out of it, update the type-spec's 1919 character length according to the first element 1920 (as all should have the same length). */ 1921 gfc_charlen_t string_len; 1922 if ((c = gfc_constructor_first (p->value.constructor))) 1923 { 1924 const gfc_expr* first = c->expr; 1925 gcc_assert (first->expr_type == EXPR_CONSTANT); 1926 gcc_assert (first->ts.type == BT_CHARACTER); 1927 string_len = first->value.character.length; 1928 } 1929 else 1930 string_len = 0; 1931 1932 if (!p->ts.u.cl) 1933 { 1934 if (p->symtree) 1935 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, 1936 NULL); 1937 else 1938 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, 1939 NULL); 1940 } 1941 else 1942 gfc_free_expr (p->ts.u.cl->length); 1943 1944 p->ts.u.cl->length 1945 = gfc_get_int_expr (gfc_charlen_int_kind, 1946 NULL, string_len); 1947 } 1948 } 1949 gfc_free_ref_list (p->ref); 1950 p->ref = NULL; 1951 break; 1952 1953 default: 1954 return true; 1955 } 1956 1957 break; 1958 1959 case REF_COMPONENT: 1960 cons = find_component_ref (p->value.constructor, p->ref); 1961 remove_subobject_ref (p, cons); 1962 break; 1963 1964 case REF_INQUIRY: 1965 if (!find_inquiry_ref (p, &newp)) 1966 return false; 1967 1968 gfc_replace_expr (p, newp); 1969 gfc_free_ref_list (p->ref); 1970 p->ref = NULL; 1971 break; 1972 1973 case REF_SUBSTRING: 1974 if (!find_substring_ref (p, &newp)) 1975 return false; 1976 1977 gfc_replace_expr (p, newp); 1978 gfc_free_ref_list (p->ref); 1979 p->ref = NULL; 1980 break; 1981 } 1982 } 1983 1984 return true; 1985 } 1986 1987 1988 /* Simplify a chain of references. */ 1989 1990 static bool 1991 simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p) 1992 { 1993 int n; 1994 gfc_expr *newp; 1995 1996 for (; ref; ref = ref->next) 1997 { 1998 switch (ref->type) 1999 { 2000 case REF_ARRAY: 2001 for (n = 0; n < ref->u.ar.dimen; n++) 2002 { 2003 if (!gfc_simplify_expr (ref->u.ar.start[n], type)) 2004 return false; 2005 if (!gfc_simplify_expr (ref->u.ar.end[n], type)) 2006 return false; 2007 if (!gfc_simplify_expr (ref->u.ar.stride[n], type)) 2008 return false; 2009 } 2010 break; 2011 2012 case REF_SUBSTRING: 2013 if (!gfc_simplify_expr (ref->u.ss.start, type)) 2014 return false; 2015 if (!gfc_simplify_expr (ref->u.ss.end, type)) 2016 return false; 2017 break; 2018 2019 case REF_INQUIRY: 2020 if (!find_inquiry_ref (*p, &newp)) 2021 return false; 2022 2023 gfc_replace_expr (*p, newp); 2024 gfc_free_ref_list ((*p)->ref); 2025 (*p)->ref = NULL; 2026 return true; 2027 2028 default: 2029 break; 2030 } 2031 } 2032 return true; 2033 } 2034 2035 2036 /* Try to substitute the value of a parameter variable. */ 2037 2038 static bool 2039 simplify_parameter_variable (gfc_expr *p, int type) 2040 { 2041 gfc_expr *e; 2042 bool t; 2043 2044 if (gfc_is_size_zero_array (p)) 2045 { 2046 if (p->expr_type == EXPR_ARRAY) 2047 return true; 2048 2049 e = gfc_get_expr (); 2050 e->expr_type = EXPR_ARRAY; 2051 e->ts = p->ts; 2052 e->rank = p->rank; 2053 e->value.constructor = NULL; 2054 e->shape = gfc_copy_shape (p->shape, p->rank); 2055 e->where = p->where; 2056 gfc_replace_expr (p, e); 2057 return true; 2058 } 2059 2060 e = gfc_copy_expr (p->symtree->n.sym->value); 2061 if (e == NULL) 2062 return false; 2063 2064 e->rank = p->rank; 2065 2066 /* Do not copy subobject refs for constant. */ 2067 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) 2068 e->ref = gfc_copy_ref (p->ref); 2069 t = gfc_simplify_expr (e, type); 2070 2071 /* Only use the simplification if it eliminated all subobject references. */ 2072 if (t && !e->ref) 2073 gfc_replace_expr (p, e); 2074 else 2075 gfc_free_expr (e); 2076 2077 return t; 2078 } 2079 2080 2081 static bool 2082 scalarize_intrinsic_call (gfc_expr *, bool init_flag); 2083 2084 /* Given an expression, simplify it by collapsing constant 2085 expressions. Most simplification takes place when the expression 2086 tree is being constructed. If an intrinsic function is simplified 2087 at some point, we get called again to collapse the result against 2088 other constants. 2089 2090 We work by recursively simplifying expression nodes, simplifying 2091 intrinsic functions where possible, which can lead to further 2092 constant collapsing. If an operator has constant operand(s), we 2093 rip the expression apart, and rebuild it, hoping that it becomes 2094 something simpler. 2095 2096 The expression type is defined for: 2097 0 Basic expression parsing 2098 1 Simplifying array constructors -- will substitute 2099 iterator values. 2100 Returns false on error, true otherwise. 2101 NOTE: Will return true even if the expression cannot be simplified. */ 2102 2103 bool 2104 gfc_simplify_expr (gfc_expr *p, int type) 2105 { 2106 gfc_actual_arglist *ap; 2107 gfc_intrinsic_sym* isym = NULL; 2108 2109 2110 if (p == NULL) 2111 return true; 2112 2113 switch (p->expr_type) 2114 { 2115 case EXPR_CONSTANT: 2116 if (p->ref && p->ref->type == REF_INQUIRY) 2117 simplify_ref_chain (p->ref, type, &p); 2118 break; 2119 case EXPR_NULL: 2120 break; 2121 2122 case EXPR_FUNCTION: 2123 // For array-bound functions, we don't need to optimize 2124 // the 'array' argument. In particular, if the argument 2125 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE 2126 // into an EXPR_ARRAY; the latter has lbound = 1, the former 2127 // can have any lbound. 2128 ap = p->value.function.actual; 2129 if (p->value.function.isym && 2130 (p->value.function.isym->id == GFC_ISYM_LBOUND 2131 || p->value.function.isym->id == GFC_ISYM_UBOUND 2132 || p->value.function.isym->id == GFC_ISYM_LCOBOUND 2133 || p->value.function.isym->id == GFC_ISYM_UCOBOUND)) 2134 ap = ap->next; 2135 2136 for ( ; ap; ap = ap->next) 2137 if (!gfc_simplify_expr (ap->expr, type)) 2138 return false; 2139 2140 if (p->value.function.isym != NULL 2141 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) 2142 return false; 2143 2144 if (p->expr_type == EXPR_FUNCTION) 2145 { 2146 if (p->symtree) 2147 isym = gfc_find_function (p->symtree->n.sym->name); 2148 if (isym && isym->elemental) 2149 scalarize_intrinsic_call (p, false); 2150 } 2151 2152 break; 2153 2154 case EXPR_SUBSTRING: 2155 if (!simplify_ref_chain (p->ref, type, &p)) 2156 return false; 2157 2158 if (gfc_is_constant_expr (p)) 2159 { 2160 gfc_char_t *s; 2161 HOST_WIDE_INT start, end; 2162 2163 start = 0; 2164 if (p->ref && p->ref->u.ss.start) 2165 { 2166 gfc_extract_hwi (p->ref->u.ss.start, &start); 2167 start--; /* Convert from one-based to zero-based. */ 2168 } 2169 2170 end = p->value.character.length; 2171 if (p->ref && p->ref->u.ss.end) 2172 gfc_extract_hwi (p->ref->u.ss.end, &end); 2173 2174 if (end < start) 2175 end = start; 2176 2177 s = gfc_get_wide_string (end - start + 2); 2178 memcpy (s, p->value.character.string + start, 2179 (end - start) * sizeof (gfc_char_t)); 2180 s[end - start + 1] = '\0'; /* TODO: C-style string. */ 2181 free (p->value.character.string); 2182 p->value.character.string = s; 2183 p->value.character.length = end - start; 2184 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 2185 p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, 2186 NULL, 2187 p->value.character.length); 2188 gfc_free_ref_list (p->ref); 2189 p->ref = NULL; 2190 p->expr_type = EXPR_CONSTANT; 2191 } 2192 break; 2193 2194 case EXPR_OP: 2195 if (!simplify_intrinsic_op (p, type)) 2196 return false; 2197 break; 2198 2199 case EXPR_VARIABLE: 2200 /* Only substitute array parameter variables if we are in an 2201 initialization expression, or we want a subsection. */ 2202 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER 2203 && (gfc_init_expr_flag || p->ref 2204 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) 2205 { 2206 if (!simplify_parameter_variable (p, type)) 2207 return false; 2208 break; 2209 } 2210 2211 if (type == 1) 2212 { 2213 gfc_simplify_iterator_var (p); 2214 } 2215 2216 /* Simplify subcomponent references. */ 2217 if (!simplify_ref_chain (p->ref, type, &p)) 2218 return false; 2219 2220 break; 2221 2222 case EXPR_STRUCTURE: 2223 case EXPR_ARRAY: 2224 if (!simplify_ref_chain (p->ref, type, &p)) 2225 return false; 2226 2227 /* If the following conditions hold, we found something like kind type 2228 inquiry of the form a(2)%kind while simplify the ref chain. */ 2229 if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape) 2230 return true; 2231 2232 if (!simplify_constructor (p->value.constructor, type)) 2233 return false; 2234 2235 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY 2236 && p->ref->u.ar.type == AR_FULL) 2237 gfc_expand_constructor (p, false); 2238 2239 if (!simplify_const_ref (p)) 2240 return false; 2241 2242 break; 2243 2244 case EXPR_COMPCALL: 2245 case EXPR_PPC: 2246 break; 2247 2248 case EXPR_UNKNOWN: 2249 gcc_unreachable (); 2250 } 2251 2252 return true; 2253 } 2254 2255 2256 /* Returns the type of an expression with the exception that iterator 2257 variables are automatically integers no matter what else they may 2258 be declared as. */ 2259 2260 static bt 2261 et0 (gfc_expr *e) 2262 { 2263 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e)) 2264 return BT_INTEGER; 2265 2266 return e->ts.type; 2267 } 2268 2269 2270 /* Scalarize an expression for an elemental intrinsic call. */ 2271 2272 static bool 2273 scalarize_intrinsic_call (gfc_expr *e, bool init_flag) 2274 { 2275 gfc_actual_arglist *a, *b; 2276 gfc_constructor_base ctor; 2277 gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */ 2278 gfc_constructor *ci, *new_ctor; 2279 gfc_expr *expr, *old; 2280 int n, i, rank[5], array_arg; 2281 int errors = 0; 2282 2283 if (e == NULL) 2284 return false; 2285 2286 a = e->value.function.actual; 2287 for (; a; a = a->next) 2288 if (a->expr && !gfc_is_constant_expr (a->expr)) 2289 return false; 2290 2291 /* Find which, if any, arguments are arrays. Assume that the old 2292 expression carries the type information and that the first arg 2293 that is an array expression carries all the shape information.*/ 2294 n = array_arg = 0; 2295 a = e->value.function.actual; 2296 for (; a; a = a->next) 2297 { 2298 n++; 2299 if (!a->expr || a->expr->expr_type != EXPR_ARRAY) 2300 continue; 2301 array_arg = n; 2302 expr = gfc_copy_expr (a->expr); 2303 break; 2304 } 2305 2306 if (!array_arg) 2307 return false; 2308 2309 old = gfc_copy_expr (e); 2310 2311 gfc_constructor_free (expr->value.constructor); 2312 expr->value.constructor = NULL; 2313 expr->ts = old->ts; 2314 expr->where = old->where; 2315 expr->expr_type = EXPR_ARRAY; 2316 2317 /* Copy the array argument constructors into an array, with nulls 2318 for the scalars. */ 2319 n = 0; 2320 a = old->value.function.actual; 2321 for (; a; a = a->next) 2322 { 2323 /* Check that this is OK for an initialization expression. */ 2324 if (a->expr && init_flag && !gfc_check_init_expr (a->expr)) 2325 goto cleanup; 2326 2327 rank[n] = 0; 2328 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE) 2329 { 2330 rank[n] = a->expr->rank; 2331 ctor = a->expr->symtree->n.sym->value->value.constructor; 2332 args[n] = gfc_constructor_first (ctor); 2333 } 2334 else if (a->expr && a->expr->expr_type == EXPR_ARRAY) 2335 { 2336 if (a->expr->rank) 2337 rank[n] = a->expr->rank; 2338 else 2339 rank[n] = 1; 2340 ctor = gfc_constructor_copy (a->expr->value.constructor); 2341 args[n] = gfc_constructor_first (ctor); 2342 } 2343 else 2344 args[n] = NULL; 2345 2346 n++; 2347 } 2348 2349 gfc_get_errors (NULL, &errors); 2350 2351 /* Using the array argument as the master, step through the array 2352 calling the function for each element and advancing the array 2353 constructors together. */ 2354 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) 2355 { 2356 new_ctor = gfc_constructor_append_expr (&expr->value.constructor, 2357 gfc_copy_expr (old), NULL); 2358 2359 gfc_free_actual_arglist (new_ctor->expr->value.function.actual); 2360 a = NULL; 2361 b = old->value.function.actual; 2362 for (i = 0; i < n; i++) 2363 { 2364 if (a == NULL) 2365 new_ctor->expr->value.function.actual 2366 = a = gfc_get_actual_arglist (); 2367 else 2368 { 2369 a->next = gfc_get_actual_arglist (); 2370 a = a->next; 2371 } 2372 2373 if (args[i]) 2374 a->expr = gfc_copy_expr (args[i]->expr); 2375 else 2376 a->expr = gfc_copy_expr (b->expr); 2377 2378 b = b->next; 2379 } 2380 2381 /* Simplify the function calls. If the simplification fails, the 2382 error will be flagged up down-stream or the library will deal 2383 with it. */ 2384 if (errors == 0) 2385 gfc_simplify_expr (new_ctor->expr, 0); 2386 2387 for (i = 0; i < n; i++) 2388 if (args[i]) 2389 args[i] = gfc_constructor_next (args[i]); 2390 2391 for (i = 1; i < n; i++) 2392 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) 2393 || (args[i] == NULL && args[array_arg - 1] != NULL))) 2394 goto compliance; 2395 } 2396 2397 free_expr0 (e); 2398 *e = *expr; 2399 /* Free "expr" but not the pointers it contains. */ 2400 free (expr); 2401 gfc_free_expr (old); 2402 return true; 2403 2404 compliance: 2405 gfc_error_now ("elemental function arguments at %C are not compliant"); 2406 2407 cleanup: 2408 gfc_free_expr (expr); 2409 gfc_free_expr (old); 2410 return false; 2411 } 2412 2413 2414 static bool 2415 check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *)) 2416 { 2417 gfc_expr *op1 = e->value.op.op1; 2418 gfc_expr *op2 = e->value.op.op2; 2419 2420 if (!(*check_function)(op1)) 2421 return false; 2422 2423 switch (e->value.op.op) 2424 { 2425 case INTRINSIC_UPLUS: 2426 case INTRINSIC_UMINUS: 2427 if (!numeric_type (et0 (op1))) 2428 goto not_numeric; 2429 break; 2430 2431 case INTRINSIC_EQ: 2432 case INTRINSIC_EQ_OS: 2433 case INTRINSIC_NE: 2434 case INTRINSIC_NE_OS: 2435 case INTRINSIC_GT: 2436 case INTRINSIC_GT_OS: 2437 case INTRINSIC_GE: 2438 case INTRINSIC_GE_OS: 2439 case INTRINSIC_LT: 2440 case INTRINSIC_LT_OS: 2441 case INTRINSIC_LE: 2442 case INTRINSIC_LE_OS: 2443 if (!(*check_function)(op2)) 2444 return false; 2445 2446 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) 2447 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) 2448 { 2449 gfc_error ("Numeric or CHARACTER operands are required in " 2450 "expression at %L", &e->where); 2451 return false; 2452 } 2453 break; 2454 2455 case INTRINSIC_PLUS: 2456 case INTRINSIC_MINUS: 2457 case INTRINSIC_TIMES: 2458 case INTRINSIC_DIVIDE: 2459 case INTRINSIC_POWER: 2460 if (!(*check_function)(op2)) 2461 return false; 2462 2463 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) 2464 goto not_numeric; 2465 2466 break; 2467 2468 case INTRINSIC_CONCAT: 2469 if (!(*check_function)(op2)) 2470 return false; 2471 2472 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) 2473 { 2474 gfc_error ("Concatenation operator in expression at %L " 2475 "must have two CHARACTER operands", &op1->where); 2476 return false; 2477 } 2478 2479 if (op1->ts.kind != op2->ts.kind) 2480 { 2481 gfc_error ("Concat operator at %L must concatenate strings of the " 2482 "same kind", &e->where); 2483 return false; 2484 } 2485 2486 break; 2487 2488 case INTRINSIC_NOT: 2489 if (et0 (op1) != BT_LOGICAL) 2490 { 2491 gfc_error (".NOT. operator in expression at %L must have a LOGICAL " 2492 "operand", &op1->where); 2493 return false; 2494 } 2495 2496 break; 2497 2498 case INTRINSIC_AND: 2499 case INTRINSIC_OR: 2500 case INTRINSIC_EQV: 2501 case INTRINSIC_NEQV: 2502 if (!(*check_function)(op2)) 2503 return false; 2504 2505 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) 2506 { 2507 gfc_error ("LOGICAL operands are required in expression at %L", 2508 &e->where); 2509 return false; 2510 } 2511 2512 break; 2513 2514 case INTRINSIC_PARENTHESES: 2515 break; 2516 2517 default: 2518 gfc_error ("Only intrinsic operators can be used in expression at %L", 2519 &e->where); 2520 return false; 2521 } 2522 2523 return true; 2524 2525 not_numeric: 2526 gfc_error ("Numeric operands are required in expression at %L", &e->where); 2527 2528 return false; 2529 } 2530 2531 /* F2003, 7.1.7 (3): In init expression, allocatable components 2532 must not be data-initialized. */ 2533 static bool 2534 check_alloc_comp_init (gfc_expr *e) 2535 { 2536 gfc_component *comp; 2537 gfc_constructor *ctor; 2538 2539 gcc_assert (e->expr_type == EXPR_STRUCTURE); 2540 gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS); 2541 2542 for (comp = e->ts.u.derived->components, 2543 ctor = gfc_constructor_first (e->value.constructor); 2544 comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) 2545 { 2546 if (comp->attr.allocatable && ctor->expr 2547 && ctor->expr->expr_type != EXPR_NULL) 2548 { 2549 gfc_error ("Invalid initialization expression for ALLOCATABLE " 2550 "component %qs in structure constructor at %L", 2551 comp->name, &ctor->expr->where); 2552 return false; 2553 } 2554 } 2555 2556 return true; 2557 } 2558 2559 static match 2560 check_init_expr_arguments (gfc_expr *e) 2561 { 2562 gfc_actual_arglist *ap; 2563 2564 for (ap = e->value.function.actual; ap; ap = ap->next) 2565 if (!gfc_check_init_expr (ap->expr)) 2566 return MATCH_ERROR; 2567 2568 return MATCH_YES; 2569 } 2570 2571 static bool check_restricted (gfc_expr *); 2572 2573 /* F95, 7.1.6.1, Initialization expressions, (7) 2574 F2003, 7.1.7 Initialization expression, (8) 2575 F2008, 7.1.12 Constant expression, (4) */ 2576 2577 static match 2578 check_inquiry (gfc_expr *e, int not_restricted) 2579 { 2580 const char *name; 2581 const char *const *functions; 2582 2583 static const char *const inquiry_func_f95[] = { 2584 "lbound", "shape", "size", "ubound", 2585 "bit_size", "len", "kind", 2586 "digits", "epsilon", "huge", "maxexponent", "minexponent", 2587 "precision", "radix", "range", "tiny", 2588 NULL 2589 }; 2590 2591 static const char *const inquiry_func_f2003[] = { 2592 "lbound", "shape", "size", "ubound", 2593 "bit_size", "len", "kind", 2594 "digits", "epsilon", "huge", "maxexponent", "minexponent", 2595 "precision", "radix", "range", "tiny", 2596 "new_line", NULL 2597 }; 2598 2599 /* std=f2008+ or -std=gnu */ 2600 static const char *const inquiry_func_gnu[] = { 2601 "lbound", "shape", "size", "ubound", 2602 "bit_size", "len", "kind", 2603 "digits", "epsilon", "huge", "maxexponent", "minexponent", 2604 "precision", "radix", "range", "tiny", 2605 "new_line", "storage_size", NULL 2606 }; 2607 2608 int i = 0; 2609 gfc_actual_arglist *ap; 2610 gfc_symbol *sym; 2611 gfc_symbol *asym; 2612 2613 if (!e->value.function.isym 2614 || !e->value.function.isym->inquiry) 2615 return MATCH_NO; 2616 2617 /* An undeclared parameter will get us here (PR25018). */ 2618 if (e->symtree == NULL) 2619 return MATCH_NO; 2620 2621 sym = e->symtree->n.sym; 2622 2623 if (sym->from_intmod) 2624 { 2625 if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV 2626 && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS 2627 && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) 2628 return MATCH_NO; 2629 2630 if (sym->from_intmod == INTMOD_ISO_C_BINDING 2631 && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) 2632 return MATCH_NO; 2633 } 2634 else 2635 { 2636 name = sym->name; 2637 2638 functions = inquiry_func_gnu; 2639 if (gfc_option.warn_std & GFC_STD_F2003) 2640 functions = inquiry_func_f2003; 2641 if (gfc_option.warn_std & GFC_STD_F95) 2642 functions = inquiry_func_f95; 2643 2644 for (i = 0; functions[i]; i++) 2645 if (strcmp (functions[i], name) == 0) 2646 break; 2647 2648 if (functions[i] == NULL) 2649 return MATCH_ERROR; 2650 } 2651 2652 /* At this point we have an inquiry function with a variable argument. The 2653 type of the variable might be undefined, but we need it now, because the 2654 arguments of these functions are not allowed to be undefined. */ 2655 2656 for (ap = e->value.function.actual; ap; ap = ap->next) 2657 { 2658 if (!ap->expr) 2659 continue; 2660 2661 asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL; 2662 2663 if (ap->expr->ts.type == BT_UNKNOWN) 2664 { 2665 if (asym && asym->ts.type == BT_UNKNOWN 2666 && !gfc_set_default_type (asym, 0, gfc_current_ns)) 2667 return MATCH_NO; 2668 2669 ap->expr->ts = asym->ts; 2670 } 2671 2672 if (asym && asym->assoc && asym->assoc->target 2673 && asym->assoc->target->expr_type == EXPR_CONSTANT) 2674 { 2675 gfc_free_expr (ap->expr); 2676 ap->expr = gfc_copy_expr (asym->assoc->target); 2677 } 2678 2679 /* Assumed character length will not reduce to a constant expression 2680 with LEN, as required by the standard. */ 2681 if (i == 5 && not_restricted && asym 2682 && asym->ts.type == BT_CHARACTER 2683 && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL) 2684 || asym->ts.deferred)) 2685 { 2686 gfc_error ("Assumed or deferred character length variable %qs " 2687 "in constant expression at %L", 2688 asym->name, &ap->expr->where); 2689 return MATCH_ERROR; 2690 } 2691 else if (not_restricted && !gfc_check_init_expr (ap->expr)) 2692 return MATCH_ERROR; 2693 2694 if (not_restricted == 0 2695 && ap->expr->expr_type != EXPR_VARIABLE 2696 && !check_restricted (ap->expr)) 2697 return MATCH_ERROR; 2698 2699 if (not_restricted == 0 2700 && ap->expr->expr_type == EXPR_VARIABLE 2701 && asym->attr.dummy && asym->attr.optional) 2702 return MATCH_NO; 2703 } 2704 2705 return MATCH_YES; 2706 } 2707 2708 2709 /* F95, 7.1.6.1, Initialization expressions, (5) 2710 F2003, 7.1.7 Initialization expression, (5) */ 2711 2712 static match 2713 check_transformational (gfc_expr *e) 2714 { 2715 static const char * const trans_func_f95[] = { 2716 "repeat", "reshape", "selected_int_kind", 2717 "selected_real_kind", "transfer", "trim", NULL 2718 }; 2719 2720 static const char * const trans_func_f2003[] = { 2721 "all", "any", "count", "dot_product", "matmul", "null", "pack", 2722 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", 2723 "selected_real_kind", "spread", "sum", "transfer", "transpose", 2724 "trim", "unpack", NULL 2725 }; 2726 2727 static const char * const trans_func_f2008[] = { 2728 "all", "any", "count", "dot_product", "matmul", "null", "pack", 2729 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", 2730 "selected_real_kind", "spread", "sum", "transfer", "transpose", 2731 "trim", "unpack", "findloc", NULL 2732 }; 2733 2734 int i; 2735 const char *name; 2736 const char *const *functions; 2737 2738 if (!e->value.function.isym 2739 || !e->value.function.isym->transformational) 2740 return MATCH_NO; 2741 2742 name = e->symtree->n.sym->name; 2743 2744 if (gfc_option.allow_std & GFC_STD_F2008) 2745 functions = trans_func_f2008; 2746 else if (gfc_option.allow_std & GFC_STD_F2003) 2747 functions = trans_func_f2003; 2748 else 2749 functions = trans_func_f95; 2750 2751 /* NULL() is dealt with below. */ 2752 if (strcmp ("null", name) == 0) 2753 return MATCH_NO; 2754 2755 for (i = 0; functions[i]; i++) 2756 if (strcmp (functions[i], name) == 0) 2757 break; 2758 2759 if (functions[i] == NULL) 2760 { 2761 gfc_error ("transformational intrinsic %qs at %L is not permitted " 2762 "in an initialization expression", name, &e->where); 2763 return MATCH_ERROR; 2764 } 2765 2766 return check_init_expr_arguments (e); 2767 } 2768 2769 2770 /* F95, 7.1.6.1, Initialization expressions, (6) 2771 F2003, 7.1.7 Initialization expression, (6) */ 2772 2773 static match 2774 check_null (gfc_expr *e) 2775 { 2776 if (strcmp ("null", e->symtree->n.sym->name) != 0) 2777 return MATCH_NO; 2778 2779 return check_init_expr_arguments (e); 2780 } 2781 2782 2783 static match 2784 check_elemental (gfc_expr *e) 2785 { 2786 if (!e->value.function.isym 2787 || !e->value.function.isym->elemental) 2788 return MATCH_NO; 2789 2790 if (e->ts.type != BT_INTEGER 2791 && e->ts.type != BT_CHARACTER 2792 && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard " 2793 "initialization expression at %L", &e->where)) 2794 return MATCH_ERROR; 2795 2796 return check_init_expr_arguments (e); 2797 } 2798 2799 2800 static match 2801 check_conversion (gfc_expr *e) 2802 { 2803 if (!e->value.function.isym 2804 || !e->value.function.isym->conversion) 2805 return MATCH_NO; 2806 2807 return check_init_expr_arguments (e); 2808 } 2809 2810 2811 /* Verify that an expression is an initialization expression. A side 2812 effect is that the expression tree is reduced to a single constant 2813 node if all goes well. This would normally happen when the 2814 expression is constructed but function references are assumed to be 2815 intrinsics in the context of initialization expressions. If 2816 false is returned an error message has been generated. */ 2817 2818 bool 2819 gfc_check_init_expr (gfc_expr *e) 2820 { 2821 match m; 2822 bool t; 2823 2824 if (e == NULL) 2825 return true; 2826 2827 switch (e->expr_type) 2828 { 2829 case EXPR_OP: 2830 t = check_intrinsic_op (e, gfc_check_init_expr); 2831 if (t) 2832 t = gfc_simplify_expr (e, 0); 2833 2834 break; 2835 2836 case EXPR_FUNCTION: 2837 t = false; 2838 2839 { 2840 bool conversion; 2841 gfc_intrinsic_sym* isym = NULL; 2842 gfc_symbol* sym = e->symtree->n.sym; 2843 2844 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and 2845 IEEE_EXCEPTIONS modules. */ 2846 int mod = sym->from_intmod; 2847 if (mod == INTMOD_NONE && sym->generic) 2848 mod = sym->generic->sym->from_intmod; 2849 if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS) 2850 { 2851 gfc_expr *new_expr = gfc_simplify_ieee_functions (e); 2852 if (new_expr) 2853 { 2854 gfc_replace_expr (e, new_expr); 2855 t = true; 2856 break; 2857 } 2858 } 2859 2860 /* If a conversion function, e.g., __convert_i8_i4, was inserted 2861 into an array constructor, we need to skip the error check here. 2862 Conversion errors are caught below in scalarize_intrinsic_call. */ 2863 conversion = e->value.function.isym 2864 && (e->value.function.isym->conversion == 1); 2865 2866 if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where) 2867 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)) 2868 { 2869 gfc_error ("Function %qs in initialization expression at %L " 2870 "must be an intrinsic function", 2871 e->symtree->n.sym->name, &e->where); 2872 break; 2873 } 2874 2875 if ((m = check_conversion (e)) == MATCH_NO 2876 && (m = check_inquiry (e, 1)) == MATCH_NO 2877 && (m = check_null (e)) == MATCH_NO 2878 && (m = check_transformational (e)) == MATCH_NO 2879 && (m = check_elemental (e)) == MATCH_NO) 2880 { 2881 gfc_error ("Intrinsic function %qs at %L is not permitted " 2882 "in an initialization expression", 2883 e->symtree->n.sym->name, &e->where); 2884 m = MATCH_ERROR; 2885 } 2886 2887 if (m == MATCH_ERROR) 2888 return false; 2889 2890 /* Try to scalarize an elemental intrinsic function that has an 2891 array argument. */ 2892 isym = gfc_find_function (e->symtree->n.sym->name); 2893 if (isym && isym->elemental 2894 && (t = scalarize_intrinsic_call (e, true))) 2895 break; 2896 } 2897 2898 if (m == MATCH_YES) 2899 t = gfc_simplify_expr (e, 0); 2900 2901 break; 2902 2903 case EXPR_VARIABLE: 2904 t = true; 2905 2906 /* This occurs when parsing pdt templates. */ 2907 if (gfc_expr_attr (e).pdt_kind) 2908 break; 2909 2910 if (gfc_check_iter_variable (e)) 2911 break; 2912 2913 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) 2914 { 2915 /* A PARAMETER shall not be used to define itself, i.e. 2916 REAL, PARAMETER :: x = transfer(0, x) 2917 is invalid. */ 2918 if (!e->symtree->n.sym->value) 2919 { 2920 gfc_error ("PARAMETER %qs is used at %L before its definition " 2921 "is complete", e->symtree->n.sym->name, &e->where); 2922 t = false; 2923 } 2924 else 2925 t = simplify_parameter_variable (e, 0); 2926 2927 break; 2928 } 2929 2930 if (gfc_in_match_data ()) 2931 break; 2932 2933 t = false; 2934 2935 if (e->symtree->n.sym->as) 2936 { 2937 switch (e->symtree->n.sym->as->type) 2938 { 2939 case AS_ASSUMED_SIZE: 2940 gfc_error ("Assumed size array %qs at %L is not permitted " 2941 "in an initialization expression", 2942 e->symtree->n.sym->name, &e->where); 2943 break; 2944 2945 case AS_ASSUMED_SHAPE: 2946 gfc_error ("Assumed shape array %qs at %L is not permitted " 2947 "in an initialization expression", 2948 e->symtree->n.sym->name, &e->where); 2949 break; 2950 2951 case AS_DEFERRED: 2952 if (!e->symtree->n.sym->attr.allocatable 2953 && !e->symtree->n.sym->attr.pointer 2954 && e->symtree->n.sym->attr.dummy) 2955 gfc_error ("Assumed-shape array %qs at %L is not permitted " 2956 "in an initialization expression", 2957 e->symtree->n.sym->name, &e->where); 2958 else 2959 gfc_error ("Deferred array %qs at %L is not permitted " 2960 "in an initialization expression", 2961 e->symtree->n.sym->name, &e->where); 2962 break; 2963 2964 case AS_EXPLICIT: 2965 gfc_error ("Array %qs at %L is a variable, which does " 2966 "not reduce to a constant expression", 2967 e->symtree->n.sym->name, &e->where); 2968 break; 2969 2970 default: 2971 gcc_unreachable(); 2972 } 2973 } 2974 else 2975 gfc_error ("Parameter %qs at %L has not been declared or is " 2976 "a variable, which does not reduce to a constant " 2977 "expression", e->symtree->name, &e->where); 2978 2979 break; 2980 2981 case EXPR_CONSTANT: 2982 case EXPR_NULL: 2983 t = true; 2984 break; 2985 2986 case EXPR_SUBSTRING: 2987 if (e->ref) 2988 { 2989 t = gfc_check_init_expr (e->ref->u.ss.start); 2990 if (!t) 2991 break; 2992 2993 t = gfc_check_init_expr (e->ref->u.ss.end); 2994 if (t) 2995 t = gfc_simplify_expr (e, 0); 2996 } 2997 else 2998 t = false; 2999 break; 3000 3001 case EXPR_STRUCTURE: 3002 t = e->ts.is_iso_c ? true : false; 3003 if (t) 3004 break; 3005 3006 t = check_alloc_comp_init (e); 3007 if (!t) 3008 break; 3009 3010 t = gfc_check_constructor (e, gfc_check_init_expr); 3011 if (!t) 3012 break; 3013 3014 break; 3015 3016 case EXPR_ARRAY: 3017 t = gfc_check_constructor (e, gfc_check_init_expr); 3018 if (!t) 3019 break; 3020 3021 t = gfc_expand_constructor (e, true); 3022 if (!t) 3023 break; 3024 3025 t = gfc_check_constructor_type (e); 3026 break; 3027 3028 default: 3029 gfc_internal_error ("check_init_expr(): Unknown expression type"); 3030 } 3031 3032 return t; 3033 } 3034 3035 /* Reduces a general expression to an initialization expression (a constant). 3036 This used to be part of gfc_match_init_expr. 3037 Note that this function doesn't free the given expression on false. */ 3038 3039 bool 3040 gfc_reduce_init_expr (gfc_expr *expr) 3041 { 3042 bool t; 3043 3044 gfc_init_expr_flag = true; 3045 t = gfc_resolve_expr (expr); 3046 if (t) 3047 t = gfc_check_init_expr (expr); 3048 gfc_init_expr_flag = false; 3049 3050 if (!t || !expr) 3051 return false; 3052 3053 if (expr->expr_type == EXPR_ARRAY) 3054 { 3055 if (!gfc_check_constructor_type (expr)) 3056 return false; 3057 if (!gfc_expand_constructor (expr, true)) 3058 return false; 3059 } 3060 3061 return true; 3062 } 3063 3064 3065 /* Match an initialization expression. We work by first matching an 3066 expression, then reducing it to a constant. */ 3067 3068 match 3069 gfc_match_init_expr (gfc_expr **result) 3070 { 3071 gfc_expr *expr; 3072 match m; 3073 bool t; 3074 3075 expr = NULL; 3076 3077 gfc_init_expr_flag = true; 3078 3079 m = gfc_match_expr (&expr); 3080 if (m != MATCH_YES) 3081 { 3082 gfc_init_expr_flag = false; 3083 return m; 3084 } 3085 3086 if (gfc_derived_parameter_expr (expr)) 3087 { 3088 *result = expr; 3089 gfc_init_expr_flag = false; 3090 return m; 3091 } 3092 3093 t = gfc_reduce_init_expr (expr); 3094 if (!t) 3095 { 3096 gfc_free_expr (expr); 3097 gfc_init_expr_flag = false; 3098 return MATCH_ERROR; 3099 } 3100 3101 *result = expr; 3102 gfc_init_expr_flag = false; 3103 3104 return MATCH_YES; 3105 } 3106 3107 3108 /* Given an actual argument list, test to see that each argument is a 3109 restricted expression and optionally if the expression type is 3110 integer or character. */ 3111 3112 static bool 3113 restricted_args (gfc_actual_arglist *a) 3114 { 3115 for (; a; a = a->next) 3116 { 3117 if (!check_restricted (a->expr)) 3118 return false; 3119 } 3120 3121 return true; 3122 } 3123 3124 3125 /************* Restricted/specification expressions *************/ 3126 3127 3128 /* Make sure a non-intrinsic function is a specification function, 3129 * see F08:7.1.11.5. */ 3130 3131 static bool 3132 external_spec_function (gfc_expr *e) 3133 { 3134 gfc_symbol *f; 3135 3136 f = e->value.function.esym; 3137 3138 /* IEEE functions allowed are "a reference to a transformational function 3139 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and 3140 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and 3141 IEEE_EXCEPTIONS". */ 3142 if (f->from_intmod == INTMOD_IEEE_ARITHMETIC 3143 || f->from_intmod == INTMOD_IEEE_EXCEPTIONS) 3144 { 3145 if (!strcmp (f->name, "ieee_selected_real_kind") 3146 || !strcmp (f->name, "ieee_support_rounding") 3147 || !strcmp (f->name, "ieee_support_flag") 3148 || !strcmp (f->name, "ieee_support_halting") 3149 || !strcmp (f->name, "ieee_support_datatype") 3150 || !strcmp (f->name, "ieee_support_denormal") 3151 || !strcmp (f->name, "ieee_support_subnormal") 3152 || !strcmp (f->name, "ieee_support_divide") 3153 || !strcmp (f->name, "ieee_support_inf") 3154 || !strcmp (f->name, "ieee_support_io") 3155 || !strcmp (f->name, "ieee_support_nan") 3156 || !strcmp (f->name, "ieee_support_sqrt") 3157 || !strcmp (f->name, "ieee_support_standard") 3158 || !strcmp (f->name, "ieee_support_underflow_control")) 3159 goto function_allowed; 3160 } 3161 3162 if (f->attr.proc == PROC_ST_FUNCTION) 3163 { 3164 gfc_error ("Specification function %qs at %L cannot be a statement " 3165 "function", f->name, &e->where); 3166 return false; 3167 } 3168 3169 if (f->attr.proc == PROC_INTERNAL) 3170 { 3171 gfc_error ("Specification function %qs at %L cannot be an internal " 3172 "function", f->name, &e->where); 3173 return false; 3174 } 3175 3176 if (!f->attr.pure && !f->attr.elemental) 3177 { 3178 gfc_error ("Specification function %qs at %L must be PURE", f->name, 3179 &e->where); 3180 return false; 3181 } 3182 3183 /* F08:7.1.11.6. */ 3184 if (f->attr.recursive 3185 && !gfc_notify_std (GFC_STD_F2003, 3186 "Specification function %qs " 3187 "at %L cannot be RECURSIVE", f->name, &e->where)) 3188 return false; 3189 3190 function_allowed: 3191 return restricted_args (e->value.function.actual); 3192 } 3193 3194 3195 /* Check to see that a function reference to an intrinsic is a 3196 restricted expression. */ 3197 3198 static bool 3199 restricted_intrinsic (gfc_expr *e) 3200 { 3201 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ 3202 if (check_inquiry (e, 0) == MATCH_YES) 3203 return true; 3204 3205 return restricted_args (e->value.function.actual); 3206 } 3207 3208 3209 /* Check the expressions of an actual arglist. Used by check_restricted. */ 3210 3211 static bool 3212 check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) 3213 { 3214 for (; arg; arg = arg->next) 3215 if (!checker (arg->expr)) 3216 return false; 3217 3218 return true; 3219 } 3220 3221 3222 /* Check the subscription expressions of a reference chain with a checking 3223 function; used by check_restricted. */ 3224 3225 static bool 3226 check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) 3227 { 3228 int dim; 3229 3230 if (!ref) 3231 return true; 3232 3233 switch (ref->type) 3234 { 3235 case REF_ARRAY: 3236 for (dim = 0; dim != ref->u.ar.dimen; ++dim) 3237 { 3238 if (!checker (ref->u.ar.start[dim])) 3239 return false; 3240 if (!checker (ref->u.ar.end[dim])) 3241 return false; 3242 if (!checker (ref->u.ar.stride[dim])) 3243 return false; 3244 } 3245 break; 3246 3247 case REF_COMPONENT: 3248 /* Nothing needed, just proceed to next reference. */ 3249 break; 3250 3251 case REF_SUBSTRING: 3252 if (!checker (ref->u.ss.start)) 3253 return false; 3254 if (!checker (ref->u.ss.end)) 3255 return false; 3256 break; 3257 3258 default: 3259 gcc_unreachable (); 3260 break; 3261 } 3262 3263 return check_references (ref->next, checker); 3264 } 3265 3266 /* Return true if ns is a parent of the current ns. */ 3267 3268 static bool 3269 is_parent_of_current_ns (gfc_namespace *ns) 3270 { 3271 gfc_namespace *p; 3272 for (p = gfc_current_ns->parent; p; p = p->parent) 3273 if (ns == p) 3274 return true; 3275 3276 return false; 3277 } 3278 3279 /* Verify that an expression is a restricted expression. Like its 3280 cousin check_init_expr(), an error message is generated if we 3281 return false. */ 3282 3283 static bool 3284 check_restricted (gfc_expr *e) 3285 { 3286 gfc_symbol* sym; 3287 bool t; 3288 3289 if (e == NULL) 3290 return true; 3291 3292 switch (e->expr_type) 3293 { 3294 case EXPR_OP: 3295 t = check_intrinsic_op (e, check_restricted); 3296 if (t) 3297 t = gfc_simplify_expr (e, 0); 3298 3299 break; 3300 3301 case EXPR_FUNCTION: 3302 if (e->value.function.esym) 3303 { 3304 t = check_arglist (e->value.function.actual, &check_restricted); 3305 if (t) 3306 t = external_spec_function (e); 3307 } 3308 else 3309 { 3310 if (e->value.function.isym && e->value.function.isym->inquiry) 3311 t = true; 3312 else 3313 t = check_arglist (e->value.function.actual, &check_restricted); 3314 3315 if (t) 3316 t = restricted_intrinsic (e); 3317 } 3318 break; 3319 3320 case EXPR_VARIABLE: 3321 sym = e->symtree->n.sym; 3322 t = false; 3323 3324 /* If a dummy argument appears in a context that is valid for a 3325 restricted expression in an elemental procedure, it will have 3326 already been simplified away once we get here. Therefore we 3327 don't need to jump through hoops to distinguish valid from 3328 invalid cases. Allowed in F2018. */ 3329 if (gfc_notification_std (GFC_STD_F2008) 3330 && sym->attr.dummy && sym->ns == gfc_current_ns 3331 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) 3332 { 3333 gfc_error_now ("Dummy argument %qs not " 3334 "allowed in expression at %L", 3335 sym->name, &e->where); 3336 break; 3337 } 3338 3339 if (sym->attr.optional) 3340 { 3341 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", 3342 sym->name, &e->where); 3343 break; 3344 } 3345 3346 if (sym->attr.intent == INTENT_OUT) 3347 { 3348 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", 3349 sym->name, &e->where); 3350 break; 3351 } 3352 3353 /* Check reference chain if any. */ 3354 if (!check_references (e->ref, &check_restricted)) 3355 break; 3356 3357 /* gfc_is_formal_arg broadcasts that a formal argument list is being 3358 processed in resolve.c(resolve_formal_arglist). This is done so 3359 that host associated dummy array indices are accepted (PR23446). 3360 This mechanism also does the same for the specification expressions 3361 of array-valued functions. */ 3362 if (e->error 3363 || sym->attr.in_common 3364 || sym->attr.use_assoc 3365 || sym->attr.dummy 3366 || sym->attr.implied_index 3367 || sym->attr.flavor == FL_PARAMETER 3368 || is_parent_of_current_ns (sym->ns) 3369 || (sym->ns->proc_name != NULL 3370 && sym->ns->proc_name->attr.flavor == FL_MODULE) 3371 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) 3372 { 3373 t = true; 3374 break; 3375 } 3376 3377 gfc_error ("Variable %qs cannot appear in the expression at %L", 3378 sym->name, &e->where); 3379 /* Prevent a repetition of the error. */ 3380 e->error = 1; 3381 break; 3382 3383 case EXPR_NULL: 3384 case EXPR_CONSTANT: 3385 t = true; 3386 break; 3387 3388 case EXPR_SUBSTRING: 3389 t = gfc_specification_expr (e->ref->u.ss.start); 3390 if (!t) 3391 break; 3392 3393 t = gfc_specification_expr (e->ref->u.ss.end); 3394 if (t) 3395 t = gfc_simplify_expr (e, 0); 3396 3397 break; 3398 3399 case EXPR_STRUCTURE: 3400 t = gfc_check_constructor (e, check_restricted); 3401 break; 3402 3403 case EXPR_ARRAY: 3404 t = gfc_check_constructor (e, check_restricted); 3405 break; 3406 3407 default: 3408 gfc_internal_error ("check_restricted(): Unknown expression type"); 3409 } 3410 3411 return t; 3412 } 3413 3414 3415 /* Check to see that an expression is a specification expression. If 3416 we return false, an error has been generated. */ 3417 3418 bool 3419 gfc_specification_expr (gfc_expr *e) 3420 { 3421 gfc_component *comp; 3422 3423 if (e == NULL) 3424 return true; 3425 3426 if (e->ts.type != BT_INTEGER) 3427 { 3428 gfc_error ("Expression at %L must be of INTEGER type, found %s", 3429 &e->where, gfc_basic_typename (e->ts.type)); 3430 return false; 3431 } 3432 3433 comp = gfc_get_proc_ptr_comp (e); 3434 if (e->expr_type == EXPR_FUNCTION 3435 && !e->value.function.isym 3436 && !e->value.function.esym 3437 && !gfc_pure (e->symtree->n.sym) 3438 && (!comp || !comp->attr.pure)) 3439 { 3440 gfc_error ("Function %qs at %L must be PURE", 3441 e->symtree->n.sym->name, &e->where); 3442 /* Prevent repeat error messages. */ 3443 e->symtree->n.sym->attr.pure = 1; 3444 return false; 3445 } 3446 3447 if (e->rank != 0) 3448 { 3449 gfc_error ("Expression at %L must be scalar", &e->where); 3450 return false; 3451 } 3452 3453 if (!gfc_simplify_expr (e, 0)) 3454 return false; 3455 3456 return check_restricted (e); 3457 } 3458 3459 3460 /************** Expression conformance checks. *************/ 3461 3462 /* Given two expressions, make sure that the arrays are conformable. */ 3463 3464 bool 3465 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) 3466 { 3467 int op1_flag, op2_flag, d; 3468 mpz_t op1_size, op2_size; 3469 bool t; 3470 3471 va_list argp; 3472 char buffer[240]; 3473 3474 if (op1->rank == 0 || op2->rank == 0) 3475 return true; 3476 3477 va_start (argp, optype_msgid); 3478 vsnprintf (buffer, 240, optype_msgid, argp); 3479 va_end (argp); 3480 3481 if (op1->rank != op2->rank) 3482 { 3483 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer), 3484 op1->rank, op2->rank, &op1->where); 3485 return false; 3486 } 3487 3488 t = true; 3489 3490 for (d = 0; d < op1->rank; d++) 3491 { 3492 op1_flag = gfc_array_dimen_size(op1, d, &op1_size); 3493 op2_flag = gfc_array_dimen_size(op2, d, &op2_size); 3494 3495 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) 3496 { 3497 gfc_error ("Different shape for %s at %L on dimension %d " 3498 "(%d and %d)", _(buffer), &op1->where, d + 1, 3499 (int) mpz_get_si (op1_size), 3500 (int) mpz_get_si (op2_size)); 3501 3502 t = false; 3503 } 3504 3505 if (op1_flag) 3506 mpz_clear (op1_size); 3507 if (op2_flag) 3508 mpz_clear (op2_size); 3509 3510 if (!t) 3511 return false; 3512 } 3513 3514 return true; 3515 } 3516 3517 3518 /* Given an assignable expression and an arbitrary expression, make 3519 sure that the assignment can take place. Only add a call to the intrinsic 3520 conversion routines, when allow_convert is set. When this assign is a 3521 coarray call, then the convert is done by the coarray routine implictly and 3522 adding the intrinsic conversion would do harm in most cases. */ 3523 3524 bool 3525 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, 3526 bool allow_convert) 3527 { 3528 gfc_symbol *sym; 3529 gfc_ref *ref; 3530 int has_pointer; 3531 3532 sym = lvalue->symtree->n.sym; 3533 3534 /* See if this is the component or subcomponent of a pointer and guard 3535 against assignment to LEN or KIND part-refs. */ 3536 has_pointer = sym->attr.pointer; 3537 for (ref = lvalue->ref; ref; ref = ref->next) 3538 { 3539 if (!has_pointer && ref->type == REF_COMPONENT 3540 && ref->u.c.component->attr.pointer) 3541 has_pointer = 1; 3542 else if (ref->type == REF_INQUIRY 3543 && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND)) 3544 { 3545 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not " 3546 "allowed", &lvalue->where); 3547 return false; 3548 } 3549 } 3550 3551 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other 3552 variable local to a function subprogram. Its existence begins when 3553 execution of the function is initiated and ends when execution of the 3554 function is terminated... 3555 Therefore, the left hand side is no longer a variable, when it is: */ 3556 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION 3557 && !sym->attr.external) 3558 { 3559 bool bad_proc; 3560 bad_proc = false; 3561 3562 /* (i) Use associated; */ 3563 if (sym->attr.use_assoc) 3564 bad_proc = true; 3565 3566 /* (ii) The assignment is in the main program; or */ 3567 if (gfc_current_ns->proc_name 3568 && gfc_current_ns->proc_name->attr.is_main_program) 3569 bad_proc = true; 3570 3571 /* (iii) A module or internal procedure... */ 3572 if (gfc_current_ns->proc_name 3573 && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL 3574 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) 3575 && gfc_current_ns->parent 3576 && (!(gfc_current_ns->parent->proc_name->attr.function 3577 || gfc_current_ns->parent->proc_name->attr.subroutine) 3578 || gfc_current_ns->parent->proc_name->attr.is_main_program)) 3579 { 3580 /* ... that is not a function... */ 3581 if (gfc_current_ns->proc_name 3582 && !gfc_current_ns->proc_name->attr.function) 3583 bad_proc = true; 3584 3585 /* ... or is not an entry and has a different name. */ 3586 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) 3587 bad_proc = true; 3588 } 3589 3590 /* (iv) Host associated and not the function symbol or the 3591 parent result. This picks up sibling references, which 3592 cannot be entries. */ 3593 if (!sym->attr.entry 3594 && sym->ns == gfc_current_ns->parent 3595 && sym != gfc_current_ns->proc_name 3596 && sym != gfc_current_ns->parent->proc_name->result) 3597 bad_proc = true; 3598 3599 if (bad_proc) 3600 { 3601 gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); 3602 return false; 3603 } 3604 } 3605 else 3606 { 3607 /* Reject assigning to an external symbol. For initializers, this 3608 was already done before, in resolve_fl_procedure. */ 3609 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external 3610 && sym->attr.proc != PROC_MODULE && !rvalue->error) 3611 { 3612 gfc_error ("Illegal assignment to external procedure at %L", 3613 &lvalue->where); 3614 return false; 3615 } 3616 } 3617 3618 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) 3619 { 3620 gfc_error ("Incompatible ranks %d and %d in assignment at %L", 3621 lvalue->rank, rvalue->rank, &lvalue->where); 3622 return false; 3623 } 3624 3625 if (lvalue->ts.type == BT_UNKNOWN) 3626 { 3627 gfc_error ("Variable type is UNKNOWN in assignment at %L", 3628 &lvalue->where); 3629 return false; 3630 } 3631 3632 if (rvalue->expr_type == EXPR_NULL) 3633 { 3634 if (has_pointer && (ref == NULL || ref->next == NULL) 3635 && lvalue->symtree->n.sym->attr.data) 3636 return true; 3637 else 3638 { 3639 gfc_error ("NULL appears on right-hand side in assignment at %L", 3640 &rvalue->where); 3641 return false; 3642 } 3643 } 3644 3645 /* This is possibly a typo: x = f() instead of x => f(). */ 3646 if (warn_surprising 3647 && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) 3648 gfc_warning (OPT_Wsurprising, 3649 "POINTER-valued function appears on right-hand side of " 3650 "assignment at %L", &rvalue->where); 3651 3652 /* Check size of array assignments. */ 3653 if (lvalue->rank != 0 && rvalue->rank != 0 3654 && !gfc_check_conformance (lvalue, rvalue, "array assignment")) 3655 return false; 3656 3657 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER 3658 && lvalue->symtree->n.sym->attr.data 3659 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to " 3660 "initialize non-integer variable %qs", 3661 &rvalue->where, lvalue->symtree->n.sym->name)) 3662 return false; 3663 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data 3664 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " 3665 "a DATA statement and outside INT/REAL/DBLE/CMPLX", 3666 &rvalue->where)) 3667 return false; 3668 3669 /* Handle the case of a BOZ literal on the RHS. */ 3670 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER) 3671 { 3672 int rc; 3673 if (warn_surprising) 3674 gfc_warning (OPT_Wsurprising, 3675 "BOZ literal at %L is bitwise transferred " 3676 "non-integer symbol %qs", &rvalue->where, 3677 lvalue->symtree->n.sym->name); 3678 if (!gfc_convert_boz (rvalue, &lvalue->ts)) 3679 return false; 3680 if ((rc = gfc_range_check (rvalue)) != ARITH_OK) 3681 { 3682 if (rc == ARITH_UNDERFLOW) 3683 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L" 3684 ". This check can be disabled with the option " 3685 "%<-fno-range-check%>", &rvalue->where); 3686 else if (rc == ARITH_OVERFLOW) 3687 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L" 3688 ". This check can be disabled with the option " 3689 "%<-fno-range-check%>", &rvalue->where); 3690 else if (rc == ARITH_NAN) 3691 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L" 3692 ". This check can be disabled with the option " 3693 "%<-fno-range-check%>", &rvalue->where); 3694 return false; 3695 } 3696 } 3697 3698 if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) 3699 { 3700 gfc_error ("The assignment to a KIND or LEN component of a " 3701 "parameterized type at %L is not allowed", 3702 &lvalue->where); 3703 return false; 3704 } 3705 3706 if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) 3707 return true; 3708 3709 /* Only DATA Statements come here. */ 3710 if (!conform) 3711 { 3712 locus *where; 3713 3714 /* Numeric can be converted to any other numeric. And Hollerith can be 3715 converted to any other type. */ 3716 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) 3717 || rvalue->ts.type == BT_HOLLERITH) 3718 return true; 3719 3720 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) 3721 return true; 3722 3723 where = lvalue->where.lb ? &lvalue->where : &rvalue->where; 3724 gfc_error ("Incompatible types in DATA statement at %L; attempted " 3725 "conversion of %s to %s", where, 3726 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); 3727 3728 return false; 3729 } 3730 3731 /* Assignment is the only case where character variables of different 3732 kind values can be converted into one another. */ 3733 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) 3734 { 3735 if (lvalue->ts.kind != rvalue->ts.kind && allow_convert) 3736 return gfc_convert_chartype (rvalue, &lvalue->ts); 3737 else 3738 return true; 3739 } 3740 3741 if (!allow_convert) 3742 return true; 3743 3744 return gfc_convert_type (rvalue, &lvalue->ts, 1); 3745 } 3746 3747 3748 /* Check that a pointer assignment is OK. We first check lvalue, and 3749 we only check rvalue if it's not an assignment to NULL() or a 3750 NULLIFY statement. */ 3751 3752 bool 3753 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, 3754 bool suppress_type_test, bool is_init_expr) 3755 { 3756 symbol_attribute attr, lhs_attr; 3757 gfc_ref *ref; 3758 bool is_pure, is_implicit_pure, rank_remap; 3759 int proc_pointer; 3760 bool same_rank; 3761 3762 lhs_attr = gfc_expr_attr (lvalue); 3763 if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) 3764 { 3765 gfc_error ("Pointer assignment target is not a POINTER at %L", 3766 &lvalue->where); 3767 return false; 3768 } 3769 3770 if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc 3771 && !lhs_attr.proc_pointer) 3772 { 3773 gfc_error ("%qs in the pointer assignment at %L cannot be an " 3774 "l-value since it is a procedure", 3775 lvalue->symtree->n.sym->name, &lvalue->where); 3776 return false; 3777 } 3778 3779 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; 3780 3781 rank_remap = false; 3782 same_rank = lvalue->rank == rvalue->rank; 3783 for (ref = lvalue->ref; ref; ref = ref->next) 3784 { 3785 if (ref->type == REF_COMPONENT) 3786 proc_pointer = ref->u.c.component->attr.proc_pointer; 3787 3788 if (ref->type == REF_ARRAY && ref->next == NULL) 3789 { 3790 int dim; 3791 3792 if (ref->u.ar.type == AR_FULL) 3793 break; 3794 3795 if (ref->u.ar.type != AR_SECTION) 3796 { 3797 gfc_error ("Expected bounds specification for %qs at %L", 3798 lvalue->symtree->n.sym->name, &lvalue->where); 3799 return false; 3800 } 3801 3802 if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " 3803 "for %qs in pointer assignment at %L", 3804 lvalue->symtree->n.sym->name, &lvalue->where)) 3805 return false; 3806 3807 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment): 3808 * 3809 * (C1017) If bounds-spec-list is specified, the number of 3810 * bounds-specs shall equal the rank of data-pointer-object. 3811 * 3812 * If bounds-spec-list appears, it specifies the lower bounds. 3813 * 3814 * (C1018) If bounds-remapping-list is specified, the number of 3815 * bounds-remappings shall equal the rank of data-pointer-object. 3816 * 3817 * If bounds-remapping-list appears, it specifies the upper and 3818 * lower bounds of each dimension of the pointer; the pointer target 3819 * shall be simply contiguous or of rank one. 3820 * 3821 * (C1019) If bounds-remapping-list is not specified, the ranks of 3822 * data-pointer-object and data-target shall be the same. 3823 * 3824 * Thus when bounds are given, all lbounds are necessary and either 3825 * all or none of the upper bounds; no strides are allowed. If the 3826 * upper bounds are present, we may do rank remapping. */ 3827 for (dim = 0; dim < ref->u.ar.dimen; ++dim) 3828 { 3829 if (ref->u.ar.stride[dim]) 3830 { 3831 gfc_error ("Stride must not be present at %L", 3832 &lvalue->where); 3833 return false; 3834 } 3835 if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim])) 3836 { 3837 gfc_error ("Rank remapping requires a " 3838 "list of %<lower-bound : upper-bound%> " 3839 "specifications at %L", &lvalue->where); 3840 return false; 3841 } 3842 if (!ref->u.ar.start[dim] 3843 || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) 3844 { 3845 gfc_error ("Expected list of %<lower-bound :%> or " 3846 "list of %<lower-bound : upper-bound%> " 3847 "specifications at %L", &lvalue->where); 3848 return false; 3849 } 3850 3851 if (dim == 0) 3852 rank_remap = (ref->u.ar.end[dim] != NULL); 3853 else 3854 { 3855 if ((rank_remap && !ref->u.ar.end[dim])) 3856 { 3857 gfc_error ("Rank remapping requires a " 3858 "list of %<lower-bound : upper-bound%> " 3859 "specifications at %L", &lvalue->where); 3860 return false; 3861 } 3862 if (!rank_remap && ref->u.ar.end[dim]) 3863 { 3864 gfc_error ("Expected list of %<lower-bound :%> or " 3865 "list of %<lower-bound : upper-bound%> " 3866 "specifications at %L", &lvalue->where); 3867 return false; 3868 } 3869 } 3870 } 3871 } 3872 } 3873 3874 is_pure = gfc_pure (NULL); 3875 is_implicit_pure = gfc_implicit_pure (NULL); 3876 3877 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, 3878 kind, etc for lvalue and rvalue must match, and rvalue must be a 3879 pure variable if we're in a pure function. */ 3880 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) 3881 return true; 3882 3883 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ 3884 if (lvalue->expr_type == EXPR_VARIABLE 3885 && gfc_is_coindexed (lvalue)) 3886 { 3887 gfc_ref *ref; 3888 for (ref = lvalue->ref; ref; ref = ref->next) 3889 if (ref->type == REF_ARRAY && ref->u.ar.codimen) 3890 { 3891 gfc_error ("Pointer object at %L shall not have a coindex", 3892 &lvalue->where); 3893 return false; 3894 } 3895 } 3896 3897 /* Checks on rvalue for procedure pointer assignments. */ 3898 if (proc_pointer) 3899 { 3900 char err[200]; 3901 gfc_symbol *s1,*s2; 3902 gfc_component *comp1, *comp2; 3903 const char *name; 3904 3905 attr = gfc_expr_attr (rvalue); 3906 if (!((rvalue->expr_type == EXPR_NULL) 3907 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) 3908 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) 3909 || (rvalue->expr_type == EXPR_VARIABLE 3910 && attr.flavor == FL_PROCEDURE))) 3911 { 3912 gfc_error ("Invalid procedure pointer assignment at %L", 3913 &rvalue->where); 3914 return false; 3915 } 3916 3917 if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) 3918 { 3919 /* Check for intrinsics. */ 3920 gfc_symbol *sym = rvalue->symtree->n.sym; 3921 if (!sym->attr.intrinsic 3922 && (gfc_is_intrinsic (sym, 0, sym->declared_at) 3923 || gfc_is_intrinsic (sym, 1, sym->declared_at))) 3924 { 3925 sym->attr.intrinsic = 1; 3926 gfc_resolve_intrinsic (sym, &rvalue->where); 3927 attr = gfc_expr_attr (rvalue); 3928 } 3929 /* Check for result of embracing function. */ 3930 if (sym->attr.function && sym->result == sym) 3931 { 3932 gfc_namespace *ns; 3933 3934 for (ns = gfc_current_ns; ns; ns = ns->parent) 3935 if (sym == ns->proc_name) 3936 { 3937 gfc_error ("Function result %qs is invalid as proc-target " 3938 "in procedure pointer assignment at %L", 3939 sym->name, &rvalue->where); 3940 return false; 3941 } 3942 } 3943 } 3944 if (attr.abstract) 3945 { 3946 gfc_error ("Abstract interface %qs is invalid " 3947 "in procedure pointer assignment at %L", 3948 rvalue->symtree->name, &rvalue->where); 3949 return false; 3950 } 3951 /* Check for F08:C729. */ 3952 if (attr.flavor == FL_PROCEDURE) 3953 { 3954 if (attr.proc == PROC_ST_FUNCTION) 3955 { 3956 gfc_error ("Statement function %qs is invalid " 3957 "in procedure pointer assignment at %L", 3958 rvalue->symtree->name, &rvalue->where); 3959 return false; 3960 } 3961 if (attr.proc == PROC_INTERNAL && 3962 !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs " 3963 "is invalid in procedure pointer assignment " 3964 "at %L", rvalue->symtree->name, &rvalue->where)) 3965 return false; 3966 if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, 3967 attr.subroutine) == 0) 3968 { 3969 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " 3970 "assignment", rvalue->symtree->name, &rvalue->where); 3971 return false; 3972 } 3973 } 3974 /* Check for F08:C730. */ 3975 if (attr.elemental && !attr.intrinsic) 3976 { 3977 gfc_error ("Nonintrinsic elemental procedure %qs is invalid " 3978 "in procedure pointer assignment at %L", 3979 rvalue->symtree->name, &rvalue->where); 3980 return false; 3981 } 3982 3983 /* Ensure that the calling convention is the same. As other attributes 3984 such as DLLEXPORT may differ, one explicitly only tests for the 3985 calling conventions. */ 3986 if (rvalue->expr_type == EXPR_VARIABLE 3987 && lvalue->symtree->n.sym->attr.ext_attr 3988 != rvalue->symtree->n.sym->attr.ext_attr) 3989 { 3990 symbol_attribute calls; 3991 3992 calls.ext_attr = 0; 3993 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL); 3994 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL); 3995 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL); 3996 3997 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) 3998 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) 3999 { 4000 gfc_error ("Mismatch in the procedure pointer assignment " 4001 "at %L: mismatch in the calling convention", 4002 &rvalue->where); 4003 return false; 4004 } 4005 } 4006 4007 comp1 = gfc_get_proc_ptr_comp (lvalue); 4008 if (comp1) 4009 s1 = comp1->ts.interface; 4010 else 4011 { 4012 s1 = lvalue->symtree->n.sym; 4013 if (s1->ts.interface) 4014 s1 = s1->ts.interface; 4015 } 4016 4017 comp2 = gfc_get_proc_ptr_comp (rvalue); 4018 if (comp2) 4019 { 4020 if (rvalue->expr_type == EXPR_FUNCTION) 4021 { 4022 s2 = comp2->ts.interface->result; 4023 name = s2->name; 4024 } 4025 else 4026 { 4027 s2 = comp2->ts.interface; 4028 name = comp2->name; 4029 } 4030 } 4031 else if (rvalue->expr_type == EXPR_FUNCTION) 4032 { 4033 if (rvalue->value.function.esym) 4034 s2 = rvalue->value.function.esym->result; 4035 else 4036 s2 = rvalue->symtree->n.sym->result; 4037 4038 name = s2->name; 4039 } 4040 else 4041 { 4042 s2 = rvalue->symtree->n.sym; 4043 name = s2->name; 4044 } 4045 4046 if (s2 && s2->attr.proc_pointer && s2->ts.interface) 4047 s2 = s2->ts.interface; 4048 4049 /* Special check for the case of absent interface on the lvalue. 4050 * All other interface checks are done below. */ 4051 if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) 4052 { 4053 gfc_error ("Interface mismatch in procedure pointer assignment " 4054 "at %L: %qs is not a subroutine", &rvalue->where, name); 4055 return false; 4056 } 4057 4058 /* F08:7.2.2.4 (4) */ 4059 if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) 4060 { 4061 if (comp1 && !s1) 4062 { 4063 gfc_error ("Explicit interface required for component %qs at %L: %s", 4064 comp1->name, &lvalue->where, err); 4065 return false; 4066 } 4067 else if (s1->attr.if_source == IFSRC_UNKNOWN) 4068 { 4069 gfc_error ("Explicit interface required for %qs at %L: %s", 4070 s1->name, &lvalue->where, err); 4071 return false; 4072 } 4073 } 4074 if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) 4075 { 4076 if (comp2 && !s2) 4077 { 4078 gfc_error ("Explicit interface required for component %qs at %L: %s", 4079 comp2->name, &rvalue->where, err); 4080 return false; 4081 } 4082 else if (s2->attr.if_source == IFSRC_UNKNOWN) 4083 { 4084 gfc_error ("Explicit interface required for %qs at %L: %s", 4085 s2->name, &rvalue->where, err); 4086 return false; 4087 } 4088 } 4089 4090 if (s1 == s2 || !s1 || !s2) 4091 return true; 4092 4093 if (!gfc_compare_interfaces (s1, s2, name, 0, 1, 4094 err, sizeof(err), NULL, NULL)) 4095 { 4096 gfc_error ("Interface mismatch in procedure pointer assignment " 4097 "at %L: %s", &rvalue->where, err); 4098 return false; 4099 } 4100 4101 /* Check F2008Cor2, C729. */ 4102 if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN 4103 && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) 4104 { 4105 gfc_error ("Procedure pointer target %qs at %L must be either an " 4106 "intrinsic, host or use associated, referenced or have " 4107 "the EXTERNAL attribute", s2->name, &rvalue->where); 4108 return false; 4109 } 4110 4111 return true; 4112 } 4113 else 4114 { 4115 /* A non-proc pointer cannot point to a constant. */ 4116 if (rvalue->expr_type == EXPR_CONSTANT) 4117 { 4118 gfc_error_now ("Pointer assignment target cannot be a constant at %L", 4119 &rvalue->where); 4120 return false; 4121 } 4122 } 4123 4124 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) 4125 { 4126 /* Check for F03:C717. */ 4127 if (UNLIMITED_POLY (rvalue) 4128 && !(UNLIMITED_POLY (lvalue) 4129 || (lvalue->ts.type == BT_DERIVED 4130 && (lvalue->ts.u.derived->attr.is_bind_c 4131 || lvalue->ts.u.derived->attr.sequence)))) 4132 gfc_error ("Data-pointer-object at %L must be unlimited " 4133 "polymorphic, or of a type with the BIND or SEQUENCE " 4134 "attribute, to be compatible with an unlimited " 4135 "polymorphic target", &lvalue->where); 4136 else if (!suppress_type_test) 4137 gfc_error ("Different types in pointer assignment at %L; " 4138 "attempted assignment of %s to %s", &lvalue->where, 4139 gfc_typename (&rvalue->ts), 4140 gfc_typename (&lvalue->ts)); 4141 return false; 4142 } 4143 4144 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) 4145 { 4146 gfc_error ("Different kind type parameters in pointer " 4147 "assignment at %L", &lvalue->where); 4148 return false; 4149 } 4150 4151 if (lvalue->rank != rvalue->rank && !rank_remap) 4152 { 4153 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); 4154 return false; 4155 } 4156 4157 /* Make sure the vtab is present. */ 4158 if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)) 4159 gfc_find_vtab (&rvalue->ts); 4160 4161 /* Check rank remapping. */ 4162 if (rank_remap) 4163 { 4164 mpz_t lsize, rsize; 4165 4166 /* If this can be determined, check that the target must be at least as 4167 large as the pointer assigned to it is. */ 4168 if (gfc_array_size (lvalue, &lsize) 4169 && gfc_array_size (rvalue, &rsize) 4170 && mpz_cmp (rsize, lsize) < 0) 4171 { 4172 gfc_error ("Rank remapping target is smaller than size of the" 4173 " pointer (%ld < %ld) at %L", 4174 mpz_get_si (rsize), mpz_get_si (lsize), 4175 &lvalue->where); 4176 return false; 4177 } 4178 4179 /* The target must be either rank one or it must be simply contiguous 4180 and F2008 must be allowed. */ 4181 if (rvalue->rank != 1) 4182 { 4183 if (!gfc_is_simply_contiguous (rvalue, true, false)) 4184 { 4185 gfc_error ("Rank remapping target must be rank 1 or" 4186 " simply contiguous at %L", &rvalue->where); 4187 return false; 4188 } 4189 if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " 4190 "rank 1 at %L", &rvalue->where)) 4191 return false; 4192 } 4193 } 4194 4195 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ 4196 if (rvalue->expr_type == EXPR_NULL) 4197 return true; 4198 4199 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) 4200 lvalue->symtree->n.sym->attr.subref_array_pointer = 1; 4201 4202 attr = gfc_expr_attr (rvalue); 4203 4204 if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) 4205 { 4206 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call 4207 to caf_get. Map this to the same error message as below when it is 4208 still a variable expression. */ 4209 if (rvalue->value.function.isym 4210 && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET) 4211 /* The test above might need to be extend when F08, Note 5.4 has to be 4212 interpreted in the way that target and pointer with the same coindex 4213 are allowed. */ 4214 gfc_error ("Data target at %L shall not have a coindex", 4215 &rvalue->where); 4216 else 4217 gfc_error ("Target expression in pointer assignment " 4218 "at %L must deliver a pointer result", 4219 &rvalue->where); 4220 return false; 4221 } 4222 4223 if (is_init_expr) 4224 { 4225 gfc_symbol *sym; 4226 bool target; 4227 4228 gcc_assert (rvalue->symtree); 4229 sym = rvalue->symtree->n.sym; 4230 4231 if (sym->ts.type == BT_CLASS && sym->attr.class_ok) 4232 target = CLASS_DATA (sym)->attr.target; 4233 else 4234 target = sym->attr.target; 4235 4236 if (!target && !proc_pointer) 4237 { 4238 gfc_error ("Pointer assignment target in initialization expression " 4239 "does not have the TARGET attribute at %L", 4240 &rvalue->where); 4241 return false; 4242 } 4243 } 4244 else 4245 { 4246 if (!attr.target && !attr.pointer) 4247 { 4248 gfc_error ("Pointer assignment target is neither TARGET " 4249 "nor POINTER at %L", &rvalue->where); 4250 return false; 4251 } 4252 } 4253 4254 if (lvalue->ts.type == BT_CHARACTER) 4255 { 4256 bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); 4257 if (!t) 4258 return false; 4259 } 4260 4261 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) 4262 { 4263 gfc_error ("Bad target in pointer assignment in PURE " 4264 "procedure at %L", &rvalue->where); 4265 } 4266 4267 if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) 4268 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 4269 4270 if (gfc_has_vector_index (rvalue)) 4271 { 4272 gfc_error ("Pointer assignment with vector subscript " 4273 "on rhs at %L", &rvalue->where); 4274 return false; 4275 } 4276 4277 if (attr.is_protected && attr.use_assoc 4278 && !(attr.pointer || attr.proc_pointer)) 4279 { 4280 gfc_error ("Pointer assignment target has PROTECTED " 4281 "attribute at %L", &rvalue->where); 4282 return false; 4283 } 4284 4285 /* F2008, C725. For PURE also C1283. */ 4286 if (rvalue->expr_type == EXPR_VARIABLE 4287 && gfc_is_coindexed (rvalue)) 4288 { 4289 gfc_ref *ref; 4290 for (ref = rvalue->ref; ref; ref = ref->next) 4291 if (ref->type == REF_ARRAY && ref->u.ar.codimen) 4292 { 4293 gfc_error ("Data target at %L shall not have a coindex", 4294 &rvalue->where); 4295 return false; 4296 } 4297 } 4298 4299 /* Warn for assignments of contiguous pointers to targets which is not 4300 contiguous. Be lenient in the definition of what counts as 4301 contiguous. */ 4302 4303 if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true)) 4304 gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from " 4305 "non-contiguous target at %L", &rvalue->where); 4306 4307 /* Warn if it is the LHS pointer may lives longer than the RHS target. */ 4308 if (warn_target_lifetime 4309 && rvalue->expr_type == EXPR_VARIABLE 4310 && !rvalue->symtree->n.sym->attr.save 4311 && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer 4312 && !rvalue->symtree->n.sym->attr.host_assoc 4313 && !rvalue->symtree->n.sym->attr.in_common 4314 && !rvalue->symtree->n.sym->attr.use_assoc 4315 && !rvalue->symtree->n.sym->attr.dummy) 4316 { 4317 bool warn; 4318 gfc_namespace *ns; 4319 4320 warn = lvalue->symtree->n.sym->attr.dummy 4321 || lvalue->symtree->n.sym->attr.result 4322 || lvalue->symtree->n.sym->attr.function 4323 || (lvalue->symtree->n.sym->attr.host_assoc 4324 && lvalue->symtree->n.sym->ns 4325 != rvalue->symtree->n.sym->ns) 4326 || lvalue->symtree->n.sym->attr.use_assoc 4327 || lvalue->symtree->n.sym->attr.in_common; 4328 4329 if (rvalue->symtree->n.sym->ns->proc_name 4330 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE 4331 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) 4332 for (ns = rvalue->symtree->n.sym->ns; 4333 ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; 4334 ns = ns->parent) 4335 if (ns->parent == lvalue->symtree->n.sym->ns) 4336 { 4337 warn = true; 4338 break; 4339 } 4340 4341 if (warn) 4342 gfc_warning (OPT_Wtarget_lifetime, 4343 "Pointer at %L in pointer assignment might outlive the " 4344 "pointer target", &lvalue->where); 4345 } 4346 4347 return true; 4348 } 4349 4350 4351 /* Relative of gfc_check_assign() except that the lvalue is a single 4352 symbol. Used for initialization assignments. */ 4353 4354 bool 4355 gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) 4356 { 4357 gfc_expr lvalue; 4358 bool r; 4359 bool pointer, proc_pointer; 4360 4361 memset (&lvalue, '\0', sizeof (gfc_expr)); 4362 4363 lvalue.expr_type = EXPR_VARIABLE; 4364 lvalue.ts = sym->ts; 4365 if (sym->as) 4366 lvalue.rank = sym->as->rank; 4367 lvalue.symtree = XCNEW (gfc_symtree); 4368 lvalue.symtree->n.sym = sym; 4369 lvalue.where = sym->declared_at; 4370 4371 if (comp) 4372 { 4373 lvalue.ref = gfc_get_ref (); 4374 lvalue.ref->type = REF_COMPONENT; 4375 lvalue.ref->u.c.component = comp; 4376 lvalue.ref->u.c.sym = sym; 4377 lvalue.ts = comp->ts; 4378 lvalue.rank = comp->as ? comp->as->rank : 0; 4379 lvalue.where = comp->loc; 4380 pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp) 4381 ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer; 4382 proc_pointer = comp->attr.proc_pointer; 4383 } 4384 else 4385 { 4386 pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym) 4387 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; 4388 proc_pointer = sym->attr.proc_pointer; 4389 } 4390 4391 if (pointer || proc_pointer) 4392 r = gfc_check_pointer_assign (&lvalue, rvalue, false, true); 4393 else 4394 { 4395 /* If a conversion function, e.g., __convert_i8_i4, was inserted 4396 into an array constructor, we should check if it can be reduced 4397 as an initialization expression. */ 4398 if (rvalue->expr_type == EXPR_FUNCTION 4399 && rvalue->value.function.isym 4400 && (rvalue->value.function.isym->conversion == 1)) 4401 gfc_check_init_expr (rvalue); 4402 4403 r = gfc_check_assign (&lvalue, rvalue, 1); 4404 } 4405 4406 free (lvalue.symtree); 4407 free (lvalue.ref); 4408 4409 if (!r) 4410 return r; 4411 4412 if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer) 4413 { 4414 /* F08:C461. Additional checks for pointer initialization. */ 4415 symbol_attribute attr; 4416 attr = gfc_expr_attr (rvalue); 4417 if (attr.allocatable) 4418 { 4419 gfc_error ("Pointer initialization target at %L " 4420 "must not be ALLOCATABLE", &rvalue->where); 4421 return false; 4422 } 4423 if (!attr.target || attr.pointer) 4424 { 4425 gfc_error ("Pointer initialization target at %L " 4426 "must have the TARGET attribute", &rvalue->where); 4427 return false; 4428 } 4429 4430 if (!attr.save && rvalue->expr_type == EXPR_VARIABLE 4431 && rvalue->symtree->n.sym->ns->proc_name 4432 && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) 4433 { 4434 rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; 4435 attr.save = SAVE_IMPLICIT; 4436 } 4437 4438 if (!attr.save) 4439 { 4440 gfc_error ("Pointer initialization target at %L " 4441 "must have the SAVE attribute", &rvalue->where); 4442 return false; 4443 } 4444 } 4445 4446 if (proc_pointer && rvalue->expr_type != EXPR_NULL) 4447 { 4448 /* F08:C1220. Additional checks for procedure pointer initialization. */ 4449 symbol_attribute attr = gfc_expr_attr (rvalue); 4450 if (attr.proc_pointer) 4451 { 4452 gfc_error ("Procedure pointer initialization target at %L " 4453 "may not be a procedure pointer", &rvalue->where); 4454 return false; 4455 } 4456 if (attr.proc == PROC_INTERNAL) 4457 { 4458 gfc_error ("Internal procedure %qs is invalid in " 4459 "procedure pointer initialization at %L", 4460 rvalue->symtree->name, &rvalue->where); 4461 return false; 4462 } 4463 if (attr.dummy) 4464 { 4465 gfc_error ("Dummy procedure %qs is invalid in " 4466 "procedure pointer initialization at %L", 4467 rvalue->symtree->name, &rvalue->where); 4468 return false; 4469 } 4470 } 4471 4472 return true; 4473 } 4474 4475 /* Invoke gfc_build_init_expr to create an initializer expression, but do not 4476 * require that an expression be built. */ 4477 4478 gfc_expr * 4479 gfc_build_default_init_expr (gfc_typespec *ts, locus *where) 4480 { 4481 return gfc_build_init_expr (ts, where, false); 4482 } 4483 4484 /* Build an initializer for a local integer, real, complex, logical, or 4485 character variable, based on the command line flags finit-local-zero, 4486 finit-integer=, finit-real=, finit-logical=, and finit-character=. 4487 With force, an initializer is ALWAYS generated. */ 4488 4489 gfc_expr * 4490 gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force) 4491 { 4492 gfc_expr *init_expr; 4493 4494 /* Try to build an initializer expression. */ 4495 init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); 4496 4497 /* If we want to force generation, make sure we default to zero. */ 4498 gfc_init_local_real init_real = flag_init_real; 4499 int init_logical = gfc_option.flag_init_logical; 4500 if (force) 4501 { 4502 if (init_real == GFC_INIT_REAL_OFF) 4503 init_real = GFC_INIT_REAL_ZERO; 4504 if (init_logical == GFC_INIT_LOGICAL_OFF) 4505 init_logical = GFC_INIT_LOGICAL_FALSE; 4506 } 4507 4508 /* We will only initialize integers, reals, complex, logicals, and 4509 characters, and only if the corresponding command-line flags 4510 were set. Otherwise, we free init_expr and return null. */ 4511 switch (ts->type) 4512 { 4513 case BT_INTEGER: 4514 if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) 4515 mpz_set_si (init_expr->value.integer, 4516 gfc_option.flag_init_integer_value); 4517 else 4518 { 4519 gfc_free_expr (init_expr); 4520 init_expr = NULL; 4521 } 4522 break; 4523 4524 case BT_REAL: 4525 switch (init_real) 4526 { 4527 case GFC_INIT_REAL_SNAN: 4528 init_expr->is_snan = 1; 4529 /* Fall through. */ 4530 case GFC_INIT_REAL_NAN: 4531 mpfr_set_nan (init_expr->value.real); 4532 break; 4533 4534 case GFC_INIT_REAL_INF: 4535 mpfr_set_inf (init_expr->value.real, 1); 4536 break; 4537 4538 case GFC_INIT_REAL_NEG_INF: 4539 mpfr_set_inf (init_expr->value.real, -1); 4540 break; 4541 4542 case GFC_INIT_REAL_ZERO: 4543 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE); 4544 break; 4545 4546 default: 4547 gfc_free_expr (init_expr); 4548 init_expr = NULL; 4549 break; 4550 } 4551 break; 4552 4553 case BT_COMPLEX: 4554 switch (init_real) 4555 { 4556 case GFC_INIT_REAL_SNAN: 4557 init_expr->is_snan = 1; 4558 /* Fall through. */ 4559 case GFC_INIT_REAL_NAN: 4560 mpfr_set_nan (mpc_realref (init_expr->value.complex)); 4561 mpfr_set_nan (mpc_imagref (init_expr->value.complex)); 4562 break; 4563 4564 case GFC_INIT_REAL_INF: 4565 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1); 4566 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1); 4567 break; 4568 4569 case GFC_INIT_REAL_NEG_INF: 4570 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1); 4571 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1); 4572 break; 4573 4574 case GFC_INIT_REAL_ZERO: 4575 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE); 4576 break; 4577 4578 default: 4579 gfc_free_expr (init_expr); 4580 init_expr = NULL; 4581 break; 4582 } 4583 break; 4584 4585 case BT_LOGICAL: 4586 if (init_logical == GFC_INIT_LOGICAL_FALSE) 4587 init_expr->value.logical = 0; 4588 else if (init_logical == GFC_INIT_LOGICAL_TRUE) 4589 init_expr->value.logical = 1; 4590 else 4591 { 4592 gfc_free_expr (init_expr); 4593 init_expr = NULL; 4594 } 4595 break; 4596 4597 case BT_CHARACTER: 4598 /* For characters, the length must be constant in order to 4599 create a default initializer. */ 4600 if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) 4601 && ts->u.cl->length 4602 && ts->u.cl->length->expr_type == EXPR_CONSTANT) 4603 { 4604 HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 4605 init_expr->value.character.length = char_len; 4606 init_expr->value.character.string = gfc_get_wide_string (char_len+1); 4607 for (size_t i = 0; i < (size_t) char_len; i++) 4608 init_expr->value.character.string[i] 4609 = (unsigned char) gfc_option.flag_init_character_value; 4610 } 4611 else 4612 { 4613 gfc_free_expr (init_expr); 4614 init_expr = NULL; 4615 } 4616 if (!init_expr 4617 && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) 4618 && ts->u.cl->length && flag_max_stack_var_size != 0) 4619 { 4620 gfc_actual_arglist *arg; 4621 init_expr = gfc_get_expr (); 4622 init_expr->where = *where; 4623 init_expr->ts = *ts; 4624 init_expr->expr_type = EXPR_FUNCTION; 4625 init_expr->value.function.isym = 4626 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); 4627 init_expr->value.function.name = "repeat"; 4628 arg = gfc_get_actual_arglist (); 4629 arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1); 4630 arg->expr->value.character.string[0] = 4631 gfc_option.flag_init_character_value; 4632 arg->next = gfc_get_actual_arglist (); 4633 arg->next->expr = gfc_copy_expr (ts->u.cl->length); 4634 init_expr->value.function.actual = arg; 4635 } 4636 break; 4637 4638 default: 4639 gfc_free_expr (init_expr); 4640 init_expr = NULL; 4641 } 4642 4643 return init_expr; 4644 } 4645 4646 /* Apply an initialization expression to a typespec. Can be used for symbols or 4647 components. Similar to add_init_expr_to_sym in decl.c; could probably be 4648 combined with some effort. */ 4649 4650 void 4651 gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) 4652 { 4653 if (ts->type == BT_CHARACTER && !attr->pointer && init 4654 && ts->u.cl 4655 && ts->u.cl->length 4656 && ts->u.cl->length->expr_type == EXPR_CONSTANT 4657 && ts->u.cl->length->ts.type == BT_INTEGER) 4658 { 4659 HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 4660 4661 if (init->expr_type == EXPR_CONSTANT) 4662 gfc_set_constant_character_len (len, init, -1); 4663 else if (init 4664 && init->ts.type == BT_CHARACTER 4665 && init->ts.u.cl && init->ts.u.cl->length 4666 && mpz_cmp (ts->u.cl->length->value.integer, 4667 init->ts.u.cl->length->value.integer)) 4668 { 4669 gfc_constructor *ctor; 4670 ctor = gfc_constructor_first (init->value.constructor); 4671 4672 if (ctor) 4673 { 4674 bool has_ts = (init->ts.u.cl 4675 && init->ts.u.cl->length_from_typespec); 4676 4677 /* Remember the length of the first element for checking 4678 that all elements *in the constructor* have the same 4679 length. This need not be the length of the LHS! */ 4680 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); 4681 gcc_assert (ctor->expr->ts.type == BT_CHARACTER); 4682 gfc_charlen_t first_len = ctor->expr->value.character.length; 4683 4684 for ( ; ctor; ctor = gfc_constructor_next (ctor)) 4685 if (ctor->expr->expr_type == EXPR_CONSTANT) 4686 { 4687 gfc_set_constant_character_len (len, ctor->expr, 4688 has_ts ? -1 : first_len); 4689 if (!ctor->expr->ts.u.cl) 4690 ctor->expr->ts.u.cl 4691 = gfc_new_charlen (gfc_current_ns, ts->u.cl); 4692 else 4693 ctor->expr->ts.u.cl->length 4694 = gfc_copy_expr (ts->u.cl->length); 4695 } 4696 } 4697 } 4698 } 4699 } 4700 4701 4702 /* Check whether an expression is a structure constructor and whether it has 4703 other values than NULL. */ 4704 4705 bool 4706 is_non_empty_structure_constructor (gfc_expr * e) 4707 { 4708 if (e->expr_type != EXPR_STRUCTURE) 4709 return false; 4710 4711 gfc_constructor *cons = gfc_constructor_first (e->value.constructor); 4712 while (cons) 4713 { 4714 if (!cons->expr || cons->expr->expr_type != EXPR_NULL) 4715 return true; 4716 cons = gfc_constructor_next (cons); 4717 } 4718 return false; 4719 } 4720 4721 4722 /* Check for default initializer; sym->value is not enough 4723 as it is also set for EXPR_NULL of allocatables. */ 4724 4725 bool 4726 gfc_has_default_initializer (gfc_symbol *der) 4727 { 4728 gfc_component *c; 4729 4730 gcc_assert (gfc_fl_struct (der->attr.flavor)); 4731 for (c = der->components; c; c = c->next) 4732 if (gfc_bt_struct (c->ts.type)) 4733 { 4734 if (!c->attr.pointer && !c->attr.proc_pointer 4735 && !(c->attr.allocatable && der == c->ts.u.derived) 4736 && ((c->initializer 4737 && is_non_empty_structure_constructor (c->initializer)) 4738 || gfc_has_default_initializer (c->ts.u.derived))) 4739 return true; 4740 if (c->attr.pointer && c->initializer) 4741 return true; 4742 } 4743 else 4744 { 4745 if (c->initializer) 4746 return true; 4747 } 4748 4749 return false; 4750 } 4751 4752 4753 /* 4754 Generate an initializer expression which initializes the entirety of a union. 4755 A normal structure constructor is insufficient without undue effort, because 4756 components of maps may be oddly aligned/overlapped. (For example if a 4757 character is initialized from one map overtop a real from the other, only one 4758 byte of the real is actually initialized.) Unfortunately we don't know the 4759 size of the union right now, so we can't generate a proper initializer, but 4760 we use a NULL expr as a placeholder and do the right thing later in 4761 gfc_trans_subcomponent_assign. 4762 */ 4763 static gfc_expr * 4764 generate_union_initializer (gfc_component *un) 4765 { 4766 if (un == NULL || un->ts.type != BT_UNION) 4767 return NULL; 4768 4769 gfc_expr *placeholder = gfc_get_null_expr (&un->loc); 4770 placeholder->ts = un->ts; 4771 return placeholder; 4772 } 4773 4774 4775 /* Get the user-specified initializer for a union, if any. This means the user 4776 has said to initialize component(s) of a map. For simplicity's sake we 4777 only allow the user to initialize the first map. We don't have to worry 4778 about overlapping initializers as they are released early in resolution (see 4779 resolve_fl_struct). */ 4780 4781 static gfc_expr * 4782 get_union_initializer (gfc_symbol *union_type, gfc_component **map_p) 4783 { 4784 gfc_component *map; 4785 gfc_expr *init=NULL; 4786 4787 if (!union_type || union_type->attr.flavor != FL_UNION) 4788 return NULL; 4789 4790 for (map = union_type->components; map; map = map->next) 4791 { 4792 if (gfc_has_default_initializer (map->ts.u.derived)) 4793 { 4794 init = gfc_default_initializer (&map->ts); 4795 if (map_p) 4796 *map_p = map; 4797 break; 4798 } 4799 } 4800 4801 if (map_p && !init) 4802 *map_p = NULL; 4803 4804 return init; 4805 } 4806 4807 static bool 4808 class_allocatable (gfc_component *comp) 4809 { 4810 return comp->ts.type == BT_CLASS && CLASS_DATA (comp) 4811 && CLASS_DATA (comp)->attr.allocatable; 4812 } 4813 4814 static bool 4815 class_pointer (gfc_component *comp) 4816 { 4817 return comp->ts.type == BT_CLASS && CLASS_DATA (comp) 4818 && CLASS_DATA (comp)->attr.pointer; 4819 } 4820 4821 static bool 4822 comp_allocatable (gfc_component *comp) 4823 { 4824 return comp->attr.allocatable || class_allocatable (comp); 4825 } 4826 4827 static bool 4828 comp_pointer (gfc_component *comp) 4829 { 4830 return comp->attr.pointer 4831 || comp->attr.proc_pointer 4832 || comp->attr.class_pointer 4833 || class_pointer (comp); 4834 } 4835 4836 /* Fetch or generate an initializer for the given component. 4837 Only generate an initializer if generate is true. */ 4838 4839 static gfc_expr * 4840 component_initializer (gfc_component *c, bool generate) 4841 { 4842 gfc_expr *init = NULL; 4843 4844 /* Allocatable components always get EXPR_NULL. 4845 Pointer components are only initialized when generating, and only if they 4846 do not already have an initializer. */ 4847 if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer)) 4848 { 4849 init = gfc_get_null_expr (&c->loc); 4850 init->ts = c->ts; 4851 return init; 4852 } 4853 4854 /* See if we can find the initializer immediately. */ 4855 if (c->initializer || !generate) 4856 return c->initializer; 4857 4858 /* Recursively handle derived type components. */ 4859 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 4860 init = gfc_generate_initializer (&c->ts, true); 4861 4862 else if (c->ts.type == BT_UNION && c->ts.u.derived->components) 4863 { 4864 gfc_component *map = NULL; 4865 gfc_constructor *ctor; 4866 gfc_expr *user_init; 4867 4868 /* If we don't have a user initializer and we aren't generating one, this 4869 union has no initializer. */ 4870 user_init = get_union_initializer (c->ts.u.derived, &map); 4871 if (!user_init && !generate) 4872 return NULL; 4873 4874 /* Otherwise use a structure constructor. */ 4875 init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind, 4876 &c->loc); 4877 init->ts = c->ts; 4878 4879 /* If we are to generate an initializer for the union, add a constructor 4880 which initializes the whole union first. */ 4881 if (generate) 4882 { 4883 ctor = gfc_constructor_get (); 4884 ctor->expr = generate_union_initializer (c); 4885 gfc_constructor_append (&init->value.constructor, ctor); 4886 } 4887 4888 /* If we found an initializer in one of our maps, apply it. Note this 4889 is applied _after_ the entire-union initializer above if any. */ 4890 if (user_init) 4891 { 4892 ctor = gfc_constructor_get (); 4893 ctor->expr = user_init; 4894 ctor->n.component = map; 4895 gfc_constructor_append (&init->value.constructor, ctor); 4896 } 4897 } 4898 4899 /* Treat simple components like locals. */ 4900 else 4901 { 4902 /* We MUST give an initializer, so force generation. */ 4903 init = gfc_build_init_expr (&c->ts, &c->loc, true); 4904 gfc_apply_init (&c->ts, &c->attr, init); 4905 } 4906 4907 return init; 4908 } 4909 4910 4911 /* Get an expression for a default initializer of a derived type. */ 4912 4913 gfc_expr * 4914 gfc_default_initializer (gfc_typespec *ts) 4915 { 4916 return gfc_generate_initializer (ts, false); 4917 } 4918 4919 /* Generate an initializer expression for an iso_c_binding type 4920 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */ 4921 4922 static gfc_expr * 4923 generate_isocbinding_initializer (gfc_symbol *derived) 4924 { 4925 /* The initializers have already been built into the c_null_[fun]ptr symbols 4926 from gen_special_c_interop_ptr. */ 4927 gfc_symtree *npsym = NULL; 4928 if (0 == strcmp (derived->name, "c_ptr")) 4929 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym); 4930 else if (0 == strcmp (derived->name, "c_funptr")) 4931 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym); 4932 else 4933 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding" 4934 " type, expected %<c_ptr%> or %<c_funptr%>"); 4935 if (npsym) 4936 { 4937 gfc_expr *init = gfc_copy_expr (npsym->n.sym->value); 4938 init->symtree = npsym; 4939 init->ts.is_iso_c = true; 4940 return init; 4941 } 4942 4943 return NULL; 4944 } 4945 4946 /* Get or generate an expression for a default initializer of a derived type. 4947 If -finit-derived is specified, generate default initialization expressions 4948 for components that lack them when generate is set. */ 4949 4950 gfc_expr * 4951 gfc_generate_initializer (gfc_typespec *ts, bool generate) 4952 { 4953 gfc_expr *init, *tmp; 4954 gfc_component *comp; 4955 4956 generate = flag_init_derived && generate; 4957 4958 if (ts->u.derived->ts.is_iso_c && generate) 4959 return generate_isocbinding_initializer (ts->u.derived); 4960 4961 /* See if we have a default initializer in this, but not in nested 4962 types (otherwise we could use gfc_has_default_initializer()). 4963 We don't need to check if we are going to generate them. */ 4964 comp = ts->u.derived->components; 4965 if (!generate) 4966 { 4967 for (; comp; comp = comp->next) 4968 if (comp->initializer || comp_allocatable (comp)) 4969 break; 4970 } 4971 4972 if (!comp) 4973 return NULL; 4974 4975 init = gfc_get_structure_constructor_expr (ts->type, ts->kind, 4976 &ts->u.derived->declared_at); 4977 init->ts = *ts; 4978 4979 for (comp = ts->u.derived->components; comp; comp = comp->next) 4980 { 4981 gfc_constructor *ctor = gfc_constructor_get(); 4982 4983 /* Fetch or generate an initializer for the component. */ 4984 tmp = component_initializer (comp, generate); 4985 if (tmp) 4986 { 4987 /* Save the component ref for STRUCTUREs and UNIONs. */ 4988 if (ts->u.derived->attr.flavor == FL_STRUCT 4989 || ts->u.derived->attr.flavor == FL_UNION) 4990 ctor->n.component = comp; 4991 4992 /* If the initializer was not generated, we need a copy. */ 4993 ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp; 4994 if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind) 4995 && !comp->attr.pointer && !comp->attr.proc_pointer) 4996 { 4997 bool val; 4998 val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false); 4999 if (val == false) 5000 return NULL; 5001 } 5002 } 5003 5004 gfc_constructor_append (&init->value.constructor, ctor); 5005 } 5006 5007 return init; 5008 } 5009 5010 5011 /* Given a symbol, create an expression node with that symbol as a 5012 variable. If the symbol is array valued, setup a reference of the 5013 whole array. */ 5014 5015 gfc_expr * 5016 gfc_get_variable_expr (gfc_symtree *var) 5017 { 5018 gfc_expr *e; 5019 5020 e = gfc_get_expr (); 5021 e->expr_type = EXPR_VARIABLE; 5022 e->symtree = var; 5023 e->ts = var->n.sym->ts; 5024 5025 if (var->n.sym->attr.flavor != FL_PROCEDURE 5026 && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) 5027 || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym) 5028 && CLASS_DATA (var->n.sym)->as))) 5029 { 5030 e->rank = var->n.sym->ts.type == BT_CLASS 5031 ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; 5032 e->ref = gfc_get_ref (); 5033 e->ref->type = REF_ARRAY; 5034 e->ref->u.ar.type = AR_FULL; 5035 e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS 5036 ? CLASS_DATA (var->n.sym)->as 5037 : var->n.sym->as); 5038 } 5039 5040 return e; 5041 } 5042 5043 5044 /* Adds a full array reference to an expression, as needed. */ 5045 5046 void 5047 gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) 5048 { 5049 gfc_ref *ref; 5050 for (ref = e->ref; ref; ref = ref->next) 5051 if (!ref->next) 5052 break; 5053 if (ref) 5054 { 5055 ref->next = gfc_get_ref (); 5056 ref = ref->next; 5057 } 5058 else 5059 { 5060 e->ref = gfc_get_ref (); 5061 ref = e->ref; 5062 } 5063 ref->type = REF_ARRAY; 5064 ref->u.ar.type = AR_FULL; 5065 ref->u.ar.dimen = e->rank; 5066 ref->u.ar.where = e->where; 5067 ref->u.ar.as = as; 5068 } 5069 5070 5071 gfc_expr * 5072 gfc_lval_expr_from_sym (gfc_symbol *sym) 5073 { 5074 gfc_expr *lval; 5075 gfc_array_spec *as; 5076 lval = gfc_get_expr (); 5077 lval->expr_type = EXPR_VARIABLE; 5078 lval->where = sym->declared_at; 5079 lval->ts = sym->ts; 5080 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); 5081 5082 /* It will always be a full array. */ 5083 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; 5084 lval->rank = as ? as->rank : 0; 5085 if (lval->rank) 5086 gfc_add_full_array_ref (lval, as); 5087 return lval; 5088 } 5089 5090 5091 /* Returns the array_spec of a full array expression. A NULL is 5092 returned otherwise. */ 5093 gfc_array_spec * 5094 gfc_get_full_arrayspec_from_expr (gfc_expr *expr) 5095 { 5096 gfc_array_spec *as; 5097 gfc_ref *ref; 5098 5099 if (expr->rank == 0) 5100 return NULL; 5101 5102 /* Follow any component references. */ 5103 if (expr->expr_type == EXPR_VARIABLE 5104 || expr->expr_type == EXPR_CONSTANT) 5105 { 5106 if (expr->symtree) 5107 as = expr->symtree->n.sym->as; 5108 else 5109 as = NULL; 5110 5111 for (ref = expr->ref; ref; ref = ref->next) 5112 { 5113 switch (ref->type) 5114 { 5115 case REF_COMPONENT: 5116 as = ref->u.c.component->as; 5117 continue; 5118 5119 case REF_SUBSTRING: 5120 case REF_INQUIRY: 5121 continue; 5122 5123 case REF_ARRAY: 5124 { 5125 switch (ref->u.ar.type) 5126 { 5127 case AR_ELEMENT: 5128 case AR_SECTION: 5129 case AR_UNKNOWN: 5130 as = NULL; 5131 continue; 5132 5133 case AR_FULL: 5134 break; 5135 } 5136 break; 5137 } 5138 } 5139 } 5140 } 5141 else 5142 as = NULL; 5143 5144 return as; 5145 } 5146 5147 5148 /* General expression traversal function. */ 5149 5150 bool 5151 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, 5152 bool (*func)(gfc_expr *, gfc_symbol *, int*), 5153 int f) 5154 { 5155 gfc_array_ref ar; 5156 gfc_ref *ref; 5157 gfc_actual_arglist *args; 5158 gfc_constructor *c; 5159 int i; 5160 5161 if (!expr) 5162 return false; 5163 5164 if ((*func) (expr, sym, &f)) 5165 return true; 5166 5167 if (expr->ts.type == BT_CHARACTER 5168 && expr->ts.u.cl 5169 && expr->ts.u.cl->length 5170 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT 5171 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) 5172 return true; 5173 5174 switch (expr->expr_type) 5175 { 5176 case EXPR_PPC: 5177 case EXPR_COMPCALL: 5178 case EXPR_FUNCTION: 5179 for (args = expr->value.function.actual; args; args = args->next) 5180 { 5181 if (gfc_traverse_expr (args->expr, sym, func, f)) 5182 return true; 5183 } 5184 break; 5185 5186 case EXPR_VARIABLE: 5187 case EXPR_CONSTANT: 5188 case EXPR_NULL: 5189 case EXPR_SUBSTRING: 5190 break; 5191 5192 case EXPR_STRUCTURE: 5193 case EXPR_ARRAY: 5194 for (c = gfc_constructor_first (expr->value.constructor); 5195 c; c = gfc_constructor_next (c)) 5196 { 5197 if (gfc_traverse_expr (c->expr, sym, func, f)) 5198 return true; 5199 if (c->iterator) 5200 { 5201 if (gfc_traverse_expr (c->iterator->var, sym, func, f)) 5202 return true; 5203 if (gfc_traverse_expr (c->iterator->start, sym, func, f)) 5204 return true; 5205 if (gfc_traverse_expr (c->iterator->end, sym, func, f)) 5206 return true; 5207 if (gfc_traverse_expr (c->iterator->step, sym, func, f)) 5208 return true; 5209 } 5210 } 5211 break; 5212 5213 case EXPR_OP: 5214 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) 5215 return true; 5216 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) 5217 return true; 5218 break; 5219 5220 default: 5221 gcc_unreachable (); 5222 break; 5223 } 5224 5225 ref = expr->ref; 5226 while (ref != NULL) 5227 { 5228 switch (ref->type) 5229 { 5230 case REF_ARRAY: 5231 ar = ref->u.ar; 5232 for (i = 0; i < GFC_MAX_DIMENSIONS; i++) 5233 { 5234 if (gfc_traverse_expr (ar.start[i], sym, func, f)) 5235 return true; 5236 if (gfc_traverse_expr (ar.end[i], sym, func, f)) 5237 return true; 5238 if (gfc_traverse_expr (ar.stride[i], sym, func, f)) 5239 return true; 5240 } 5241 break; 5242 5243 case REF_SUBSTRING: 5244 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) 5245 return true; 5246 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) 5247 return true; 5248 break; 5249 5250 case REF_COMPONENT: 5251 if (ref->u.c.component->ts.type == BT_CHARACTER 5252 && ref->u.c.component->ts.u.cl 5253 && ref->u.c.component->ts.u.cl->length 5254 && ref->u.c.component->ts.u.cl->length->expr_type 5255 != EXPR_CONSTANT 5256 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, 5257 sym, func, f)) 5258 return true; 5259 5260 if (ref->u.c.component->as) 5261 for (i = 0; i < ref->u.c.component->as->rank 5262 + ref->u.c.component->as->corank; i++) 5263 { 5264 if (gfc_traverse_expr (ref->u.c.component->as->lower[i], 5265 sym, func, f)) 5266 return true; 5267 if (gfc_traverse_expr (ref->u.c.component->as->upper[i], 5268 sym, func, f)) 5269 return true; 5270 } 5271 break; 5272 5273 case REF_INQUIRY: 5274 return true; 5275 5276 default: 5277 gcc_unreachable (); 5278 } 5279 ref = ref->next; 5280 } 5281 return false; 5282 } 5283 5284 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ 5285 5286 static bool 5287 expr_set_symbols_referenced (gfc_expr *expr, 5288 gfc_symbol *sym ATTRIBUTE_UNUSED, 5289 int *f ATTRIBUTE_UNUSED) 5290 { 5291 if (expr->expr_type != EXPR_VARIABLE) 5292 return false; 5293 gfc_set_sym_referenced (expr->symtree->n.sym); 5294 return false; 5295 } 5296 5297 void 5298 gfc_expr_set_symbols_referenced (gfc_expr *expr) 5299 { 5300 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); 5301 } 5302 5303 5304 /* Determine if an expression is a procedure pointer component and return 5305 the component in that case. Otherwise return NULL. */ 5306 5307 gfc_component * 5308 gfc_get_proc_ptr_comp (gfc_expr *expr) 5309 { 5310 gfc_ref *ref; 5311 5312 if (!expr || !expr->ref) 5313 return NULL; 5314 5315 ref = expr->ref; 5316 while (ref->next) 5317 ref = ref->next; 5318 5319 if (ref->type == REF_COMPONENT 5320 && ref->u.c.component->attr.proc_pointer) 5321 return ref->u.c.component; 5322 5323 return NULL; 5324 } 5325 5326 5327 /* Determine if an expression is a procedure pointer component. */ 5328 5329 bool 5330 gfc_is_proc_ptr_comp (gfc_expr *expr) 5331 { 5332 return (gfc_get_proc_ptr_comp (expr) != NULL); 5333 } 5334 5335 5336 /* Determine if an expression is a function with an allocatable class scalar 5337 result. */ 5338 bool 5339 gfc_is_alloc_class_scalar_function (gfc_expr *expr) 5340 { 5341 if (expr->expr_type == EXPR_FUNCTION 5342 && expr->value.function.esym 5343 && expr->value.function.esym->result 5344 && expr->value.function.esym->result->ts.type == BT_CLASS 5345 && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension 5346 && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) 5347 return true; 5348 5349 return false; 5350 } 5351 5352 5353 /* Determine if an expression is a function with an allocatable class array 5354 result. */ 5355 bool 5356 gfc_is_class_array_function (gfc_expr *expr) 5357 { 5358 if (expr->expr_type == EXPR_FUNCTION 5359 && expr->value.function.esym 5360 && expr->value.function.esym->result 5361 && expr->value.function.esym->result->ts.type == BT_CLASS 5362 && CLASS_DATA (expr->value.function.esym->result)->attr.dimension 5363 && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable 5364 || CLASS_DATA (expr->value.function.esym->result)->attr.pointer)) 5365 return true; 5366 5367 return false; 5368 } 5369 5370 5371 /* Walk an expression tree and check each variable encountered for being typed. 5372 If strict is not set, a top-level variable is tolerated untyped in -std=gnu 5373 mode as is a basic arithmetic expression using those; this is for things in 5374 legacy-code like: 5375 5376 INTEGER :: arr(n), n 5377 INTEGER :: arr(n + 1), n 5378 5379 The namespace is needed for IMPLICIT typing. */ 5380 5381 static gfc_namespace* check_typed_ns; 5382 5383 static bool 5384 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, 5385 int* f ATTRIBUTE_UNUSED) 5386 { 5387 bool t; 5388 5389 if (e->expr_type != EXPR_VARIABLE) 5390 return false; 5391 5392 gcc_assert (e->symtree); 5393 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, 5394 true, e->where); 5395 5396 return (!t); 5397 } 5398 5399 bool 5400 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) 5401 { 5402 bool error_found; 5403 5404 /* If this is a top-level variable or EXPR_OP, do the check with strict given 5405 to us. */ 5406 if (!strict) 5407 { 5408 if (e->expr_type == EXPR_VARIABLE && !e->ref) 5409 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); 5410 5411 if (e->expr_type == EXPR_OP) 5412 { 5413 bool t = true; 5414 5415 gcc_assert (e->value.op.op1); 5416 t = gfc_expr_check_typed (e->value.op.op1, ns, strict); 5417 5418 if (t && e->value.op.op2) 5419 t = gfc_expr_check_typed (e->value.op.op2, ns, strict); 5420 5421 return t; 5422 } 5423 } 5424 5425 /* Otherwise, walk the expression and do it strictly. */ 5426 check_typed_ns = ns; 5427 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); 5428 5429 return error_found ? false : true; 5430 } 5431 5432 5433 /* This function returns true if it contains any references to PDT KIND 5434 or LEN parameters. */ 5435 5436 static bool 5437 derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, 5438 int* f ATTRIBUTE_UNUSED) 5439 { 5440 if (e->expr_type != EXPR_VARIABLE) 5441 return false; 5442 5443 gcc_assert (e->symtree); 5444 if (e->symtree->n.sym->attr.pdt_kind 5445 || e->symtree->n.sym->attr.pdt_len) 5446 return true; 5447 5448 return false; 5449 } 5450 5451 5452 bool 5453 gfc_derived_parameter_expr (gfc_expr *e) 5454 { 5455 return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0); 5456 } 5457 5458 5459 /* This function returns the overall type of a type parameter spec list. 5460 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the 5461 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned 5462 unless derived is not NULL. In this latter case, all the LEN parameters 5463 must be either assumed or deferred for the return argument to be set to 5464 anything other than SPEC_EXPLICIT. */ 5465 5466 gfc_param_spec_type 5467 gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) 5468 { 5469 gfc_param_spec_type res = SPEC_EXPLICIT; 5470 gfc_component *c; 5471 bool seen_assumed = false; 5472 bool seen_deferred = false; 5473 5474 if (derived == NULL) 5475 { 5476 for (; param_list; param_list = param_list->next) 5477 if (param_list->spec_type == SPEC_ASSUMED 5478 || param_list->spec_type == SPEC_DEFERRED) 5479 return param_list->spec_type; 5480 } 5481 else 5482 { 5483 for (; param_list; param_list = param_list->next) 5484 { 5485 c = gfc_find_component (derived, param_list->name, 5486 true, true, NULL); 5487 gcc_assert (c != NULL); 5488 if (c->attr.pdt_kind) 5489 continue; 5490 else if (param_list->spec_type == SPEC_EXPLICIT) 5491 return SPEC_EXPLICIT; 5492 seen_assumed = param_list->spec_type == SPEC_ASSUMED; 5493 seen_deferred = param_list->spec_type == SPEC_DEFERRED; 5494 if (seen_assumed && seen_deferred) 5495 return SPEC_EXPLICIT; 5496 } 5497 res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; 5498 } 5499 return res; 5500 } 5501 5502 5503 bool 5504 gfc_ref_this_image (gfc_ref *ref) 5505 { 5506 int n; 5507 5508 gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0); 5509 5510 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) 5511 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) 5512 return false; 5513 5514 return true; 5515 } 5516 5517 gfc_expr * 5518 gfc_find_team_co (gfc_expr *e) 5519 { 5520 gfc_ref *ref; 5521 5522 for (ref = e->ref; ref; ref = ref->next) 5523 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5524 return ref->u.ar.team; 5525 5526 if (e->value.function.actual->expr) 5527 for (ref = e->value.function.actual->expr->ref; ref; 5528 ref = ref->next) 5529 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5530 return ref->u.ar.team; 5531 5532 return NULL; 5533 } 5534 5535 gfc_expr * 5536 gfc_find_stat_co (gfc_expr *e) 5537 { 5538 gfc_ref *ref; 5539 5540 for (ref = e->ref; ref; ref = ref->next) 5541 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5542 return ref->u.ar.stat; 5543 5544 if (e->value.function.actual->expr) 5545 for (ref = e->value.function.actual->expr->ref; ref; 5546 ref = ref->next) 5547 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5548 return ref->u.ar.stat; 5549 5550 return NULL; 5551 } 5552 5553 bool 5554 gfc_is_coindexed (gfc_expr *e) 5555 { 5556 gfc_ref *ref; 5557 5558 for (ref = e->ref; ref; ref = ref->next) 5559 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5560 return !gfc_ref_this_image (ref); 5561 5562 return false; 5563 } 5564 5565 5566 /* Coarrays are variables with a corank but not being coindexed. However, also 5567 the following is a coarray: A subobject of a coarray is a coarray if it does 5568 not have any cosubscripts, vector subscripts, allocatable component 5569 selection, or pointer component selection. (F2008, 2.4.7) */ 5570 5571 bool 5572 gfc_is_coarray (gfc_expr *e) 5573 { 5574 gfc_ref *ref; 5575 gfc_symbol *sym; 5576 gfc_component *comp; 5577 bool coindexed; 5578 bool coarray; 5579 int i; 5580 5581 if (e->expr_type != EXPR_VARIABLE) 5582 return false; 5583 5584 coindexed = false; 5585 sym = e->symtree->n.sym; 5586 5587 if (sym->ts.type == BT_CLASS && sym->attr.class_ok) 5588 coarray = CLASS_DATA (sym)->attr.codimension; 5589 else 5590 coarray = sym->attr.codimension; 5591 5592 for (ref = e->ref; ref; ref = ref->next) 5593 switch (ref->type) 5594 { 5595 case REF_COMPONENT: 5596 comp = ref->u.c.component; 5597 if (comp->ts.type == BT_CLASS && comp->attr.class_ok 5598 && (CLASS_DATA (comp)->attr.class_pointer 5599 || CLASS_DATA (comp)->attr.allocatable)) 5600 { 5601 coindexed = false; 5602 coarray = CLASS_DATA (comp)->attr.codimension; 5603 } 5604 else if (comp->attr.pointer || comp->attr.allocatable) 5605 { 5606 coindexed = false; 5607 coarray = comp->attr.codimension; 5608 } 5609 break; 5610 5611 case REF_ARRAY: 5612 if (!coarray) 5613 break; 5614 5615 if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) 5616 { 5617 coindexed = true; 5618 break; 5619 } 5620 5621 for (i = 0; i < ref->u.ar.dimen; i++) 5622 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 5623 { 5624 coarray = false; 5625 break; 5626 } 5627 break; 5628 5629 case REF_SUBSTRING: 5630 case REF_INQUIRY: 5631 break; 5632 } 5633 5634 return coarray && !coindexed; 5635 } 5636 5637 5638 int 5639 gfc_get_corank (gfc_expr *e) 5640 { 5641 int corank; 5642 gfc_ref *ref; 5643 5644 if (!gfc_is_coarray (e)) 5645 return 0; 5646 5647 if (e->ts.type == BT_CLASS && e->ts.u.derived->components) 5648 corank = e->ts.u.derived->components->as 5649 ? e->ts.u.derived->components->as->corank : 0; 5650 else 5651 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; 5652 5653 for (ref = e->ref; ref; ref = ref->next) 5654 { 5655 if (ref->type == REF_ARRAY) 5656 corank = ref->u.ar.as->corank; 5657 gcc_assert (ref->type != REF_SUBSTRING); 5658 } 5659 5660 return corank; 5661 } 5662 5663 5664 /* Check whether the expression has an ultimate allocatable component. 5665 Being itself allocatable does not count. */ 5666 bool 5667 gfc_has_ultimate_allocatable (gfc_expr *e) 5668 { 5669 gfc_ref *ref, *last = NULL; 5670 5671 if (e->expr_type != EXPR_VARIABLE) 5672 return false; 5673 5674 for (ref = e->ref; ref; ref = ref->next) 5675 if (ref->type == REF_COMPONENT) 5676 last = ref; 5677 5678 if (last && last->u.c.component->ts.type == BT_CLASS) 5679 return CLASS_DATA (last->u.c.component)->attr.alloc_comp; 5680 else if (last && last->u.c.component->ts.type == BT_DERIVED) 5681 return last->u.c.component->ts.u.derived->attr.alloc_comp; 5682 else if (last) 5683 return false; 5684 5685 if (e->ts.type == BT_CLASS) 5686 return CLASS_DATA (e)->attr.alloc_comp; 5687 else if (e->ts.type == BT_DERIVED) 5688 return e->ts.u.derived->attr.alloc_comp; 5689 else 5690 return false; 5691 } 5692 5693 5694 /* Check whether the expression has an pointer component. 5695 Being itself a pointer does not count. */ 5696 bool 5697 gfc_has_ultimate_pointer (gfc_expr *e) 5698 { 5699 gfc_ref *ref, *last = NULL; 5700 5701 if (e->expr_type != EXPR_VARIABLE) 5702 return false; 5703 5704 for (ref = e->ref; ref; ref = ref->next) 5705 if (ref->type == REF_COMPONENT) 5706 last = ref; 5707 5708 if (last && last->u.c.component->ts.type == BT_CLASS) 5709 return CLASS_DATA (last->u.c.component)->attr.pointer_comp; 5710 else if (last && last->u.c.component->ts.type == BT_DERIVED) 5711 return last->u.c.component->ts.u.derived->attr.pointer_comp; 5712 else if (last) 5713 return false; 5714 5715 if (e->ts.type == BT_CLASS) 5716 return CLASS_DATA (e)->attr.pointer_comp; 5717 else if (e->ts.type == BT_DERIVED) 5718 return e->ts.u.derived->attr.pointer_comp; 5719 else 5720 return false; 5721 } 5722 5723 5724 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. 5725 Note: A scalar is not regarded as "simply contiguous" by the standard. 5726 if bool is not strict, some further checks are done - for instance, 5727 a "(::1)" is accepted. */ 5728 5729 bool 5730 gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) 5731 { 5732 bool colon; 5733 int i; 5734 gfc_array_ref *ar = NULL; 5735 gfc_ref *ref, *part_ref = NULL; 5736 gfc_symbol *sym; 5737 5738 if (expr->expr_type == EXPR_FUNCTION) 5739 { 5740 if (expr->value.function.esym) 5741 return expr->value.function.esym->result->attr.contiguous; 5742 else 5743 { 5744 /* Type-bound procedures. */ 5745 gfc_symbol *s = expr->symtree->n.sym; 5746 if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED) 5747 return false; 5748 5749 gfc_ref *rc = NULL; 5750 for (gfc_ref *r = expr->ref; r; r = r->next) 5751 if (r->type == REF_COMPONENT) 5752 rc = r; 5753 5754 if (rc == NULL || rc->u.c.component == NULL 5755 || rc->u.c.component->ts.interface == NULL) 5756 return false; 5757 5758 return rc->u.c.component->ts.interface->attr.contiguous; 5759 } 5760 } 5761 else if (expr->expr_type != EXPR_VARIABLE) 5762 return false; 5763 5764 if (!permit_element && expr->rank == 0) 5765 return false; 5766 5767 for (ref = expr->ref; ref; ref = ref->next) 5768 { 5769 if (ar) 5770 return false; /* Array shall be last part-ref. */ 5771 5772 if (ref->type == REF_COMPONENT) 5773 part_ref = ref; 5774 else if (ref->type == REF_SUBSTRING) 5775 return false; 5776 else if (ref->u.ar.type != AR_ELEMENT) 5777 ar = &ref->u.ar; 5778 } 5779 5780 sym = expr->symtree->n.sym; 5781 if (expr->ts.type != BT_CLASS 5782 && ((part_ref 5783 && !part_ref->u.c.component->attr.contiguous 5784 && part_ref->u.c.component->attr.pointer) 5785 || (!part_ref 5786 && !sym->attr.contiguous 5787 && (sym->attr.pointer 5788 || (sym->as && sym->as->type == AS_ASSUMED_RANK) 5789 || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))) 5790 return false; 5791 5792 if (!ar || ar->type == AR_FULL) 5793 return true; 5794 5795 gcc_assert (ar->type == AR_SECTION); 5796 5797 /* Check for simply contiguous array */ 5798 colon = true; 5799 for (i = 0; i < ar->dimen; i++) 5800 { 5801 if (ar->dimen_type[i] == DIMEN_VECTOR) 5802 return false; 5803 5804 if (ar->dimen_type[i] == DIMEN_ELEMENT) 5805 { 5806 colon = false; 5807 continue; 5808 } 5809 5810 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); 5811 5812 5813 /* If the previous section was not contiguous, that's an error, 5814 unless we have effective only one element and checking is not 5815 strict. */ 5816 if (!colon && (strict || !ar->start[i] || !ar->end[i] 5817 || ar->start[i]->expr_type != EXPR_CONSTANT 5818 || ar->end[i]->expr_type != EXPR_CONSTANT 5819 || mpz_cmp (ar->start[i]->value.integer, 5820 ar->end[i]->value.integer) != 0)) 5821 return false; 5822 5823 /* Following the standard, "(::1)" or - if known at compile time - 5824 "(lbound:ubound)" are not simply contiguous; if strict 5825 is false, they are regarded as simply contiguous. */ 5826 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT 5827 || ar->stride[i]->ts.type != BT_INTEGER 5828 || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) 5829 return false; 5830 5831 if (ar->start[i] 5832 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT 5833 || !ar->as->lower[i] 5834 || ar->as->lower[i]->expr_type != EXPR_CONSTANT 5835 || mpz_cmp (ar->start[i]->value.integer, 5836 ar->as->lower[i]->value.integer) != 0)) 5837 colon = false; 5838 5839 if (ar->end[i] 5840 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT 5841 || !ar->as->upper[i] 5842 || ar->as->upper[i]->expr_type != EXPR_CONSTANT 5843 || mpz_cmp (ar->end[i]->value.integer, 5844 ar->as->upper[i]->value.integer) != 0)) 5845 colon = false; 5846 } 5847 5848 return true; 5849 } 5850 5851 /* Return true if the expression is guaranteed to be non-contiguous, 5852 false if we cannot prove anything. It is probably best to call 5853 this after gfc_is_simply_contiguous. If neither of them returns 5854 true, we cannot say (at compile-time). */ 5855 5856 bool 5857 gfc_is_not_contiguous (gfc_expr *array) 5858 { 5859 int i; 5860 gfc_array_ref *ar = NULL; 5861 gfc_ref *ref; 5862 bool previous_incomplete; 5863 5864 for (ref = array->ref; ref; ref = ref->next) 5865 { 5866 /* Array-ref shall be last ref. */ 5867 5868 if (ar) 5869 return true; 5870 5871 if (ref->type == REF_ARRAY) 5872 ar = &ref->u.ar; 5873 } 5874 5875 if (ar == NULL || ar->type != AR_SECTION) 5876 return false; 5877 5878 previous_incomplete = false; 5879 5880 /* Check if we can prove that the array is not contiguous. */ 5881 5882 for (i = 0; i < ar->dimen; i++) 5883 { 5884 mpz_t arr_size, ref_size; 5885 5886 if (gfc_ref_dimen_size (ar, i, &ref_size, NULL)) 5887 { 5888 if (gfc_dep_difference (ar->as->lower[i], ar->as->upper[i], &arr_size)) 5889 { 5890 /* a(2:4,2:) is known to be non-contiguous, but 5891 a(2:4,i:i) can be contiguous. */ 5892 if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0) 5893 { 5894 mpz_clear (arr_size); 5895 mpz_clear (ref_size); 5896 return true; 5897 } 5898 else if (mpz_cmp (arr_size, ref_size) != 0) 5899 previous_incomplete = true; 5900 5901 mpz_clear (arr_size); 5902 } 5903 5904 /* Check for a(::2), i.e. where the stride is not unity. 5905 This is only done if there is more than one element in 5906 the reference along this dimension. */ 5907 5908 if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION 5909 && ar->dimen_type[i] == DIMEN_RANGE 5910 && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT 5911 && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0) 5912 return true; 5913 5914 mpz_clear (ref_size); 5915 } 5916 } 5917 /* We didn't find anything definitive. */ 5918 return false; 5919 } 5920 5921 /* Build call to an intrinsic procedure. The number of arguments has to be 5922 passed (rather than ending the list with a NULL value) because we may 5923 want to add arguments but with a NULL-expression. */ 5924 5925 gfc_expr* 5926 gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, 5927 locus where, unsigned numarg, ...) 5928 { 5929 gfc_expr* result; 5930 gfc_actual_arglist* atail; 5931 gfc_intrinsic_sym* isym; 5932 va_list ap; 5933 unsigned i; 5934 const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name); 5935 5936 isym = gfc_intrinsic_function_by_id (id); 5937 gcc_assert (isym); 5938 5939 result = gfc_get_expr (); 5940 result->expr_type = EXPR_FUNCTION; 5941 result->ts = isym->ts; 5942 result->where = where; 5943 result->value.function.name = mangled_name; 5944 result->value.function.isym = isym; 5945 5946 gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); 5947 gfc_commit_symbol (result->symtree->n.sym); 5948 gcc_assert (result->symtree 5949 && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE 5950 || result->symtree->n.sym->attr.flavor == FL_UNKNOWN)); 5951 result->symtree->n.sym->intmod_sym_id = id; 5952 result->symtree->n.sym->attr.flavor = FL_PROCEDURE; 5953 result->symtree->n.sym->attr.intrinsic = 1; 5954 result->symtree->n.sym->attr.artificial = 1; 5955 5956 va_start (ap, numarg); 5957 atail = NULL; 5958 for (i = 0; i < numarg; ++i) 5959 { 5960 if (atail) 5961 { 5962 atail->next = gfc_get_actual_arglist (); 5963 atail = atail->next; 5964 } 5965 else 5966 atail = result->value.function.actual = gfc_get_actual_arglist (); 5967 5968 atail->expr = va_arg (ap, gfc_expr*); 5969 } 5970 va_end (ap); 5971 5972 return result; 5973 } 5974 5975 5976 /* Check if an expression may appear in a variable definition context 5977 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). 5978 This is called from the various places when resolving 5979 the pieces that make up such a context. 5980 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do 5981 variables), some checks are not performed. 5982 5983 Optionally, a possible error message can be suppressed if context is NULL 5984 and just the return status (true / false) be requested. */ 5985 5986 bool 5987 gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, 5988 bool own_scope, const char* context) 5989 { 5990 gfc_symbol* sym = NULL; 5991 bool is_pointer; 5992 bool check_intentin; 5993 bool ptr_component; 5994 symbol_attribute attr; 5995 gfc_ref* ref; 5996 int i; 5997 5998 if (e->expr_type == EXPR_VARIABLE) 5999 { 6000 gcc_assert (e->symtree); 6001 sym = e->symtree->n.sym; 6002 } 6003 else if (e->expr_type == EXPR_FUNCTION) 6004 { 6005 gcc_assert (e->symtree); 6006 sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; 6007 } 6008 6009 attr = gfc_expr_attr (e); 6010 if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) 6011 { 6012 if (!(gfc_option.allow_std & GFC_STD_F2008)) 6013 { 6014 if (context) 6015 gfc_error ("Fortran 2008: Pointer functions in variable definition" 6016 " context (%s) at %L", context, &e->where); 6017 return false; 6018 } 6019 } 6020 else if (e->expr_type != EXPR_VARIABLE) 6021 { 6022 if (context) 6023 gfc_error ("Non-variable expression in variable definition context (%s)" 6024 " at %L", context, &e->where); 6025 return false; 6026 } 6027 6028 if (!pointer && sym->attr.flavor == FL_PARAMETER) 6029 { 6030 if (context) 6031 gfc_error ("Named constant %qs in variable definition context (%s)" 6032 " at %L", sym->name, context, &e->where); 6033 return false; 6034 } 6035 if (!pointer && sym->attr.flavor != FL_VARIABLE 6036 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) 6037 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) 6038 { 6039 if (context) 6040 gfc_error ("%qs in variable definition context (%s) at %L is not" 6041 " a variable", sym->name, context, &e->where); 6042 return false; 6043 } 6044 6045 /* Find out whether the expr is a pointer; this also means following 6046 component references to the last one. */ 6047 is_pointer = (attr.pointer || attr.proc_pointer); 6048 if (pointer && !is_pointer) 6049 { 6050 if (context) 6051 gfc_error ("Non-POINTER in pointer association context (%s)" 6052 " at %L", context, &e->where); 6053 return false; 6054 } 6055 6056 if (e->ts.type == BT_DERIVED 6057 && e->ts.u.derived == NULL) 6058 { 6059 if (context) 6060 gfc_error ("Type inaccessible in variable definition context (%s) " 6061 "at %L", context, &e->where); 6062 return false; 6063 } 6064 6065 /* F2008, C1303. */ 6066 if (!alloc_obj 6067 && (attr.lock_comp 6068 || (e->ts.type == BT_DERIVED 6069 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 6070 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) 6071 { 6072 if (context) 6073 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", 6074 context, &e->where); 6075 return false; 6076 } 6077 6078 /* TS18508, C702/C203. */ 6079 if (!alloc_obj 6080 && (attr.lock_comp 6081 || (e->ts.type == BT_DERIVED 6082 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 6083 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) 6084 { 6085 if (context) 6086 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L", 6087 context, &e->where); 6088 return false; 6089 } 6090 6091 /* INTENT(IN) dummy argument. Check this, unless the object itself is the 6092 component of sub-component of a pointer; we need to distinguish 6093 assignment to a pointer component from pointer-assignment to a pointer 6094 component. Note that (normal) assignment to procedure pointers is not 6095 possible. */ 6096 check_intentin = !own_scope; 6097 ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived 6098 && CLASS_DATA (sym)) 6099 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; 6100 for (ref = e->ref; ref && check_intentin; ref = ref->next) 6101 { 6102 if (ptr_component && ref->type == REF_COMPONENT) 6103 check_intentin = false; 6104 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) 6105 { 6106 ptr_component = true; 6107 if (!pointer) 6108 check_intentin = false; 6109 } 6110 } 6111 6112 if (check_intentin 6113 && (sym->attr.intent == INTENT_IN 6114 || (sym->attr.select_type_temporary && sym->assoc 6115 && sym->assoc->target && sym->assoc->target->symtree 6116 && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN))) 6117 { 6118 if (pointer && is_pointer) 6119 { 6120 if (context) 6121 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" 6122 " association context (%s) at %L", 6123 sym->name, context, &e->where); 6124 return false; 6125 } 6126 if (!pointer && !is_pointer && !sym->attr.pointer) 6127 { 6128 const char *name = sym->attr.select_type_temporary 6129 ? sym->assoc->target->symtree->name : sym->name; 6130 if (context) 6131 gfc_error ("Dummy argument %qs with INTENT(IN) in variable" 6132 " definition context (%s) at %L", 6133 name, context, &e->where); 6134 return false; 6135 } 6136 } 6137 6138 /* PROTECTED and use-associated. */ 6139 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) 6140 { 6141 if (pointer && is_pointer) 6142 { 6143 if (context) 6144 gfc_error ("Variable %qs is PROTECTED and cannot appear in a" 6145 " pointer association context (%s) at %L", 6146 sym->name, context, &e->where); 6147 return false; 6148 } 6149 if (!pointer && !is_pointer) 6150 { 6151 if (context) 6152 gfc_error ("Variable %qs is PROTECTED and cannot appear in a" 6153 " variable definition context (%s) at %L", 6154 sym->name, context, &e->where); 6155 return false; 6156 } 6157 } 6158 6159 /* Variable not assignable from a PURE procedure but appears in 6160 variable definition context. */ 6161 if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) 6162 { 6163 if (context) 6164 gfc_error ("Variable %qs cannot appear in a variable definition" 6165 " context (%s) at %L in PURE procedure", 6166 sym->name, context, &e->where); 6167 return false; 6168 } 6169 6170 if (!pointer && context && gfc_implicit_pure (NULL) 6171 && gfc_impure_variable (sym)) 6172 { 6173 gfc_namespace *ns; 6174 gfc_symbol *sym; 6175 6176 for (ns = gfc_current_ns; ns; ns = ns->parent) 6177 { 6178 sym = ns->proc_name; 6179 if (sym == NULL) 6180 break; 6181 if (sym->attr.flavor == FL_PROCEDURE) 6182 { 6183 sym->attr.implicit_pure = 0; 6184 break; 6185 } 6186 } 6187 } 6188 /* Check variable definition context for associate-names. */ 6189 if (!pointer && sym->assoc) 6190 { 6191 const char* name; 6192 gfc_association_list* assoc; 6193 6194 gcc_assert (sym->assoc->target); 6195 6196 /* If this is a SELECT TYPE temporary (the association is used internally 6197 for SELECT TYPE), silently go over to the target. */ 6198 if (sym->attr.select_type_temporary) 6199 { 6200 gfc_expr* t = sym->assoc->target; 6201 6202 gcc_assert (t->expr_type == EXPR_VARIABLE); 6203 name = t->symtree->name; 6204 6205 if (t->symtree->n.sym->assoc) 6206 assoc = t->symtree->n.sym->assoc; 6207 else 6208 assoc = sym->assoc; 6209 } 6210 else 6211 { 6212 name = sym->name; 6213 assoc = sym->assoc; 6214 } 6215 gcc_assert (name && assoc); 6216 6217 /* Is association to a valid variable? */ 6218 if (!assoc->variable) 6219 { 6220 if (context) 6221 { 6222 if (assoc->target->expr_type == EXPR_VARIABLE) 6223 gfc_error ("%qs at %L associated to vector-indexed target" 6224 " cannot be used in a variable definition" 6225 " context (%s)", 6226 name, &e->where, context); 6227 else 6228 gfc_error ("%qs at %L associated to expression" 6229 " cannot be used in a variable definition" 6230 " context (%s)", 6231 name, &e->where, context); 6232 } 6233 return false; 6234 } 6235 6236 /* Target must be allowed to appear in a variable definition context. */ 6237 if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) 6238 { 6239 if (context) 6240 gfc_error ("Associate-name %qs cannot appear in a variable" 6241 " definition context (%s) at %L because its target" 6242 " at %L cannot, either", 6243 name, context, &e->where, 6244 &assoc->target->where); 6245 return false; 6246 } 6247 } 6248 6249 /* Check for same value in vector expression subscript. */ 6250 6251 if (e->rank > 0) 6252 for (ref = e->ref; ref != NULL; ref = ref->next) 6253 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 6254 for (i = 0; i < GFC_MAX_DIMENSIONS 6255 && ref->u.ar.dimen_type[i] != 0; i++) 6256 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 6257 { 6258 gfc_expr *arr = ref->u.ar.start[i]; 6259 if (arr->expr_type == EXPR_ARRAY) 6260 { 6261 gfc_constructor *c, *n; 6262 gfc_expr *ec, *en; 6263 6264 for (c = gfc_constructor_first (arr->value.constructor); 6265 c != NULL; c = gfc_constructor_next (c)) 6266 { 6267 if (c == NULL || c->iterator != NULL) 6268 continue; 6269 6270 ec = c->expr; 6271 6272 for (n = gfc_constructor_next (c); n != NULL; 6273 n = gfc_constructor_next (n)) 6274 { 6275 if (n->iterator != NULL) 6276 continue; 6277 6278 en = n->expr; 6279 if (gfc_dep_compare_expr (ec, en) == 0) 6280 { 6281 if (context) 6282 gfc_error_now ("Elements with the same value " 6283 "at %L and %L in vector " 6284 "subscript in a variable " 6285 "definition context (%s)", 6286 &(ec->where), &(en->where), 6287 context); 6288 return false; 6289 } 6290 } 6291 } 6292 } 6293 } 6294 6295 return true; 6296 } 6297