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