1/* Routines for manipulation of expression nodes. 2 Copyright (C) 2000-2015 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21#include "config.h" 22#include "system.h" 23#include "coretypes.h" 24#include "flags.h" 25#include "gfortran.h" 26#include "arith.h" 27#include "match.h" 28#include "target-memory.h" /* for gfc_convert_boz */ 29#include "constructor.h" 30 31 32/* The following set of functions provide access to gfc_expr* of 33 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. 34 35 There are two functions available elsewhere that provide 36 slightly different flavours of variables. Namely: 37 expr.c (gfc_get_variable_expr) 38 symbol.c (gfc_lval_expr_from_sym) 39 TODO: Merge these functions, if possible. */ 40 41/* Get a new expression node. */ 42 43gfc_expr * 44gfc_get_expr (void) 45{ 46 gfc_expr *e; 47 48 e = XCNEW (gfc_expr); 49 gfc_clear_ts (&e->ts); 50 e->shape = NULL; 51 e->ref = NULL; 52 e->symtree = NULL; 53 return e; 54} 55 56 57/* Get a new expression node that is an array constructor 58 of given type and kind. */ 59 60gfc_expr * 61gfc_get_array_expr (bt type, int kind, locus *where) 62{ 63 gfc_expr *e; 64 65 e = gfc_get_expr (); 66 e->expr_type = EXPR_ARRAY; 67 e->value.constructor = NULL; 68 e->rank = 1; 69 e->shape = NULL; 70 71 e->ts.type = type; 72 e->ts.kind = kind; 73 if (where) 74 e->where = *where; 75 76 return e; 77} 78 79 80/* Get a new expression node that is the NULL expression. */ 81 82gfc_expr * 83gfc_get_null_expr (locus *where) 84{ 85 gfc_expr *e; 86 87 e = gfc_get_expr (); 88 e->expr_type = EXPR_NULL; 89 e->ts.type = BT_UNKNOWN; 90 91 if (where) 92 e->where = *where; 93 94 return e; 95} 96 97 98/* Get a new expression node that is an operator expression node. */ 99 100gfc_expr * 101gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, 102 gfc_expr *op1, gfc_expr *op2) 103{ 104 gfc_expr *e; 105 106 e = gfc_get_expr (); 107 e->expr_type = EXPR_OP; 108 e->value.op.op = op; 109 e->value.op.op1 = op1; 110 e->value.op.op2 = op2; 111 112 if (where) 113 e->where = *where; 114 115 return e; 116} 117 118 119/* Get a new expression node that is an structure constructor 120 of given type and kind. */ 121 122gfc_expr * 123gfc_get_structure_constructor_expr (bt type, int kind, locus *where) 124{ 125 gfc_expr *e; 126 127 e = gfc_get_expr (); 128 e->expr_type = EXPR_STRUCTURE; 129 e->value.constructor = NULL; 130 131 e->ts.type = type; 132 e->ts.kind = kind; 133 if (where) 134 e->where = *where; 135 136 return e; 137} 138 139 140/* Get a new expression node that is an constant of given type and kind. */ 141 142gfc_expr * 143gfc_get_constant_expr (bt type, int kind, locus *where) 144{ 145 gfc_expr *e; 146 147 if (!where) 148 gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be " 149 "NULL"); 150 151 e = gfc_get_expr (); 152 153 e->expr_type = EXPR_CONSTANT; 154 e->ts.type = type; 155 e->ts.kind = kind; 156 e->where = *where; 157 158 switch (type) 159 { 160 case BT_INTEGER: 161 mpz_init (e->value.integer); 162 break; 163 164 case BT_REAL: 165 gfc_set_model_kind (kind); 166 mpfr_init (e->value.real); 167 break; 168 169 case BT_COMPLEX: 170 gfc_set_model_kind (kind); 171 mpc_init2 (e->value.complex, mpfr_get_default_prec()); 172 break; 173 174 default: 175 break; 176 } 177 178 return e; 179} 180 181 182/* Get a new expression node that is an string constant. 183 If no string is passed, a string of len is allocated, 184 blanked and null-terminated. */ 185 186gfc_expr * 187gfc_get_character_expr (int kind, locus *where, const char *src, int len) 188{ 189 gfc_expr *e; 190 gfc_char_t *dest; 191 192 if (!src) 193 { 194 dest = gfc_get_wide_string (len + 1); 195 gfc_wide_memset (dest, ' ', len); 196 dest[len] = '\0'; 197 } 198 else 199 dest = gfc_char_to_widechar (src); 200 201 e = gfc_get_constant_expr (BT_CHARACTER, kind, 202 where ? where : &gfc_current_locus); 203 e->value.character.string = dest; 204 e->value.character.length = len; 205 206 return e; 207} 208 209 210/* Get a new expression node that is an integer constant. */ 211 212gfc_expr * 213gfc_get_int_expr (int kind, locus *where, int value) 214{ 215 gfc_expr *p; 216 p = gfc_get_constant_expr (BT_INTEGER, kind, 217 where ? where : &gfc_current_locus); 218 219 mpz_set_si (p->value.integer, value); 220 221 return p; 222} 223 224 225/* Get a new expression node that is a logical constant. */ 226 227gfc_expr * 228gfc_get_logical_expr (int kind, locus *where, bool value) 229{ 230 gfc_expr *p; 231 p = gfc_get_constant_expr (BT_LOGICAL, kind, 232 where ? where : &gfc_current_locus); 233 234 p->value.logical = value; 235 236 return p; 237} 238 239 240gfc_expr * 241gfc_get_iokind_expr (locus *where, io_kind k) 242{ 243 gfc_expr *e; 244 245 /* Set the types to something compatible with iokind. This is needed to 246 get through gfc_free_expr later since iokind really has no Basic Type, 247 BT, of its own. */ 248 249 e = gfc_get_expr (); 250 e->expr_type = EXPR_CONSTANT; 251 e->ts.type = BT_LOGICAL; 252 e->value.iokind = k; 253 e->where = *where; 254 255 return e; 256} 257 258 259/* Given an expression pointer, return a copy of the expression. This 260 subroutine is recursive. */ 261 262gfc_expr * 263gfc_copy_expr (gfc_expr *p) 264{ 265 gfc_expr *q; 266 gfc_char_t *s; 267 char *c; 268 269 if (p == NULL) 270 return NULL; 271 272 q = gfc_get_expr (); 273 *q = *p; 274 275 switch (q->expr_type) 276 { 277 case EXPR_SUBSTRING: 278 s = gfc_get_wide_string (p->value.character.length + 1); 279 q->value.character.string = s; 280 memcpy (s, p->value.character.string, 281 (p->value.character.length + 1) * sizeof (gfc_char_t)); 282 break; 283 284 case EXPR_CONSTANT: 285 /* Copy target representation, if it exists. */ 286 if (p->representation.string) 287 { 288 c = XCNEWVEC (char, p->representation.length + 1); 289 q->representation.string = c; 290 memcpy (c, p->representation.string, (p->representation.length + 1)); 291 } 292 293 /* Copy the values of any pointer components of p->value. */ 294 switch (q->ts.type) 295 { 296 case BT_INTEGER: 297 mpz_init_set (q->value.integer, p->value.integer); 298 break; 299 300 case BT_REAL: 301 gfc_set_model_kind (q->ts.kind); 302 mpfr_init (q->value.real); 303 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); 304 break; 305 306 case BT_COMPLEX: 307 gfc_set_model_kind (q->ts.kind); 308 mpc_init2 (q->value.complex, mpfr_get_default_prec()); 309 mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); 310 break; 311 312 case BT_CHARACTER: 313 if (p->representation.string) 314 q->value.character.string 315 = gfc_char_to_widechar (q->representation.string); 316 else 317 { 318 s = gfc_get_wide_string (p->value.character.length + 1); 319 q->value.character.string = s; 320 321 /* This is the case for the C_NULL_CHAR named constant. */ 322 if (p->value.character.length == 0 323 && (p->ts.is_c_interop || p->ts.is_iso_c)) 324 { 325 *s = '\0'; 326 /* Need to set the length to 1 to make sure the NUL 327 terminator is copied. */ 328 q->value.character.length = 1; 329 } 330 else 331 memcpy (s, p->value.character.string, 332 (p->value.character.length + 1) * sizeof (gfc_char_t)); 333 } 334 break; 335 336 case BT_HOLLERITH: 337 case BT_LOGICAL: 338 case BT_DERIVED: 339 case BT_CLASS: 340 case BT_ASSUMED: 341 break; /* Already done. */ 342 343 case BT_PROCEDURE: 344 case BT_VOID: 345 /* Should never be reached. */ 346 case BT_UNKNOWN: 347 gfc_internal_error ("gfc_copy_expr(): Bad expr node"); 348 /* Not reached. */ 349 } 350 351 break; 352 353 case EXPR_OP: 354 switch (q->value.op.op) 355 { 356 case INTRINSIC_NOT: 357 case INTRINSIC_PARENTHESES: 358 case INTRINSIC_UPLUS: 359 case INTRINSIC_UMINUS: 360 q->value.op.op1 = gfc_copy_expr (p->value.op.op1); 361 break; 362 363 default: /* Binary operators. */ 364 q->value.op.op1 = gfc_copy_expr (p->value.op.op1); 365 q->value.op.op2 = gfc_copy_expr (p->value.op.op2); 366 break; 367 } 368 369 break; 370 371 case EXPR_FUNCTION: 372 q->value.function.actual = 373 gfc_copy_actual_arglist (p->value.function.actual); 374 break; 375 376 case EXPR_COMPCALL: 377 case EXPR_PPC: 378 q->value.compcall.actual = 379 gfc_copy_actual_arglist (p->value.compcall.actual); 380 q->value.compcall.tbp = p->value.compcall.tbp; 381 break; 382 383 case EXPR_STRUCTURE: 384 case EXPR_ARRAY: 385 q->value.constructor = gfc_constructor_copy (p->value.constructor); 386 break; 387 388 case EXPR_VARIABLE: 389 case EXPR_NULL: 390 break; 391 } 392 393 q->shape = gfc_copy_shape (p->shape, p->rank); 394 395 q->ref = gfc_copy_ref (p->ref); 396 397 return q; 398} 399 400 401void 402gfc_clear_shape (mpz_t *shape, int rank) 403{ 404 int i; 405 406 for (i = 0; i < rank; i++) 407 mpz_clear (shape[i]); 408} 409 410 411void 412gfc_free_shape (mpz_t **shape, int rank) 413{ 414 if (*shape == NULL) 415 return; 416 417 gfc_clear_shape (*shape, rank); 418 free (*shape); 419 *shape = NULL; 420} 421 422 423/* Workhorse function for gfc_free_expr() that frees everything 424 beneath an expression node, but not the node itself. This is 425 useful when we want to simplify a node and replace it with 426 something else or the expression node belongs to another structure. */ 427 428static void 429free_expr0 (gfc_expr *e) 430{ 431 switch (e->expr_type) 432 { 433 case EXPR_CONSTANT: 434 /* Free any parts of the value that need freeing. */ 435 switch (e->ts.type) 436 { 437 case BT_INTEGER: 438 mpz_clear (e->value.integer); 439 break; 440 441 case BT_REAL: 442 mpfr_clear (e->value.real); 443 break; 444 445 case BT_CHARACTER: 446 free (e->value.character.string); 447 break; 448 449 case BT_COMPLEX: 450 mpc_clear (e->value.complex); 451 break; 452 453 default: 454 break; 455 } 456 457 /* Free the representation. */ 458 free (e->representation.string); 459 460 break; 461 462 case EXPR_OP: 463 if (e->value.op.op1 != NULL) 464 gfc_free_expr (e->value.op.op1); 465 if (e->value.op.op2 != NULL) 466 gfc_free_expr (e->value.op.op2); 467 break; 468 469 case EXPR_FUNCTION: 470 gfc_free_actual_arglist (e->value.function.actual); 471 break; 472 473 case EXPR_COMPCALL: 474 case EXPR_PPC: 475 gfc_free_actual_arglist (e->value.compcall.actual); 476 break; 477 478 case EXPR_VARIABLE: 479 break; 480 481 case EXPR_ARRAY: 482 case EXPR_STRUCTURE: 483 gfc_constructor_free (e->value.constructor); 484 break; 485 486 case EXPR_SUBSTRING: 487 free (e->value.character.string); 488 break; 489 490 case EXPR_NULL: 491 break; 492 493 default: 494 gfc_internal_error ("free_expr0(): Bad expr type"); 495 } 496 497 /* Free a shape array. */ 498 gfc_free_shape (&e->shape, e->rank); 499 500 gfc_free_ref_list (e->ref); 501 502 memset (e, '\0', sizeof (gfc_expr)); 503} 504 505 506/* Free an expression node and everything beneath it. */ 507 508void 509gfc_free_expr (gfc_expr *e) 510{ 511 if (e == NULL) 512 return; 513 free_expr0 (e); 514 free (e); 515} 516 517 518/* Free an argument list and everything below it. */ 519 520void 521gfc_free_actual_arglist (gfc_actual_arglist *a1) 522{ 523 gfc_actual_arglist *a2; 524 525 while (a1) 526 { 527 a2 = a1->next; 528 gfc_free_expr (a1->expr); 529 free (a1); 530 a1 = a2; 531 } 532} 533 534 535/* Copy an arglist structure and all of the arguments. */ 536 537gfc_actual_arglist * 538gfc_copy_actual_arglist (gfc_actual_arglist *p) 539{ 540 gfc_actual_arglist *head, *tail, *new_arg; 541 542 head = tail = NULL; 543 544 for (; p; p = p->next) 545 { 546 new_arg = gfc_get_actual_arglist (); 547 *new_arg = *p; 548 549 new_arg->expr = gfc_copy_expr (p->expr); 550 new_arg->next = NULL; 551 552 if (head == NULL) 553 head = new_arg; 554 else 555 tail->next = new_arg; 556 557 tail = new_arg; 558 } 559 560 return head; 561} 562 563 564/* Free a list of reference structures. */ 565 566void 567gfc_free_ref_list (gfc_ref *p) 568{ 569 gfc_ref *q; 570 int i; 571 572 for (; p; p = q) 573 { 574 q = p->next; 575 576 switch (p->type) 577 { 578 case REF_ARRAY: 579 for (i = 0; i < GFC_MAX_DIMENSIONS; i++) 580 { 581 gfc_free_expr (p->u.ar.start[i]); 582 gfc_free_expr (p->u.ar.end[i]); 583 gfc_free_expr (p->u.ar.stride[i]); 584 } 585 586 break; 587 588 case REF_SUBSTRING: 589 gfc_free_expr (p->u.ss.start); 590 gfc_free_expr (p->u.ss.end); 591 break; 592 593 case REF_COMPONENT: 594 break; 595 } 596 597 free (p); 598 } 599} 600 601 602/* Graft the *src expression onto the *dest subexpression. */ 603 604void 605gfc_replace_expr (gfc_expr *dest, gfc_expr *src) 606{ 607 free_expr0 (dest); 608 *dest = *src; 609 free (src); 610} 611 612 613/* Try to extract an integer constant from the passed expression node. 614 Returns an error message or NULL if the result is set. It is 615 tempting to generate an error and return true or false, but 616 failure is OK for some callers. */ 617 618const char * 619gfc_extract_int (gfc_expr *expr, int *result) 620{ 621 if (expr->expr_type != EXPR_CONSTANT) 622 return _("Constant expression required at %C"); 623 624 if (expr->ts.type != BT_INTEGER) 625 return _("Integer expression required at %C"); 626 627 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) 628 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) 629 { 630 return _("Integer value too large in expression at %C"); 631 } 632 633 *result = (int) mpz_get_si (expr->value.integer); 634 635 return NULL; 636} 637 638 639/* Recursively copy a list of reference structures. */ 640 641gfc_ref * 642gfc_copy_ref (gfc_ref *src) 643{ 644 gfc_array_ref *ar; 645 gfc_ref *dest; 646 647 if (src == NULL) 648 return NULL; 649 650 dest = gfc_get_ref (); 651 dest->type = src->type; 652 653 switch (src->type) 654 { 655 case REF_ARRAY: 656 ar = gfc_copy_array_ref (&src->u.ar); 657 dest->u.ar = *ar; 658 free (ar); 659 break; 660 661 case REF_COMPONENT: 662 dest->u.c = src->u.c; 663 break; 664 665 case REF_SUBSTRING: 666 dest->u.ss = src->u.ss; 667 dest->u.ss.start = gfc_copy_expr (src->u.ss.start); 668 dest->u.ss.end = gfc_copy_expr (src->u.ss.end); 669 break; 670 } 671 672 dest->next = gfc_copy_ref (src->next); 673 674 return dest; 675} 676 677 678/* Detect whether an expression has any vector index array references. */ 679 680int 681gfc_has_vector_index (gfc_expr *e) 682{ 683 gfc_ref *ref; 684 int i; 685 for (ref = e->ref; ref; ref = ref->next) 686 if (ref->type == REF_ARRAY) 687 for (i = 0; i < ref->u.ar.dimen; i++) 688 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 689 return 1; 690 return 0; 691} 692 693 694/* Copy a shape array. */ 695 696mpz_t * 697gfc_copy_shape (mpz_t *shape, int rank) 698{ 699 mpz_t *new_shape; 700 int n; 701 702 if (shape == NULL) 703 return NULL; 704 705 new_shape = gfc_get_shape (rank); 706 707 for (n = 0; n < rank; n++) 708 mpz_init_set (new_shape[n], shape[n]); 709 710 return new_shape; 711} 712 713 714/* Copy a shape array excluding dimension N, where N is an integer 715 constant expression. Dimensions are numbered in Fortran style -- 716 starting with ONE. 717 718 So, if the original shape array contains R elements 719 { s1 ... sN-1 sN sN+1 ... sR-1 sR} 720 the result contains R-1 elements: 721 { s1 ... sN-1 sN+1 ... sR-1} 722 723 If anything goes wrong -- N is not a constant, its value is out 724 of range -- or anything else, just returns NULL. */ 725 726mpz_t * 727gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) 728{ 729 mpz_t *new_shape, *s; 730 int i, n; 731 732 if (shape == NULL 733 || rank <= 1 734 || dim == NULL 735 || dim->expr_type != EXPR_CONSTANT 736 || dim->ts.type != BT_INTEGER) 737 return NULL; 738 739 n = mpz_get_si (dim->value.integer); 740 n--; /* Convert to zero based index. */ 741 if (n < 0 || n >= rank) 742 return NULL; 743 744 s = new_shape = gfc_get_shape (rank - 1); 745 746 for (i = 0; i < rank; i++) 747 { 748 if (i == n) 749 continue; 750 mpz_init_set (*s, shape[i]); 751 s++; 752 } 753 754 return new_shape; 755} 756 757 758/* Return the maximum kind of two expressions. In general, higher 759 kind numbers mean more precision for numeric types. */ 760 761int 762gfc_kind_max (gfc_expr *e1, gfc_expr *e2) 763{ 764 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; 765} 766 767 768/* Returns nonzero if the type is numeric, zero otherwise. */ 769 770static int 771numeric_type (bt type) 772{ 773 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; 774} 775 776 777/* Returns nonzero if the typespec is a numeric type, zero otherwise. */ 778 779int 780gfc_numeric_ts (gfc_typespec *ts) 781{ 782 return numeric_type (ts->type); 783} 784 785 786/* Return an expression node with an optional argument list attached. 787 A variable number of gfc_expr pointers are strung together in an 788 argument list with a NULL pointer terminating the list. */ 789 790gfc_expr * 791gfc_build_conversion (gfc_expr *e) 792{ 793 gfc_expr *p; 794 795 p = gfc_get_expr (); 796 p->expr_type = EXPR_FUNCTION; 797 p->symtree = NULL; 798 p->value.function.actual = NULL; 799 800 p->value.function.actual = gfc_get_actual_arglist (); 801 p->value.function.actual->expr = e; 802 803 return p; 804} 805 806 807/* Given an expression node with some sort of numeric binary 808 expression, insert type conversions required to make the operands 809 have the same type. Conversion warnings are disabled if wconversion 810 is set to 0. 811 812 The exception is that the operands of an exponential don't have to 813 have the same type. If possible, the base is promoted to the type 814 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but 815 1.0**2 stays as it is. */ 816 817void 818gfc_type_convert_binary (gfc_expr *e, int wconversion) 819{ 820 gfc_expr *op1, *op2; 821 822 op1 = e->value.op.op1; 823 op2 = e->value.op.op2; 824 825 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) 826 { 827 gfc_clear_ts (&e->ts); 828 return; 829 } 830 831 /* Kind conversions of same type. */ 832 if (op1->ts.type == op2->ts.type) 833 { 834 if (op1->ts.kind == op2->ts.kind) 835 { 836 /* No type conversions. */ 837 e->ts = op1->ts; 838 goto done; 839 } 840 841 if (op1->ts.kind > op2->ts.kind) 842 gfc_convert_type_warn (op2, &op1->ts, 2, wconversion); 843 else 844 gfc_convert_type_warn (op1, &op2->ts, 2, wconversion); 845 846 e->ts = op1->ts; 847 goto done; 848 } 849 850 /* Integer combined with real or complex. */ 851 if (op2->ts.type == BT_INTEGER) 852 { 853 e->ts = op1->ts; 854 855 /* Special case for ** operator. */ 856 if (e->value.op.op == INTRINSIC_POWER) 857 goto done; 858 859 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); 860 goto done; 861 } 862 863 if (op1->ts.type == BT_INTEGER) 864 { 865 e->ts = op2->ts; 866 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); 867 goto done; 868 } 869 870 /* Real combined with complex. */ 871 e->ts.type = BT_COMPLEX; 872 if (op1->ts.kind > op2->ts.kind) 873 e->ts.kind = op1->ts.kind; 874 else 875 e->ts.kind = op2->ts.kind; 876 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) 877 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); 878 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) 879 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); 880 881done: 882 return; 883} 884 885 886/* Function to determine if an expression is constant or not. This 887 function expects that the expression has already been simplified. */ 888 889int 890gfc_is_constant_expr (gfc_expr *e) 891{ 892 gfc_constructor *c; 893 gfc_actual_arglist *arg; 894 gfc_symbol *sym; 895 896 if (e == NULL) 897 return 1; 898 899 switch (e->expr_type) 900 { 901 case EXPR_OP: 902 return (gfc_is_constant_expr (e->value.op.op1) 903 && (e->value.op.op2 == NULL 904 || gfc_is_constant_expr (e->value.op.op2))); 905 906 case EXPR_VARIABLE: 907 return 0; 908 909 case EXPR_FUNCTION: 910 case EXPR_PPC: 911 case EXPR_COMPCALL: 912 gcc_assert (e->symtree || e->value.function.esym 913 || e->value.function.isym); 914 915 /* Call to intrinsic with at least one argument. */ 916 if (e->value.function.isym && e->value.function.actual) 917 { 918 for (arg = e->value.function.actual; arg; arg = arg->next) 919 if (!gfc_is_constant_expr (arg->expr)) 920 return 0; 921 } 922 923 /* Specification functions are constant. */ 924 /* F95, 7.1.6.2; F2003, 7.1.7 */ 925 sym = NULL; 926 if (e->symtree) 927 sym = e->symtree->n.sym; 928 if (e->value.function.esym) 929 sym = e->value.function.esym; 930 931 if (sym 932 && sym->attr.function 933 && sym->attr.pure 934 && !sym->attr.intrinsic 935 && !sym->attr.recursive 936 && sym->attr.proc != PROC_INTERNAL 937 && sym->attr.proc != PROC_ST_FUNCTION 938 && sym->attr.proc != PROC_UNKNOWN 939 && gfc_sym_get_dummy_args (sym) == NULL) 940 return 1; 941 942 if (e->value.function.isym 943 && (e->value.function.isym->elemental 944 || e->value.function.isym->pure 945 || e->value.function.isym->inquiry 946 || e->value.function.isym->transformational)) 947 return 1; 948 949 return 0; 950 951 case EXPR_CONSTANT: 952 case EXPR_NULL: 953 return 1; 954 955 case EXPR_SUBSTRING: 956 return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) 957 && gfc_is_constant_expr (e->ref->u.ss.end)); 958 959 case EXPR_ARRAY: 960 case EXPR_STRUCTURE: 961 c = gfc_constructor_first (e->value.constructor); 962 if ((e->expr_type == EXPR_ARRAY) && c && c->iterator) 963 return gfc_constant_ac (e); 964 965 for (; c; c = gfc_constructor_next (c)) 966 if (!gfc_is_constant_expr (c->expr)) 967 return 0; 968 969 return 1; 970 971 972 default: 973 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); 974 return 0; 975 } 976} 977 978 979/* Is true if an array reference is followed by a component or substring 980 reference. */ 981bool 982is_subref_array (gfc_expr * e) 983{ 984 gfc_ref * ref; 985 bool seen_array; 986 987 if (e->expr_type != EXPR_VARIABLE) 988 return false; 989 990 if (e->symtree->n.sym->attr.subref_array_pointer) 991 return true; 992 993 seen_array = false; 994 for (ref = e->ref; ref; ref = ref->next) 995 { 996 if (ref->type == REF_ARRAY 997 && ref->u.ar.type != AR_ELEMENT) 998 seen_array = true; 999 1000 if (seen_array 1001 && ref->type != REF_ARRAY) 1002 return seen_array; 1003 } 1004 return false; 1005} 1006 1007 1008/* Try to collapse intrinsic expressions. */ 1009 1010static bool 1011simplify_intrinsic_op (gfc_expr *p, int type) 1012{ 1013 gfc_intrinsic_op op; 1014 gfc_expr *op1, *op2, *result; 1015 1016 if (p->value.op.op == INTRINSIC_USER) 1017 return true; 1018 1019 op1 = p->value.op.op1; 1020 op2 = p->value.op.op2; 1021 op = p->value.op.op; 1022 1023 if (!gfc_simplify_expr (op1, type)) 1024 return false; 1025 if (!gfc_simplify_expr (op2, type)) 1026 return false; 1027 1028 if (!gfc_is_constant_expr (op1) 1029 || (op2 != NULL && !gfc_is_constant_expr (op2))) 1030 return true; 1031 1032 /* Rip p apart. */ 1033 p->value.op.op1 = NULL; 1034 p->value.op.op2 = NULL; 1035 1036 switch (op) 1037 { 1038 case INTRINSIC_PARENTHESES: 1039 result = gfc_parentheses (op1); 1040 break; 1041 1042 case INTRINSIC_UPLUS: 1043 result = gfc_uplus (op1); 1044 break; 1045 1046 case INTRINSIC_UMINUS: 1047 result = gfc_uminus (op1); 1048 break; 1049 1050 case INTRINSIC_PLUS: 1051 result = gfc_add (op1, op2); 1052 break; 1053 1054 case INTRINSIC_MINUS: 1055 result = gfc_subtract (op1, op2); 1056 break; 1057 1058 case INTRINSIC_TIMES: 1059 result = gfc_multiply (op1, op2); 1060 break; 1061 1062 case INTRINSIC_DIVIDE: 1063 result = gfc_divide (op1, op2); 1064 break; 1065 1066 case INTRINSIC_POWER: 1067 result = gfc_power (op1, op2); 1068 break; 1069 1070 case INTRINSIC_CONCAT: 1071 result = gfc_concat (op1, op2); 1072 break; 1073 1074 case INTRINSIC_EQ: 1075 case INTRINSIC_EQ_OS: 1076 result = gfc_eq (op1, op2, op); 1077 break; 1078 1079 case INTRINSIC_NE: 1080 case INTRINSIC_NE_OS: 1081 result = gfc_ne (op1, op2, op); 1082 break; 1083 1084 case INTRINSIC_GT: 1085 case INTRINSIC_GT_OS: 1086 result = gfc_gt (op1, op2, op); 1087 break; 1088 1089 case INTRINSIC_GE: 1090 case INTRINSIC_GE_OS: 1091 result = gfc_ge (op1, op2, op); 1092 break; 1093 1094 case INTRINSIC_LT: 1095 case INTRINSIC_LT_OS: 1096 result = gfc_lt (op1, op2, op); 1097 break; 1098 1099 case INTRINSIC_LE: 1100 case INTRINSIC_LE_OS: 1101 result = gfc_le (op1, op2, op); 1102 break; 1103 1104 case INTRINSIC_NOT: 1105 result = gfc_not (op1); 1106 break; 1107 1108 case INTRINSIC_AND: 1109 result = gfc_and (op1, op2); 1110 break; 1111 1112 case INTRINSIC_OR: 1113 result = gfc_or (op1, op2); 1114 break; 1115 1116 case INTRINSIC_EQV: 1117 result = gfc_eqv (op1, op2); 1118 break; 1119 1120 case INTRINSIC_NEQV: 1121 result = gfc_neqv (op1, op2); 1122 break; 1123 1124 default: 1125 gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); 1126 } 1127 1128 if (result == NULL) 1129 { 1130 gfc_free_expr (op1); 1131 gfc_free_expr (op2); 1132 return false; 1133 } 1134 1135 result->rank = p->rank; 1136 result->where = p->where; 1137 gfc_replace_expr (p, result); 1138 1139 return true; 1140} 1141 1142 1143/* Subroutine to simplify constructor expressions. Mutually recursive 1144 with gfc_simplify_expr(). */ 1145 1146static bool 1147simplify_constructor (gfc_constructor_base base, int type) 1148{ 1149 gfc_constructor *c; 1150 gfc_expr *p; 1151 1152 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 1153 { 1154 if (c->iterator 1155 && (!gfc_simplify_expr(c->iterator->start, type) 1156 || !gfc_simplify_expr (c->iterator->end, type) 1157 || !gfc_simplify_expr (c->iterator->step, type))) 1158 return false; 1159 1160 if (c->expr) 1161 { 1162 /* Try and simplify a copy. Replace the original if successful 1163 but keep going through the constructor at all costs. Not 1164 doing so can make a dog's dinner of complicated things. */ 1165 p = gfc_copy_expr (c->expr); 1166 1167 if (!gfc_simplify_expr (p, type)) 1168 { 1169 gfc_free_expr (p); 1170 continue; 1171 } 1172 1173 gfc_replace_expr (c->expr, p); 1174 } 1175 } 1176 1177 return true; 1178} 1179 1180 1181/* Pull a single array element out of an array constructor. */ 1182 1183static bool 1184find_array_element (gfc_constructor_base base, gfc_array_ref *ar, 1185 gfc_constructor **rval) 1186{ 1187 unsigned long nelemen; 1188 int i; 1189 mpz_t delta; 1190 mpz_t offset; 1191 mpz_t span; 1192 mpz_t tmp; 1193 gfc_constructor *cons; 1194 gfc_expr *e; 1195 bool t; 1196 1197 t = true; 1198 e = NULL; 1199 1200 mpz_init_set_ui (offset, 0); 1201 mpz_init (delta); 1202 mpz_init (tmp); 1203 mpz_init_set_ui (span, 1); 1204 for (i = 0; i < ar->dimen; i++) 1205 { 1206 if (!gfc_reduce_init_expr (ar->as->lower[i]) 1207 || !gfc_reduce_init_expr (ar->as->upper[i])) 1208 { 1209 t = false; 1210 cons = NULL; 1211 goto depart; 1212 } 1213 1214 e = ar->start[i]; 1215 if (e->expr_type != EXPR_CONSTANT) 1216 { 1217 cons = NULL; 1218 goto depart; 1219 } 1220 1221 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT 1222 && ar->as->lower[i]->expr_type == EXPR_CONSTANT); 1223 1224 /* Check the bounds. */ 1225 if ((ar->as->upper[i] 1226 && mpz_cmp (e->value.integer, 1227 ar->as->upper[i]->value.integer) > 0) 1228 || (mpz_cmp (e->value.integer, 1229 ar->as->lower[i]->value.integer) < 0)) 1230 { 1231 gfc_error ("Index in dimension %d is out of bounds " 1232 "at %L", i + 1, &ar->c_where[i]); 1233 cons = NULL; 1234 t = false; 1235 goto depart; 1236 } 1237 1238 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); 1239 mpz_mul (delta, delta, span); 1240 mpz_add (offset, offset, delta); 1241 1242 mpz_set_ui (tmp, 1); 1243 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer); 1244 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); 1245 mpz_mul (span, span, tmp); 1246 } 1247 1248 for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); 1249 cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) 1250 { 1251 if (cons->iterator) 1252 { 1253 cons = NULL; 1254 goto depart; 1255 } 1256 } 1257 1258depart: 1259 mpz_clear (delta); 1260 mpz_clear (offset); 1261 mpz_clear (span); 1262 mpz_clear (tmp); 1263 *rval = cons; 1264 return t; 1265} 1266 1267 1268/* Find a component of a structure constructor. */ 1269 1270static gfc_constructor * 1271find_component_ref (gfc_constructor_base base, gfc_ref *ref) 1272{ 1273 gfc_component *pick = ref->u.c.component; 1274 gfc_constructor *c = gfc_constructor_first (base); 1275 1276 gfc_symbol *dt = ref->u.c.sym; 1277 int ext = dt->attr.extension; 1278 1279 /* For extended types, check if the desired component is in one of the 1280 * parent types. */ 1281 while (ext > 0 && gfc_find_component (dt->components->ts.u.derived, 1282 pick->name, true, true)) 1283 { 1284 dt = dt->components->ts.u.derived; 1285 c = gfc_constructor_first (c->expr->value.constructor); 1286 ext--; 1287 } 1288 1289 gfc_component *comp = dt->components; 1290 while (comp != pick) 1291 { 1292 comp = comp->next; 1293 c = gfc_constructor_next (c); 1294 } 1295 1296 return c; 1297} 1298 1299 1300/* Replace an expression with the contents of a constructor, removing 1301 the subobject reference in the process. */ 1302 1303static void 1304remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) 1305{ 1306 gfc_expr *e; 1307 1308 if (cons) 1309 { 1310 e = cons->expr; 1311 cons->expr = NULL; 1312 } 1313 else 1314 e = gfc_copy_expr (p); 1315 e->ref = p->ref->next; 1316 p->ref->next = NULL; 1317 gfc_replace_expr (p, e); 1318} 1319 1320 1321/* Pull an array section out of an array constructor. */ 1322 1323static bool 1324find_array_section (gfc_expr *expr, gfc_ref *ref) 1325{ 1326 int idx; 1327 int rank; 1328 int d; 1329 int shape_i; 1330 int limit; 1331 long unsigned one = 1; 1332 bool incr_ctr; 1333 mpz_t start[GFC_MAX_DIMENSIONS]; 1334 mpz_t end[GFC_MAX_DIMENSIONS]; 1335 mpz_t stride[GFC_MAX_DIMENSIONS]; 1336 mpz_t delta[GFC_MAX_DIMENSIONS]; 1337 mpz_t ctr[GFC_MAX_DIMENSIONS]; 1338 mpz_t delta_mpz; 1339 mpz_t tmp_mpz; 1340 mpz_t nelts; 1341 mpz_t ptr; 1342 gfc_constructor_base base; 1343 gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; 1344 gfc_expr *begin; 1345 gfc_expr *finish; 1346 gfc_expr *step; 1347 gfc_expr *upper; 1348 gfc_expr *lower; 1349 bool t; 1350 1351 t = true; 1352 1353 base = expr->value.constructor; 1354 expr->value.constructor = NULL; 1355 1356 rank = ref->u.ar.as->rank; 1357 1358 if (expr->shape == NULL) 1359 expr->shape = gfc_get_shape (rank); 1360 1361 mpz_init_set_ui (delta_mpz, one); 1362 mpz_init_set_ui (nelts, one); 1363 mpz_init (tmp_mpz); 1364 1365 /* Do the initialization now, so that we can cleanup without 1366 keeping track of where we were. */ 1367 for (d = 0; d < rank; d++) 1368 { 1369 mpz_init (delta[d]); 1370 mpz_init (start[d]); 1371 mpz_init (end[d]); 1372 mpz_init (ctr[d]); 1373 mpz_init (stride[d]); 1374 vecsub[d] = NULL; 1375 } 1376 1377 /* Build the counters to clock through the array reference. */ 1378 shape_i = 0; 1379 for (d = 0; d < rank; d++) 1380 { 1381 /* Make this stretch of code easier on the eye! */ 1382 begin = ref->u.ar.start[d]; 1383 finish = ref->u.ar.end[d]; 1384 step = ref->u.ar.stride[d]; 1385 lower = ref->u.ar.as->lower[d]; 1386 upper = ref->u.ar.as->upper[d]; 1387 1388 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ 1389 { 1390 gfc_constructor *ci; 1391 gcc_assert (begin); 1392 1393 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) 1394 { 1395 t = false; 1396 goto cleanup; 1397 } 1398 1399 gcc_assert (begin->rank == 1); 1400 /* Zero-sized arrays have no shape and no elements, stop early. */ 1401 if (!begin->shape) 1402 { 1403 mpz_init_set_ui (nelts, 0); 1404 break; 1405 } 1406 1407 vecsub[d] = gfc_constructor_first (begin->value.constructor); 1408 mpz_set (ctr[d], vecsub[d]->expr->value.integer); 1409 mpz_mul (nelts, nelts, begin->shape[0]); 1410 mpz_set (expr->shape[shape_i++], begin->shape[0]); 1411 1412 /* Check bounds. */ 1413 for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) 1414 { 1415 if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 1416 || mpz_cmp (ci->expr->value.integer, 1417 lower->value.integer) < 0) 1418 { 1419 gfc_error ("index in dimension %d is out of bounds " 1420 "at %L", d + 1, &ref->u.ar.c_where[d]); 1421 t = false; 1422 goto cleanup; 1423 } 1424 } 1425 } 1426 else 1427 { 1428 if ((begin && begin->expr_type != EXPR_CONSTANT) 1429 || (finish && finish->expr_type != EXPR_CONSTANT) 1430 || (step && step->expr_type != EXPR_CONSTANT)) 1431 { 1432 t = false; 1433 goto cleanup; 1434 } 1435 1436 /* Obtain the stride. */ 1437 if (step) 1438 mpz_set (stride[d], step->value.integer); 1439 else 1440 mpz_set_ui (stride[d], one); 1441 1442 if (mpz_cmp_ui (stride[d], 0) == 0) 1443 mpz_set_ui (stride[d], one); 1444 1445 /* Obtain the start value for the index. */ 1446 if (begin) 1447 mpz_set (start[d], begin->value.integer); 1448 else 1449 mpz_set (start[d], lower->value.integer); 1450 1451 mpz_set (ctr[d], start[d]); 1452 1453 /* Obtain the end value for the index. */ 1454 if (finish) 1455 mpz_set (end[d], finish->value.integer); 1456 else 1457 mpz_set (end[d], upper->value.integer); 1458 1459 /* Separate 'if' because elements sometimes arrive with 1460 non-null end. */ 1461 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) 1462 mpz_set (end [d], begin->value.integer); 1463 1464 /* Check the bounds. */ 1465 if (mpz_cmp (ctr[d], upper->value.integer) > 0 1466 || mpz_cmp (end[d], upper->value.integer) > 0 1467 || mpz_cmp (ctr[d], lower->value.integer) < 0 1468 || mpz_cmp (end[d], lower->value.integer) < 0) 1469 { 1470 gfc_error ("index in dimension %d is out of bounds " 1471 "at %L", d + 1, &ref->u.ar.c_where[d]); 1472 t = false; 1473 goto cleanup; 1474 } 1475 1476 /* Calculate the number of elements and the shape. */ 1477 mpz_set (tmp_mpz, stride[d]); 1478 mpz_add (tmp_mpz, end[d], tmp_mpz); 1479 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); 1480 mpz_div (tmp_mpz, tmp_mpz, stride[d]); 1481 mpz_mul (nelts, nelts, tmp_mpz); 1482 1483 /* An element reference reduces the rank of the expression; don't 1484 add anything to the shape array. */ 1485 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) 1486 mpz_set (expr->shape[shape_i++], tmp_mpz); 1487 } 1488 1489 /* Calculate the 'stride' (=delta) for conversion of the 1490 counter values into the index along the constructor. */ 1491 mpz_set (delta[d], delta_mpz); 1492 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); 1493 mpz_add_ui (tmp_mpz, tmp_mpz, one); 1494 mpz_mul (delta_mpz, delta_mpz, tmp_mpz); 1495 } 1496 1497 mpz_init (ptr); 1498 cons = gfc_constructor_first (base); 1499 1500 /* Now clock through the array reference, calculating the index in 1501 the source constructor and transferring the elements to the new 1502 constructor. */ 1503 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) 1504 { 1505 mpz_init_set_ui (ptr, 0); 1506 1507 incr_ctr = true; 1508 for (d = 0; d < rank; d++) 1509 { 1510 mpz_set (tmp_mpz, ctr[d]); 1511 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer); 1512 mpz_mul (tmp_mpz, tmp_mpz, delta[d]); 1513 mpz_add (ptr, ptr, tmp_mpz); 1514 1515 if (!incr_ctr) continue; 1516 1517 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ 1518 { 1519 gcc_assert(vecsub[d]); 1520 1521 if (!gfc_constructor_next (vecsub[d])) 1522 vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); 1523 else 1524 { 1525 vecsub[d] = gfc_constructor_next (vecsub[d]); 1526 incr_ctr = false; 1527 } 1528 mpz_set (ctr[d], vecsub[d]->expr->value.integer); 1529 } 1530 else 1531 { 1532 mpz_add (ctr[d], ctr[d], stride[d]); 1533 1534 if (mpz_cmp_ui (stride[d], 0) > 0 1535 ? mpz_cmp (ctr[d], end[d]) > 0 1536 : mpz_cmp (ctr[d], end[d]) < 0) 1537 mpz_set (ctr[d], start[d]); 1538 else 1539 incr_ctr = false; 1540 } 1541 } 1542 1543 limit = mpz_get_ui (ptr); 1544 if (limit >= flag_max_array_constructor) 1545 { 1546 gfc_error ("The number of elements in the array constructor " 1547 "at %L requires an increase of the allowed %d " 1548 "upper limit. See -fmax-array-constructor " 1549 "option", &expr->where, flag_max_array_constructor); 1550 return false; 1551 } 1552 1553 cons = gfc_constructor_lookup (base, limit); 1554 gcc_assert (cons); 1555 gfc_constructor_append_expr (&expr->value.constructor, 1556 gfc_copy_expr (cons->expr), NULL); 1557 } 1558 1559 mpz_clear (ptr); 1560 1561cleanup: 1562 1563 mpz_clear (delta_mpz); 1564 mpz_clear (tmp_mpz); 1565 mpz_clear (nelts); 1566 for (d = 0; d < rank; d++) 1567 { 1568 mpz_clear (delta[d]); 1569 mpz_clear (start[d]); 1570 mpz_clear (end[d]); 1571 mpz_clear (ctr[d]); 1572 mpz_clear (stride[d]); 1573 } 1574 gfc_constructor_free (base); 1575 return t; 1576} 1577 1578/* Pull a substring out of an expression. */ 1579 1580static bool 1581find_substring_ref (gfc_expr *p, gfc_expr **newp) 1582{ 1583 int end; 1584 int start; 1585 int length; 1586 gfc_char_t *chr; 1587 1588 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT 1589 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) 1590 return false; 1591 1592 *newp = gfc_copy_expr (p); 1593 free ((*newp)->value.character.string); 1594 1595 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer); 1596 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer); 1597 length = end - start + 1; 1598 1599 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); 1600 (*newp)->value.character.length = length; 1601 memcpy (chr, &p->value.character.string[start - 1], 1602 length * sizeof (gfc_char_t)); 1603 chr[length] = '\0'; 1604 return true; 1605} 1606 1607 1608 1609/* Simplify a subobject reference of a constructor. This occurs when 1610 parameter variable values are substituted. */ 1611 1612static bool 1613simplify_const_ref (gfc_expr *p) 1614{ 1615 gfc_constructor *cons, *c; 1616 gfc_expr *newp; 1617 gfc_ref *last_ref; 1618 1619 while (p->ref) 1620 { 1621 switch (p->ref->type) 1622 { 1623 case REF_ARRAY: 1624 switch (p->ref->u.ar.type) 1625 { 1626 case AR_ELEMENT: 1627 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr 1628 will generate this. */ 1629 if (p->expr_type != EXPR_ARRAY) 1630 { 1631 remove_subobject_ref (p, NULL); 1632 break; 1633 } 1634 if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons)) 1635 return false; 1636 1637 if (!cons) 1638 return true; 1639 1640 remove_subobject_ref (p, cons); 1641 break; 1642 1643 case AR_SECTION: 1644 if (!find_array_section (p, p->ref)) 1645 return false; 1646 p->ref->u.ar.type = AR_FULL; 1647 1648 /* Fall through. */ 1649 1650 case AR_FULL: 1651 if (p->ref->next != NULL 1652 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) 1653 { 1654 for (c = gfc_constructor_first (p->value.constructor); 1655 c; c = gfc_constructor_next (c)) 1656 { 1657 c->expr->ref = gfc_copy_ref (p->ref->next); 1658 if (!simplify_const_ref (c->expr)) 1659 return false; 1660 } 1661 1662 if (p->ts.type == BT_DERIVED 1663 && p->ref->next 1664 && (c = gfc_constructor_first (p->value.constructor))) 1665 { 1666 /* There may have been component references. */ 1667 p->ts = c->expr->ts; 1668 } 1669 1670 last_ref = p->ref; 1671 for (; last_ref->next; last_ref = last_ref->next) {}; 1672 1673 if (p->ts.type == BT_CHARACTER 1674 && last_ref->type == REF_SUBSTRING) 1675 { 1676 /* If this is a CHARACTER array and we possibly took 1677 a substring out of it, update the type-spec's 1678 character length according to the first element 1679 (as all should have the same length). */ 1680 int string_len; 1681 if ((c = gfc_constructor_first (p->value.constructor))) 1682 { 1683 const gfc_expr* first = c->expr; 1684 gcc_assert (first->expr_type == EXPR_CONSTANT); 1685 gcc_assert (first->ts.type == BT_CHARACTER); 1686 string_len = first->value.character.length; 1687 } 1688 else 1689 string_len = 0; 1690 1691 if (!p->ts.u.cl) 1692 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, 1693 NULL); 1694 else 1695 gfc_free_expr (p->ts.u.cl->length); 1696 1697 p->ts.u.cl->length 1698 = gfc_get_int_expr (gfc_default_integer_kind, 1699 NULL, string_len); 1700 } 1701 } 1702 gfc_free_ref_list (p->ref); 1703 p->ref = NULL; 1704 break; 1705 1706 default: 1707 return true; 1708 } 1709 1710 break; 1711 1712 case REF_COMPONENT: 1713 cons = find_component_ref (p->value.constructor, p->ref); 1714 remove_subobject_ref (p, cons); 1715 break; 1716 1717 case REF_SUBSTRING: 1718 if (!find_substring_ref (p, &newp)) 1719 return false; 1720 1721 gfc_replace_expr (p, newp); 1722 gfc_free_ref_list (p->ref); 1723 p->ref = NULL; 1724 break; 1725 } 1726 } 1727 1728 return true; 1729} 1730 1731 1732/* Simplify a chain of references. */ 1733 1734static bool 1735simplify_ref_chain (gfc_ref *ref, int type) 1736{ 1737 int n; 1738 1739 for (; ref; ref = ref->next) 1740 { 1741 switch (ref->type) 1742 { 1743 case REF_ARRAY: 1744 for (n = 0; n < ref->u.ar.dimen; n++) 1745 { 1746 if (!gfc_simplify_expr (ref->u.ar.start[n], type)) 1747 return false; 1748 if (!gfc_simplify_expr (ref->u.ar.end[n], type)) 1749 return false; 1750 if (!gfc_simplify_expr (ref->u.ar.stride[n], type)) 1751 return false; 1752 } 1753 break; 1754 1755 case REF_SUBSTRING: 1756 if (!gfc_simplify_expr (ref->u.ss.start, type)) 1757 return false; 1758 if (!gfc_simplify_expr (ref->u.ss.end, type)) 1759 return false; 1760 break; 1761 1762 default: 1763 break; 1764 } 1765 } 1766 return true; 1767} 1768 1769 1770/* Try to substitute the value of a parameter variable. */ 1771 1772static bool 1773simplify_parameter_variable (gfc_expr *p, int type) 1774{ 1775 gfc_expr *e; 1776 bool t; 1777 1778 e = gfc_copy_expr (p->symtree->n.sym->value); 1779 if (e == NULL) 1780 return false; 1781 1782 e->rank = p->rank; 1783 1784 /* Do not copy subobject refs for constant. */ 1785 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) 1786 e->ref = gfc_copy_ref (p->ref); 1787 t = gfc_simplify_expr (e, type); 1788 1789 /* Only use the simplification if it eliminated all subobject references. */ 1790 if (t && !e->ref) 1791 gfc_replace_expr (p, e); 1792 else 1793 gfc_free_expr (e); 1794 1795 return t; 1796} 1797 1798/* Given an expression, simplify it by collapsing constant 1799 expressions. Most simplification takes place when the expression 1800 tree is being constructed. If an intrinsic function is simplified 1801 at some point, we get called again to collapse the result against 1802 other constants. 1803 1804 We work by recursively simplifying expression nodes, simplifying 1805 intrinsic functions where possible, which can lead to further 1806 constant collapsing. If an operator has constant operand(s), we 1807 rip the expression apart, and rebuild it, hoping that it becomes 1808 something simpler. 1809 1810 The expression type is defined for: 1811 0 Basic expression parsing 1812 1 Simplifying array constructors -- will substitute 1813 iterator values. 1814 Returns false on error, true otherwise. 1815 NOTE: Will return true even if the expression can not be simplified. */ 1816 1817bool 1818gfc_simplify_expr (gfc_expr *p, int type) 1819{ 1820 gfc_actual_arglist *ap; 1821 1822 if (p == NULL) 1823 return true; 1824 1825 switch (p->expr_type) 1826 { 1827 case EXPR_CONSTANT: 1828 case EXPR_NULL: 1829 break; 1830 1831 case EXPR_FUNCTION: 1832 for (ap = p->value.function.actual; ap; ap = ap->next) 1833 if (!gfc_simplify_expr (ap->expr, type)) 1834 return false; 1835 1836 if (p->value.function.isym != NULL 1837 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) 1838 return false; 1839 1840 break; 1841 1842 case EXPR_SUBSTRING: 1843 if (!simplify_ref_chain (p->ref, type)) 1844 return false; 1845 1846 if (gfc_is_constant_expr (p)) 1847 { 1848 gfc_char_t *s; 1849 int start, end; 1850 1851 start = 0; 1852 if (p->ref && p->ref->u.ss.start) 1853 { 1854 gfc_extract_int (p->ref->u.ss.start, &start); 1855 start--; /* Convert from one-based to zero-based. */ 1856 } 1857 1858 end = p->value.character.length; 1859 if (p->ref && p->ref->u.ss.end) 1860 gfc_extract_int (p->ref->u.ss.end, &end); 1861 1862 if (end < start) 1863 end = start; 1864 1865 s = gfc_get_wide_string (end - start + 2); 1866 memcpy (s, p->value.character.string + start, 1867 (end - start) * sizeof (gfc_char_t)); 1868 s[end - start + 1] = '\0'; /* TODO: C-style string. */ 1869 free (p->value.character.string); 1870 p->value.character.string = s; 1871 p->value.character.length = end - start; 1872 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 1873 p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, 1874 NULL, 1875 p->value.character.length); 1876 gfc_free_ref_list (p->ref); 1877 p->ref = NULL; 1878 p->expr_type = EXPR_CONSTANT; 1879 } 1880 break; 1881 1882 case EXPR_OP: 1883 if (!simplify_intrinsic_op (p, type)) 1884 return false; 1885 break; 1886 1887 case EXPR_VARIABLE: 1888 /* Only substitute array parameter variables if we are in an 1889 initialization expression, or we want a subsection. */ 1890 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER 1891 && (gfc_init_expr_flag || p->ref 1892 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) 1893 { 1894 if (!simplify_parameter_variable (p, type)) 1895 return false; 1896 break; 1897 } 1898 1899 if (type == 1) 1900 { 1901 gfc_simplify_iterator_var (p); 1902 } 1903 1904 /* Simplify subcomponent references. */ 1905 if (!simplify_ref_chain (p->ref, type)) 1906 return false; 1907 1908 break; 1909 1910 case EXPR_STRUCTURE: 1911 case EXPR_ARRAY: 1912 if (!simplify_ref_chain (p->ref, type)) 1913 return false; 1914 1915 if (!simplify_constructor (p->value.constructor, type)) 1916 return false; 1917 1918 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY 1919 && p->ref->u.ar.type == AR_FULL) 1920 gfc_expand_constructor (p, false); 1921 1922 if (!simplify_const_ref (p)) 1923 return false; 1924 1925 break; 1926 1927 case EXPR_COMPCALL: 1928 case EXPR_PPC: 1929 break; 1930 } 1931 1932 return true; 1933} 1934 1935 1936/* Returns the type of an expression with the exception that iterator 1937 variables are automatically integers no matter what else they may 1938 be declared as. */ 1939 1940static bt 1941et0 (gfc_expr *e) 1942{ 1943 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e)) 1944 return BT_INTEGER; 1945 1946 return e->ts.type; 1947} 1948 1949 1950/* Scalarize an expression for an elemental intrinsic call. */ 1951 1952static bool 1953scalarize_intrinsic_call (gfc_expr *e) 1954{ 1955 gfc_actual_arglist *a, *b; 1956 gfc_constructor_base ctor; 1957 gfc_constructor *args[5]; 1958 gfc_constructor *ci, *new_ctor; 1959 gfc_expr *expr, *old; 1960 int n, i, rank[5], array_arg; 1961 1962 /* Find which, if any, arguments are arrays. Assume that the old 1963 expression carries the type information and that the first arg 1964 that is an array expression carries all the shape information.*/ 1965 n = array_arg = 0; 1966 a = e->value.function.actual; 1967 for (; a; a = a->next) 1968 { 1969 n++; 1970 if (!a->expr || a->expr->expr_type != EXPR_ARRAY) 1971 continue; 1972 array_arg = n; 1973 expr = gfc_copy_expr (a->expr); 1974 break; 1975 } 1976 1977 if (!array_arg) 1978 return false; 1979 1980 old = gfc_copy_expr (e); 1981 1982 gfc_constructor_free (expr->value.constructor); 1983 expr->value.constructor = NULL; 1984 expr->ts = old->ts; 1985 expr->where = old->where; 1986 expr->expr_type = EXPR_ARRAY; 1987 1988 /* Copy the array argument constructors into an array, with nulls 1989 for the scalars. */ 1990 n = 0; 1991 a = old->value.function.actual; 1992 for (; a; a = a->next) 1993 { 1994 /* Check that this is OK for an initialization expression. */ 1995 if (a->expr && !gfc_check_init_expr (a->expr)) 1996 goto cleanup; 1997 1998 rank[n] = 0; 1999 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE) 2000 { 2001 rank[n] = a->expr->rank; 2002 ctor = a->expr->symtree->n.sym->value->value.constructor; 2003 args[n] = gfc_constructor_first (ctor); 2004 } 2005 else if (a->expr && a->expr->expr_type == EXPR_ARRAY) 2006 { 2007 if (a->expr->rank) 2008 rank[n] = a->expr->rank; 2009 else 2010 rank[n] = 1; 2011 ctor = gfc_constructor_copy (a->expr->value.constructor); 2012 args[n] = gfc_constructor_first (ctor); 2013 } 2014 else 2015 args[n] = NULL; 2016 2017 n++; 2018 } 2019 2020 2021 /* Using the array argument as the master, step through the array 2022 calling the function for each element and advancing the array 2023 constructors together. */ 2024 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) 2025 { 2026 new_ctor = gfc_constructor_append_expr (&expr->value.constructor, 2027 gfc_copy_expr (old), NULL); 2028 2029 gfc_free_actual_arglist (new_ctor->expr->value.function.actual); 2030 a = NULL; 2031 b = old->value.function.actual; 2032 for (i = 0; i < n; i++) 2033 { 2034 if (a == NULL) 2035 new_ctor->expr->value.function.actual 2036 = a = gfc_get_actual_arglist (); 2037 else 2038 { 2039 a->next = gfc_get_actual_arglist (); 2040 a = a->next; 2041 } 2042 2043 if (args[i]) 2044 a->expr = gfc_copy_expr (args[i]->expr); 2045 else 2046 a->expr = gfc_copy_expr (b->expr); 2047 2048 b = b->next; 2049 } 2050 2051 /* Simplify the function calls. If the simplification fails, the 2052 error will be flagged up down-stream or the library will deal 2053 with it. */ 2054 gfc_simplify_expr (new_ctor->expr, 0); 2055 2056 for (i = 0; i < n; i++) 2057 if (args[i]) 2058 args[i] = gfc_constructor_next (args[i]); 2059 2060 for (i = 1; i < n; i++) 2061 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) 2062 || (args[i] == NULL && args[array_arg - 1] != NULL))) 2063 goto compliance; 2064 } 2065 2066 free_expr0 (e); 2067 *e = *expr; 2068 /* Free "expr" but not the pointers it contains. */ 2069 free (expr); 2070 gfc_free_expr (old); 2071 return true; 2072 2073compliance: 2074 gfc_error_now ("elemental function arguments at %C are not compliant"); 2075 2076cleanup: 2077 gfc_free_expr (expr); 2078 gfc_free_expr (old); 2079 return false; 2080} 2081 2082 2083static bool 2084check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *)) 2085{ 2086 gfc_expr *op1 = e->value.op.op1; 2087 gfc_expr *op2 = e->value.op.op2; 2088 2089 if (!(*check_function)(op1)) 2090 return false; 2091 2092 switch (e->value.op.op) 2093 { 2094 case INTRINSIC_UPLUS: 2095 case INTRINSIC_UMINUS: 2096 if (!numeric_type (et0 (op1))) 2097 goto not_numeric; 2098 break; 2099 2100 case INTRINSIC_EQ: 2101 case INTRINSIC_EQ_OS: 2102 case INTRINSIC_NE: 2103 case INTRINSIC_NE_OS: 2104 case INTRINSIC_GT: 2105 case INTRINSIC_GT_OS: 2106 case INTRINSIC_GE: 2107 case INTRINSIC_GE_OS: 2108 case INTRINSIC_LT: 2109 case INTRINSIC_LT_OS: 2110 case INTRINSIC_LE: 2111 case INTRINSIC_LE_OS: 2112 if (!(*check_function)(op2)) 2113 return false; 2114 2115 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) 2116 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) 2117 { 2118 gfc_error ("Numeric or CHARACTER operands are required in " 2119 "expression at %L", &e->where); 2120 return false; 2121 } 2122 break; 2123 2124 case INTRINSIC_PLUS: 2125 case INTRINSIC_MINUS: 2126 case INTRINSIC_TIMES: 2127 case INTRINSIC_DIVIDE: 2128 case INTRINSIC_POWER: 2129 if (!(*check_function)(op2)) 2130 return false; 2131 2132 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) 2133 goto not_numeric; 2134 2135 break; 2136 2137 case INTRINSIC_CONCAT: 2138 if (!(*check_function)(op2)) 2139 return false; 2140 2141 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) 2142 { 2143 gfc_error ("Concatenation operator in expression at %L " 2144 "must have two CHARACTER operands", &op1->where); 2145 return false; 2146 } 2147 2148 if (op1->ts.kind != op2->ts.kind) 2149 { 2150 gfc_error ("Concat operator at %L must concatenate strings of the " 2151 "same kind", &e->where); 2152 return false; 2153 } 2154 2155 break; 2156 2157 case INTRINSIC_NOT: 2158 if (et0 (op1) != BT_LOGICAL) 2159 { 2160 gfc_error (".NOT. operator in expression at %L must have a LOGICAL " 2161 "operand", &op1->where); 2162 return false; 2163 } 2164 2165 break; 2166 2167 case INTRINSIC_AND: 2168 case INTRINSIC_OR: 2169 case INTRINSIC_EQV: 2170 case INTRINSIC_NEQV: 2171 if (!(*check_function)(op2)) 2172 return false; 2173 2174 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) 2175 { 2176 gfc_error ("LOGICAL operands are required in expression at %L", 2177 &e->where); 2178 return false; 2179 } 2180 2181 break; 2182 2183 case INTRINSIC_PARENTHESES: 2184 break; 2185 2186 default: 2187 gfc_error ("Only intrinsic operators can be used in expression at %L", 2188 &e->where); 2189 return false; 2190 } 2191 2192 return true; 2193 2194not_numeric: 2195 gfc_error ("Numeric operands are required in expression at %L", &e->where); 2196 2197 return false; 2198} 2199 2200/* F2003, 7.1.7 (3): In init expression, allocatable components 2201 must not be data-initialized. */ 2202static bool 2203check_alloc_comp_init (gfc_expr *e) 2204{ 2205 gfc_component *comp; 2206 gfc_constructor *ctor; 2207 2208 gcc_assert (e->expr_type == EXPR_STRUCTURE); 2209 gcc_assert (e->ts.type == BT_DERIVED); 2210 2211 for (comp = e->ts.u.derived->components, 2212 ctor = gfc_constructor_first (e->value.constructor); 2213 comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) 2214 { 2215 if (comp->attr.allocatable && ctor->expr 2216 && ctor->expr->expr_type != EXPR_NULL) 2217 { 2218 gfc_error ("Invalid initialization expression for ALLOCATABLE " 2219 "component %qs in structure constructor at %L", 2220 comp->name, &ctor->expr->where); 2221 return false; 2222 } 2223 } 2224 2225 return true; 2226} 2227 2228static match 2229check_init_expr_arguments (gfc_expr *e) 2230{ 2231 gfc_actual_arglist *ap; 2232 2233 for (ap = e->value.function.actual; ap; ap = ap->next) 2234 if (!gfc_check_init_expr (ap->expr)) 2235 return MATCH_ERROR; 2236 2237 return MATCH_YES; 2238} 2239 2240static bool check_restricted (gfc_expr *); 2241 2242/* F95, 7.1.6.1, Initialization expressions, (7) 2243 F2003, 7.1.7 Initialization expression, (8) */ 2244 2245static match 2246check_inquiry (gfc_expr *e, int not_restricted) 2247{ 2248 const char *name; 2249 const char *const *functions; 2250 2251 static const char *const inquiry_func_f95[] = { 2252 "lbound", "shape", "size", "ubound", 2253 "bit_size", "len", "kind", 2254 "digits", "epsilon", "huge", "maxexponent", "minexponent", 2255 "precision", "radix", "range", "tiny", 2256 NULL 2257 }; 2258 2259 static const char *const inquiry_func_f2003[] = { 2260 "lbound", "shape", "size", "ubound", 2261 "bit_size", "len", "kind", 2262 "digits", "epsilon", "huge", "maxexponent", "minexponent", 2263 "precision", "radix", "range", "tiny", 2264 "new_line", NULL 2265 }; 2266 2267 int i = 0; 2268 gfc_actual_arglist *ap; 2269 2270 if (!e->value.function.isym 2271 || !e->value.function.isym->inquiry) 2272 return MATCH_NO; 2273 2274 /* An undeclared parameter will get us here (PR25018). */ 2275 if (e->symtree == NULL) 2276 return MATCH_NO; 2277 2278 if (e->symtree->n.sym->from_intmod) 2279 { 2280 if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV 2281 && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS 2282 && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) 2283 return MATCH_NO; 2284 2285 if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING 2286 && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) 2287 return MATCH_NO; 2288 } 2289 else 2290 { 2291 name = e->symtree->n.sym->name; 2292 2293 functions = (gfc_option.warn_std & GFC_STD_F2003) 2294 ? inquiry_func_f2003 : inquiry_func_f95; 2295 2296 for (i = 0; functions[i]; i++) 2297 if (strcmp (functions[i], name) == 0) 2298 break; 2299 2300 if (functions[i] == NULL) 2301 return MATCH_ERROR; 2302 } 2303 2304 /* At this point we have an inquiry function with a variable argument. The 2305 type of the variable might be undefined, but we need it now, because the 2306 arguments of these functions are not allowed to be undefined. */ 2307 2308 for (ap = e->value.function.actual; ap; ap = ap->next) 2309 { 2310 if (!ap->expr) 2311 continue; 2312 2313 if (ap->expr->ts.type == BT_UNKNOWN) 2314 { 2315 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN 2316 && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)) 2317 return MATCH_NO; 2318 2319 ap->expr->ts = ap->expr->symtree->n.sym->ts; 2320 } 2321 2322 /* Assumed character length will not reduce to a constant expression 2323 with LEN, as required by the standard. */ 2324 if (i == 5 && not_restricted 2325 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER 2326 && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL 2327 || ap->expr->symtree->n.sym->ts.deferred)) 2328 { 2329 gfc_error ("Assumed or deferred character length variable %qs " 2330 " in constant expression at %L", 2331 ap->expr->symtree->n.sym->name, 2332 &ap->expr->where); 2333 return MATCH_ERROR; 2334 } 2335 else if (not_restricted && !gfc_check_init_expr (ap->expr)) 2336 return MATCH_ERROR; 2337 2338 if (not_restricted == 0 2339 && ap->expr->expr_type != EXPR_VARIABLE 2340 && !check_restricted (ap->expr)) 2341 return MATCH_ERROR; 2342 2343 if (not_restricted == 0 2344 && ap->expr->expr_type == EXPR_VARIABLE 2345 && ap->expr->symtree->n.sym->attr.dummy 2346 && ap->expr->symtree->n.sym->attr.optional) 2347 return MATCH_NO; 2348 } 2349 2350 return MATCH_YES; 2351} 2352 2353 2354/* F95, 7.1.6.1, Initialization expressions, (5) 2355 F2003, 7.1.7 Initialization expression, (5) */ 2356 2357static match 2358check_transformational (gfc_expr *e) 2359{ 2360 static const char * const trans_func_f95[] = { 2361 "repeat", "reshape", "selected_int_kind", 2362 "selected_real_kind", "transfer", "trim", NULL 2363 }; 2364 2365 static const char * const trans_func_f2003[] = { 2366 "all", "any", "count", "dot_product", "matmul", "null", "pack", 2367 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", 2368 "selected_real_kind", "spread", "sum", "transfer", "transpose", 2369 "trim", "unpack", NULL 2370 }; 2371 2372 int i; 2373 const char *name; 2374 const char *const *functions; 2375 2376 if (!e->value.function.isym 2377 || !e->value.function.isym->transformational) 2378 return MATCH_NO; 2379 2380 name = e->symtree->n.sym->name; 2381 2382 functions = (gfc_option.allow_std & GFC_STD_F2003) 2383 ? trans_func_f2003 : trans_func_f95; 2384 2385 /* NULL() is dealt with below. */ 2386 if (strcmp ("null", name) == 0) 2387 return MATCH_NO; 2388 2389 for (i = 0; functions[i]; i++) 2390 if (strcmp (functions[i], name) == 0) 2391 break; 2392 2393 if (functions[i] == NULL) 2394 { 2395 gfc_error ("transformational intrinsic %qs at %L is not permitted " 2396 "in an initialization expression", name, &e->where); 2397 return MATCH_ERROR; 2398 } 2399 2400 return check_init_expr_arguments (e); 2401} 2402 2403 2404/* F95, 7.1.6.1, Initialization expressions, (6) 2405 F2003, 7.1.7 Initialization expression, (6) */ 2406 2407static match 2408check_null (gfc_expr *e) 2409{ 2410 if (strcmp ("null", e->symtree->n.sym->name) != 0) 2411 return MATCH_NO; 2412 2413 return check_init_expr_arguments (e); 2414} 2415 2416 2417static match 2418check_elemental (gfc_expr *e) 2419{ 2420 if (!e->value.function.isym 2421 || !e->value.function.isym->elemental) 2422 return MATCH_NO; 2423 2424 if (e->ts.type != BT_INTEGER 2425 && e->ts.type != BT_CHARACTER 2426 && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard " 2427 "initialization expression at %L", &e->where)) 2428 return MATCH_ERROR; 2429 2430 return check_init_expr_arguments (e); 2431} 2432 2433 2434static match 2435check_conversion (gfc_expr *e) 2436{ 2437 if (!e->value.function.isym 2438 || !e->value.function.isym->conversion) 2439 return MATCH_NO; 2440 2441 return check_init_expr_arguments (e); 2442} 2443 2444 2445/* Verify that an expression is an initialization expression. A side 2446 effect is that the expression tree is reduced to a single constant 2447 node if all goes well. This would normally happen when the 2448 expression is constructed but function references are assumed to be 2449 intrinsics in the context of initialization expressions. If 2450 false is returned an error message has been generated. */ 2451 2452bool 2453gfc_check_init_expr (gfc_expr *e) 2454{ 2455 match m; 2456 bool t; 2457 2458 if (e == NULL) 2459 return true; 2460 2461 switch (e->expr_type) 2462 { 2463 case EXPR_OP: 2464 t = check_intrinsic_op (e, gfc_check_init_expr); 2465 if (t) 2466 t = gfc_simplify_expr (e, 0); 2467 2468 break; 2469 2470 case EXPR_FUNCTION: 2471 t = false; 2472 2473 { 2474 bool conversion; 2475 gfc_intrinsic_sym* isym = NULL; 2476 gfc_symbol* sym = e->symtree->n.sym; 2477 2478 /* Special case for IEEE_SELECTED_REAL_KIND from the intrinsic 2479 module IEEE_ARITHMETIC, which is allowed in initialization 2480 expressions. */ 2481 if (!strcmp(sym->name, "ieee_selected_real_kind") 2482 && sym->from_intmod == INTMOD_IEEE_ARITHMETIC) 2483 { 2484 gfc_expr *new_expr = gfc_simplify_ieee_selected_real_kind (e); 2485 if (new_expr) 2486 { 2487 gfc_replace_expr (e, new_expr); 2488 t = true; 2489 break; 2490 } 2491 } 2492 2493 /* If a conversion function, e.g., __convert_i8_i4, was inserted 2494 into an array constructor, we need to skip the error check here. 2495 Conversion errors are caught below in scalarize_intrinsic_call. */ 2496 conversion = e->value.function.isym 2497 && (e->value.function.isym->conversion == 1); 2498 2499 if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where) 2500 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)) 2501 { 2502 gfc_error ("Function %qs in initialization expression at %L " 2503 "must be an intrinsic function", 2504 e->symtree->n.sym->name, &e->where); 2505 break; 2506 } 2507 2508 if ((m = check_conversion (e)) == MATCH_NO 2509 && (m = check_inquiry (e, 1)) == MATCH_NO 2510 && (m = check_null (e)) == MATCH_NO 2511 && (m = check_transformational (e)) == MATCH_NO 2512 && (m = check_elemental (e)) == MATCH_NO) 2513 { 2514 gfc_error ("Intrinsic function %qs at %L is not permitted " 2515 "in an initialization expression", 2516 e->symtree->n.sym->name, &e->where); 2517 m = MATCH_ERROR; 2518 } 2519 2520 if (m == MATCH_ERROR) 2521 return false; 2522 2523 /* Try to scalarize an elemental intrinsic function that has an 2524 array argument. */ 2525 isym = gfc_find_function (e->symtree->n.sym->name); 2526 if (isym && isym->elemental 2527 && (t = scalarize_intrinsic_call (e))) 2528 break; 2529 } 2530 2531 if (m == MATCH_YES) 2532 t = gfc_simplify_expr (e, 0); 2533 2534 break; 2535 2536 case EXPR_VARIABLE: 2537 t = true; 2538 2539 if (gfc_check_iter_variable (e)) 2540 break; 2541 2542 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) 2543 { 2544 /* A PARAMETER shall not be used to define itself, i.e. 2545 REAL, PARAMETER :: x = transfer(0, x) 2546 is invalid. */ 2547 if (!e->symtree->n.sym->value) 2548 { 2549 gfc_error ("PARAMETER %qs is used at %L before its definition " 2550 "is complete", e->symtree->n.sym->name, &e->where); 2551 t = false; 2552 } 2553 else 2554 t = simplify_parameter_variable (e, 0); 2555 2556 break; 2557 } 2558 2559 if (gfc_in_match_data ()) 2560 break; 2561 2562 t = false; 2563 2564 if (e->symtree->n.sym->as) 2565 { 2566 switch (e->symtree->n.sym->as->type) 2567 { 2568 case AS_ASSUMED_SIZE: 2569 gfc_error ("Assumed size array %qs at %L is not permitted " 2570 "in an initialization expression", 2571 e->symtree->n.sym->name, &e->where); 2572 break; 2573 2574 case AS_ASSUMED_SHAPE: 2575 gfc_error ("Assumed shape array %qs at %L is not permitted " 2576 "in an initialization expression", 2577 e->symtree->n.sym->name, &e->where); 2578 break; 2579 2580 case AS_DEFERRED: 2581 gfc_error ("Deferred array %qs at %L is not permitted " 2582 "in an initialization expression", 2583 e->symtree->n.sym->name, &e->where); 2584 break; 2585 2586 case AS_EXPLICIT: 2587 gfc_error ("Array %qs at %L is a variable, which does " 2588 "not reduce to a constant expression", 2589 e->symtree->n.sym->name, &e->where); 2590 break; 2591 2592 default: 2593 gcc_unreachable(); 2594 } 2595 } 2596 else 2597 gfc_error ("Parameter %qs at %L has not been declared or is " 2598 "a variable, which does not reduce to a constant " 2599 "expression", e->symtree->n.sym->name, &e->where); 2600 2601 break; 2602 2603 case EXPR_CONSTANT: 2604 case EXPR_NULL: 2605 t = true; 2606 break; 2607 2608 case EXPR_SUBSTRING: 2609 if (e->ref) 2610 { 2611 t = gfc_check_init_expr (e->ref->u.ss.start); 2612 if (!t) 2613 break; 2614 2615 t = gfc_check_init_expr (e->ref->u.ss.end); 2616 if (t) 2617 t = gfc_simplify_expr (e, 0); 2618 } 2619 else 2620 t = false; 2621 break; 2622 2623 case EXPR_STRUCTURE: 2624 t = e->ts.is_iso_c ? true : false; 2625 if (t) 2626 break; 2627 2628 t = check_alloc_comp_init (e); 2629 if (!t) 2630 break; 2631 2632 t = gfc_check_constructor (e, gfc_check_init_expr); 2633 if (!t) 2634 break; 2635 2636 break; 2637 2638 case EXPR_ARRAY: 2639 t = gfc_check_constructor (e, gfc_check_init_expr); 2640 if (!t) 2641 break; 2642 2643 t = gfc_expand_constructor (e, true); 2644 if (!t) 2645 break; 2646 2647 t = gfc_check_constructor_type (e); 2648 break; 2649 2650 default: 2651 gfc_internal_error ("check_init_expr(): Unknown expression type"); 2652 } 2653 2654 return t; 2655} 2656 2657/* Reduces a general expression to an initialization expression (a constant). 2658 This used to be part of gfc_match_init_expr. 2659 Note that this function doesn't free the given expression on false. */ 2660 2661bool 2662gfc_reduce_init_expr (gfc_expr *expr) 2663{ 2664 bool t; 2665 2666 gfc_init_expr_flag = true; 2667 t = gfc_resolve_expr (expr); 2668 if (t) 2669 t = gfc_check_init_expr (expr); 2670 gfc_init_expr_flag = false; 2671 2672 if (!t) 2673 return false; 2674 2675 if (expr->expr_type == EXPR_ARRAY) 2676 { 2677 if (!gfc_check_constructor_type (expr)) 2678 return false; 2679 if (!gfc_expand_constructor (expr, true)) 2680 return false; 2681 } 2682 2683 return true; 2684} 2685 2686 2687/* Match an initialization expression. We work by first matching an 2688 expression, then reducing it to a constant. */ 2689 2690match 2691gfc_match_init_expr (gfc_expr **result) 2692{ 2693 gfc_expr *expr; 2694 match m; 2695 bool t; 2696 2697 expr = NULL; 2698 2699 gfc_init_expr_flag = true; 2700 2701 m = gfc_match_expr (&expr); 2702 if (m != MATCH_YES) 2703 { 2704 gfc_init_expr_flag = false; 2705 return m; 2706 } 2707 2708 t = gfc_reduce_init_expr (expr); 2709 if (!t) 2710 { 2711 gfc_free_expr (expr); 2712 gfc_init_expr_flag = false; 2713 return MATCH_ERROR; 2714 } 2715 2716 *result = expr; 2717 gfc_init_expr_flag = false; 2718 2719 return MATCH_YES; 2720} 2721 2722 2723/* Given an actual argument list, test to see that each argument is a 2724 restricted expression and optionally if the expression type is 2725 integer or character. */ 2726 2727static bool 2728restricted_args (gfc_actual_arglist *a) 2729{ 2730 for (; a; a = a->next) 2731 { 2732 if (!check_restricted (a->expr)) 2733 return false; 2734 } 2735 2736 return true; 2737} 2738 2739 2740/************* Restricted/specification expressions *************/ 2741 2742 2743/* Make sure a non-intrinsic function is a specification function. */ 2744 2745static bool 2746external_spec_function (gfc_expr *e) 2747{ 2748 gfc_symbol *f; 2749 2750 f = e->value.function.esym; 2751 2752 if (f->attr.proc == PROC_ST_FUNCTION) 2753 { 2754 gfc_error ("Specification function %qs at %L cannot be a statement " 2755 "function", f->name, &e->where); 2756 return false; 2757 } 2758 2759 if (f->attr.proc == PROC_INTERNAL) 2760 { 2761 gfc_error ("Specification function %qs at %L cannot be an internal " 2762 "function", f->name, &e->where); 2763 return false; 2764 } 2765 2766 if (!f->attr.pure && !f->attr.elemental) 2767 { 2768 gfc_error ("Specification function %qs at %L must be PURE", f->name, 2769 &e->where); 2770 return false; 2771 } 2772 2773 if (f->attr.recursive) 2774 { 2775 gfc_error ("Specification function %qs at %L cannot be RECURSIVE", 2776 f->name, &e->where); 2777 return false; 2778 } 2779 2780 return restricted_args (e->value.function.actual); 2781} 2782 2783 2784/* Check to see that a function reference to an intrinsic is a 2785 restricted expression. */ 2786 2787static bool 2788restricted_intrinsic (gfc_expr *e) 2789{ 2790 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ 2791 if (check_inquiry (e, 0) == MATCH_YES) 2792 return true; 2793 2794 return restricted_args (e->value.function.actual); 2795} 2796 2797 2798/* Check the expressions of an actual arglist. Used by check_restricted. */ 2799 2800static bool 2801check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) 2802{ 2803 for (; arg; arg = arg->next) 2804 if (!checker (arg->expr)) 2805 return false; 2806 2807 return true; 2808} 2809 2810 2811/* Check the subscription expressions of a reference chain with a checking 2812 function; used by check_restricted. */ 2813 2814static bool 2815check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) 2816{ 2817 int dim; 2818 2819 if (!ref) 2820 return true; 2821 2822 switch (ref->type) 2823 { 2824 case REF_ARRAY: 2825 for (dim = 0; dim != ref->u.ar.dimen; ++dim) 2826 { 2827 if (!checker (ref->u.ar.start[dim])) 2828 return false; 2829 if (!checker (ref->u.ar.end[dim])) 2830 return false; 2831 if (!checker (ref->u.ar.stride[dim])) 2832 return false; 2833 } 2834 break; 2835 2836 case REF_COMPONENT: 2837 /* Nothing needed, just proceed to next reference. */ 2838 break; 2839 2840 case REF_SUBSTRING: 2841 if (!checker (ref->u.ss.start)) 2842 return false; 2843 if (!checker (ref->u.ss.end)) 2844 return false; 2845 break; 2846 2847 default: 2848 gcc_unreachable (); 2849 break; 2850 } 2851 2852 return check_references (ref->next, checker); 2853} 2854 2855 2856/* Verify that an expression is a restricted expression. Like its 2857 cousin check_init_expr(), an error message is generated if we 2858 return false. */ 2859 2860static bool 2861check_restricted (gfc_expr *e) 2862{ 2863 gfc_symbol* sym; 2864 bool t; 2865 2866 if (e == NULL) 2867 return true; 2868 2869 switch (e->expr_type) 2870 { 2871 case EXPR_OP: 2872 t = check_intrinsic_op (e, check_restricted); 2873 if (t) 2874 t = gfc_simplify_expr (e, 0); 2875 2876 break; 2877 2878 case EXPR_FUNCTION: 2879 if (e->value.function.esym) 2880 { 2881 t = check_arglist (e->value.function.actual, &check_restricted); 2882 if (t) 2883 t = external_spec_function (e); 2884 } 2885 else 2886 { 2887 if (e->value.function.isym && e->value.function.isym->inquiry) 2888 t = true; 2889 else 2890 t = check_arglist (e->value.function.actual, &check_restricted); 2891 2892 if (t) 2893 t = restricted_intrinsic (e); 2894 } 2895 break; 2896 2897 case EXPR_VARIABLE: 2898 sym = e->symtree->n.sym; 2899 t = false; 2900 2901 /* If a dummy argument appears in a context that is valid for a 2902 restricted expression in an elemental procedure, it will have 2903 already been simplified away once we get here. Therefore we 2904 don't need to jump through hoops to distinguish valid from 2905 invalid cases. */ 2906 if (sym->attr.dummy && sym->ns == gfc_current_ns 2907 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) 2908 { 2909 gfc_error ("Dummy argument %qs not allowed in expression at %L", 2910 sym->name, &e->where); 2911 break; 2912 } 2913 2914 if (sym->attr.optional) 2915 { 2916 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", 2917 sym->name, &e->where); 2918 break; 2919 } 2920 2921 if (sym->attr.intent == INTENT_OUT) 2922 { 2923 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", 2924 sym->name, &e->where); 2925 break; 2926 } 2927 2928 /* Check reference chain if any. */ 2929 if (!check_references (e->ref, &check_restricted)) 2930 break; 2931 2932 /* gfc_is_formal_arg broadcasts that a formal argument list is being 2933 processed in resolve.c(resolve_formal_arglist). This is done so 2934 that host associated dummy array indices are accepted (PR23446). 2935 This mechanism also does the same for the specification expressions 2936 of array-valued functions. */ 2937 if (e->error 2938 || sym->attr.in_common 2939 || sym->attr.use_assoc 2940 || sym->attr.dummy 2941 || sym->attr.implied_index 2942 || sym->attr.flavor == FL_PARAMETER 2943 || (sym->ns && sym->ns == gfc_current_ns->parent) 2944 || (sym->ns && gfc_current_ns->parent 2945 && sym->ns == gfc_current_ns->parent->parent) 2946 || (sym->ns->proc_name != NULL 2947 && sym->ns->proc_name->attr.flavor == FL_MODULE) 2948 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) 2949 { 2950 t = true; 2951 break; 2952 } 2953 2954 gfc_error ("Variable %qs cannot appear in the expression at %L", 2955 sym->name, &e->where); 2956 /* Prevent a repetition of the error. */ 2957 e->error = 1; 2958 break; 2959 2960 case EXPR_NULL: 2961 case EXPR_CONSTANT: 2962 t = true; 2963 break; 2964 2965 case EXPR_SUBSTRING: 2966 t = gfc_specification_expr (e->ref->u.ss.start); 2967 if (!t) 2968 break; 2969 2970 t = gfc_specification_expr (e->ref->u.ss.end); 2971 if (t) 2972 t = gfc_simplify_expr (e, 0); 2973 2974 break; 2975 2976 case EXPR_STRUCTURE: 2977 t = gfc_check_constructor (e, check_restricted); 2978 break; 2979 2980 case EXPR_ARRAY: 2981 t = gfc_check_constructor (e, check_restricted); 2982 break; 2983 2984 default: 2985 gfc_internal_error ("check_restricted(): Unknown expression type"); 2986 } 2987 2988 return t; 2989} 2990 2991 2992/* Check to see that an expression is a specification expression. If 2993 we return false, an error has been generated. */ 2994 2995bool 2996gfc_specification_expr (gfc_expr *e) 2997{ 2998 gfc_component *comp; 2999 3000 if (e == NULL) 3001 return true; 3002 3003 if (e->ts.type != BT_INTEGER) 3004 { 3005 gfc_error ("Expression at %L must be of INTEGER type, found %s", 3006 &e->where, gfc_basic_typename (e->ts.type)); 3007 return false; 3008 } 3009 3010 comp = gfc_get_proc_ptr_comp (e); 3011 if (e->expr_type == EXPR_FUNCTION 3012 && !e->value.function.isym 3013 && !e->value.function.esym 3014 && !gfc_pure (e->symtree->n.sym) 3015 && (!comp || !comp->attr.pure)) 3016 { 3017 gfc_error ("Function %qs at %L must be PURE", 3018 e->symtree->n.sym->name, &e->where); 3019 /* Prevent repeat error messages. */ 3020 e->symtree->n.sym->attr.pure = 1; 3021 return false; 3022 } 3023 3024 if (e->rank != 0) 3025 { 3026 gfc_error ("Expression at %L must be scalar", &e->where); 3027 return false; 3028 } 3029 3030 if (!gfc_simplify_expr (e, 0)) 3031 return false; 3032 3033 return check_restricted (e); 3034} 3035 3036 3037/************** Expression conformance checks. *************/ 3038 3039/* Given two expressions, make sure that the arrays are conformable. */ 3040 3041bool 3042gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) 3043{ 3044 int op1_flag, op2_flag, d; 3045 mpz_t op1_size, op2_size; 3046 bool t; 3047 3048 va_list argp; 3049 char buffer[240]; 3050 3051 if (op1->rank == 0 || op2->rank == 0) 3052 return true; 3053 3054 va_start (argp, optype_msgid); 3055 vsnprintf (buffer, 240, optype_msgid, argp); 3056 va_end (argp); 3057 3058 if (op1->rank != op2->rank) 3059 { 3060 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer), 3061 op1->rank, op2->rank, &op1->where); 3062 return false; 3063 } 3064 3065 t = true; 3066 3067 for (d = 0; d < op1->rank; d++) 3068 { 3069 op1_flag = gfc_array_dimen_size(op1, d, &op1_size); 3070 op2_flag = gfc_array_dimen_size(op2, d, &op2_size); 3071 3072 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) 3073 { 3074 gfc_error ("Different shape for %s at %L on dimension %d " 3075 "(%d and %d)", _(buffer), &op1->where, d + 1, 3076 (int) mpz_get_si (op1_size), 3077 (int) mpz_get_si (op2_size)); 3078 3079 t = false; 3080 } 3081 3082 if (op1_flag) 3083 mpz_clear (op1_size); 3084 if (op2_flag) 3085 mpz_clear (op2_size); 3086 3087 if (!t) 3088 return false; 3089 } 3090 3091 return true; 3092} 3093 3094 3095/* Given an assignable expression and an arbitrary expression, make 3096 sure that the assignment can take place. */ 3097 3098bool 3099gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) 3100{ 3101 gfc_symbol *sym; 3102 gfc_ref *ref; 3103 int has_pointer; 3104 3105 sym = lvalue->symtree->n.sym; 3106 3107 /* See if this is the component or subcomponent of a pointer. */ 3108 has_pointer = sym->attr.pointer; 3109 for (ref = lvalue->ref; ref; ref = ref->next) 3110 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) 3111 { 3112 has_pointer = 1; 3113 break; 3114 } 3115 3116 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other 3117 variable local to a function subprogram. Its existence begins when 3118 execution of the function is initiated and ends when execution of the 3119 function is terminated... 3120 Therefore, the left hand side is no longer a variable, when it is: */ 3121 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION 3122 && !sym->attr.external) 3123 { 3124 bool bad_proc; 3125 bad_proc = false; 3126 3127 /* (i) Use associated; */ 3128 if (sym->attr.use_assoc) 3129 bad_proc = true; 3130 3131 /* (ii) The assignment is in the main program; or */ 3132 if (gfc_current_ns->proc_name 3133 && gfc_current_ns->proc_name->attr.is_main_program) 3134 bad_proc = true; 3135 3136 /* (iii) A module or internal procedure... */ 3137 if (gfc_current_ns->proc_name 3138 && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL 3139 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) 3140 && gfc_current_ns->parent 3141 && (!(gfc_current_ns->parent->proc_name->attr.function 3142 || gfc_current_ns->parent->proc_name->attr.subroutine) 3143 || gfc_current_ns->parent->proc_name->attr.is_main_program)) 3144 { 3145 /* ... that is not a function... */ 3146 if (gfc_current_ns->proc_name 3147 && !gfc_current_ns->proc_name->attr.function) 3148 bad_proc = true; 3149 3150 /* ... or is not an entry and has a different name. */ 3151 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) 3152 bad_proc = true; 3153 } 3154 3155 /* (iv) Host associated and not the function symbol or the 3156 parent result. This picks up sibling references, which 3157 cannot be entries. */ 3158 if (!sym->attr.entry 3159 && sym->ns == gfc_current_ns->parent 3160 && sym != gfc_current_ns->proc_name 3161 && sym != gfc_current_ns->parent->proc_name->result) 3162 bad_proc = true; 3163 3164 if (bad_proc) 3165 { 3166 gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); 3167 return false; 3168 } 3169 } 3170 3171 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) 3172 { 3173 gfc_error ("Incompatible ranks %d and %d in assignment at %L", 3174 lvalue->rank, rvalue->rank, &lvalue->where); 3175 return false; 3176 } 3177 3178 if (lvalue->ts.type == BT_UNKNOWN) 3179 { 3180 gfc_error ("Variable type is UNKNOWN in assignment at %L", 3181 &lvalue->where); 3182 return false; 3183 } 3184 3185 if (rvalue->expr_type == EXPR_NULL) 3186 { 3187 if (has_pointer && (ref == NULL || ref->next == NULL) 3188 && lvalue->symtree->n.sym->attr.data) 3189 return true; 3190 else 3191 { 3192 gfc_error ("NULL appears on right-hand side in assignment at %L", 3193 &rvalue->where); 3194 return false; 3195 } 3196 } 3197 3198 /* This is possibly a typo: x = f() instead of x => f(). */ 3199 if (warn_surprising 3200 && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) 3201 gfc_warning (OPT_Wsurprising, 3202 "POINTER-valued function appears on right-hand side of " 3203 "assignment at %L", &rvalue->where); 3204 3205 /* Check size of array assignments. */ 3206 if (lvalue->rank != 0 && rvalue->rank != 0 3207 && !gfc_check_conformance (lvalue, rvalue, "array assignment")) 3208 return false; 3209 3210 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER 3211 && lvalue->symtree->n.sym->attr.data 3212 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to " 3213 "initialize non-integer variable %qs", 3214 &rvalue->where, lvalue->symtree->n.sym->name)) 3215 return false; 3216 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data 3217 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " 3218 "a DATA statement and outside INT/REAL/DBLE/CMPLX", 3219 &rvalue->where)) 3220 return false; 3221 3222 /* Handle the case of a BOZ literal on the RHS. */ 3223 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER) 3224 { 3225 int rc; 3226 if (warn_surprising) 3227 gfc_warning (OPT_Wsurprising, 3228 "BOZ literal at %L is bitwise transferred " 3229 "non-integer symbol %qs", &rvalue->where, 3230 lvalue->symtree->n.sym->name); 3231 if (!gfc_convert_boz (rvalue, &lvalue->ts)) 3232 return false; 3233 if ((rc = gfc_range_check (rvalue)) != ARITH_OK) 3234 { 3235 if (rc == ARITH_UNDERFLOW) 3236 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L" 3237 ". This check can be disabled with the option " 3238 "%<-fno-range-check%>", &rvalue->where); 3239 else if (rc == ARITH_OVERFLOW) 3240 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L" 3241 ". This check can be disabled with the option " 3242 "%<-fno-range-check%>", &rvalue->where); 3243 else if (rc == ARITH_NAN) 3244 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L" 3245 ". This check can be disabled with the option " 3246 "%<-fno-range-check%>", &rvalue->where); 3247 return false; 3248 } 3249 } 3250 3251 /* Warn about type-changing conversions for REAL or COMPLEX constants. 3252 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types 3253 will warn anyway, so there is no need to to so here. */ 3254 3255 if (rvalue->expr_type == EXPR_CONSTANT && lvalue->ts.type == rvalue->ts.type 3256 && (lvalue->ts.type == BT_REAL || lvalue->ts.type == BT_COMPLEX)) 3257 { 3258 if (lvalue->ts.kind < rvalue->ts.kind && warn_conversion) 3259 { 3260 /* As a special bonus, don't warn about REAL rvalues which are not 3261 changed by the conversion if -Wconversion is specified. */ 3262 if (rvalue->ts.type == BT_REAL && mpfr_number_p (rvalue->value.real)) 3263 { 3264 /* Calculate the difference between the constant and the rounded 3265 value and check it against zero. */ 3266 mpfr_t rv, diff; 3267 gfc_set_model_kind (lvalue->ts.kind); 3268 mpfr_init (rv); 3269 gfc_set_model_kind (rvalue->ts.kind); 3270 mpfr_init (diff); 3271 3272 mpfr_set (rv, rvalue->value.real, GFC_RND_MODE); 3273 mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE); 3274 3275 if (!mpfr_zero_p (diff)) 3276 gfc_warning (OPT_Wconversion, 3277 "Change of value in conversion from " 3278 " %qs to %qs at %L", gfc_typename (&rvalue->ts), 3279 gfc_typename (&lvalue->ts), &rvalue->where); 3280 3281 mpfr_clear (rv); 3282 mpfr_clear (diff); 3283 } 3284 else 3285 gfc_warning (OPT_Wconversion, 3286 "Possible change of value in conversion from %qs " 3287 "to %qs at %L", gfc_typename (&rvalue->ts), 3288 gfc_typename (&lvalue->ts), &rvalue->where); 3289 3290 } 3291 else if (warn_conversion_extra && lvalue->ts.kind > rvalue->ts.kind) 3292 { 3293 gfc_warning (OPT_Wconversion_extra, 3294 "Conversion from %qs to %qs at %L", 3295 gfc_typename (&rvalue->ts), 3296 gfc_typename (&lvalue->ts), &rvalue->where); 3297 } 3298 } 3299 3300 if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) 3301 return true; 3302 3303 /* Only DATA Statements come here. */ 3304 if (!conform) 3305 { 3306 /* Numeric can be converted to any other numeric. And Hollerith can be 3307 converted to any other type. */ 3308 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) 3309 || rvalue->ts.type == BT_HOLLERITH) 3310 return true; 3311 3312 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) 3313 return true; 3314 3315 gfc_error ("Incompatible types in DATA statement at %L; attempted " 3316 "conversion of %s to %s", &lvalue->where, 3317 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); 3318 3319 return false; 3320 } 3321 3322 /* Assignment is the only case where character variables of different 3323 kind values can be converted into one another. */ 3324 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) 3325 { 3326 if (lvalue->ts.kind != rvalue->ts.kind) 3327 gfc_convert_chartype (rvalue, &lvalue->ts); 3328 3329 return true; 3330 } 3331 3332 return gfc_convert_type (rvalue, &lvalue->ts, 1); 3333} 3334 3335 3336/* Check that a pointer assignment is OK. We first check lvalue, and 3337 we only check rvalue if it's not an assignment to NULL() or a 3338 NULLIFY statement. */ 3339 3340bool 3341gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) 3342{ 3343 symbol_attribute attr, lhs_attr; 3344 gfc_ref *ref; 3345 bool is_pure, is_implicit_pure, rank_remap; 3346 int proc_pointer; 3347 3348 lhs_attr = gfc_expr_attr (lvalue); 3349 if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) 3350 { 3351 gfc_error ("Pointer assignment target is not a POINTER at %L", 3352 &lvalue->where); 3353 return false; 3354 } 3355 3356 if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc 3357 && !lhs_attr.proc_pointer) 3358 { 3359 gfc_error ("%qs in the pointer assignment at %L cannot be an " 3360 "l-value since it is a procedure", 3361 lvalue->symtree->n.sym->name, &lvalue->where); 3362 return false; 3363 } 3364 3365 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; 3366 3367 rank_remap = false; 3368 for (ref = lvalue->ref; ref; ref = ref->next) 3369 { 3370 if (ref->type == REF_COMPONENT) 3371 proc_pointer = ref->u.c.component->attr.proc_pointer; 3372 3373 if (ref->type == REF_ARRAY && ref->next == NULL) 3374 { 3375 int dim; 3376 3377 if (ref->u.ar.type == AR_FULL) 3378 break; 3379 3380 if (ref->u.ar.type != AR_SECTION) 3381 { 3382 gfc_error ("Expected bounds specification for %qs at %L", 3383 lvalue->symtree->n.sym->name, &lvalue->where); 3384 return false; 3385 } 3386 3387 if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " 3388 "for %qs in pointer assignment at %L", 3389 lvalue->symtree->n.sym->name, &lvalue->where)) 3390 return false; 3391 3392 /* When bounds are given, all lbounds are necessary and either all 3393 or none of the upper bounds; no strides are allowed. If the 3394 upper bounds are present, we may do rank remapping. */ 3395 for (dim = 0; dim < ref->u.ar.dimen; ++dim) 3396 { 3397 if (!ref->u.ar.start[dim] 3398 || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) 3399 { 3400 gfc_error ("Lower bound has to be present at %L", 3401 &lvalue->where); 3402 return false; 3403 } 3404 if (ref->u.ar.stride[dim]) 3405 { 3406 gfc_error ("Stride must not be present at %L", 3407 &lvalue->where); 3408 return false; 3409 } 3410 3411 if (dim == 0) 3412 rank_remap = (ref->u.ar.end[dim] != NULL); 3413 else 3414 { 3415 if ((rank_remap && !ref->u.ar.end[dim]) 3416 || (!rank_remap && ref->u.ar.end[dim])) 3417 { 3418 gfc_error ("Either all or none of the upper bounds" 3419 " must be specified at %L", &lvalue->where); 3420 return false; 3421 } 3422 } 3423 } 3424 } 3425 } 3426 3427 is_pure = gfc_pure (NULL); 3428 is_implicit_pure = gfc_implicit_pure (NULL); 3429 3430 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, 3431 kind, etc for lvalue and rvalue must match, and rvalue must be a 3432 pure variable if we're in a pure function. */ 3433 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) 3434 return true; 3435 3436 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ 3437 if (lvalue->expr_type == EXPR_VARIABLE 3438 && gfc_is_coindexed (lvalue)) 3439 { 3440 gfc_ref *ref; 3441 for (ref = lvalue->ref; ref; ref = ref->next) 3442 if (ref->type == REF_ARRAY && ref->u.ar.codimen) 3443 { 3444 gfc_error ("Pointer object at %L shall not have a coindex", 3445 &lvalue->where); 3446 return false; 3447 } 3448 } 3449 3450 /* Checks on rvalue for procedure pointer assignments. */ 3451 if (proc_pointer) 3452 { 3453 char err[200]; 3454 gfc_symbol *s1,*s2; 3455 gfc_component *comp; 3456 const char *name; 3457 3458 attr = gfc_expr_attr (rvalue); 3459 if (!((rvalue->expr_type == EXPR_NULL) 3460 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) 3461 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) 3462 || (rvalue->expr_type == EXPR_VARIABLE 3463 && attr.flavor == FL_PROCEDURE))) 3464 { 3465 gfc_error ("Invalid procedure pointer assignment at %L", 3466 &rvalue->where); 3467 return false; 3468 } 3469 if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) 3470 { 3471 /* Check for intrinsics. */ 3472 gfc_symbol *sym = rvalue->symtree->n.sym; 3473 if (!sym->attr.intrinsic 3474 && (gfc_is_intrinsic (sym, 0, sym->declared_at) 3475 || gfc_is_intrinsic (sym, 1, sym->declared_at))) 3476 { 3477 sym->attr.intrinsic = 1; 3478 gfc_resolve_intrinsic (sym, &rvalue->where); 3479 attr = gfc_expr_attr (rvalue); 3480 } 3481 /* Check for result of embracing function. */ 3482 if (sym->attr.function && sym->result == sym) 3483 { 3484 gfc_namespace *ns; 3485 3486 for (ns = gfc_current_ns; ns; ns = ns->parent) 3487 if (sym == ns->proc_name) 3488 { 3489 gfc_error ("Function result %qs is invalid as proc-target " 3490 "in procedure pointer assignment at %L", 3491 sym->name, &rvalue->where); 3492 return false; 3493 } 3494 } 3495 } 3496 if (attr.abstract) 3497 { 3498 gfc_error ("Abstract interface %qs is invalid " 3499 "in procedure pointer assignment at %L", 3500 rvalue->symtree->name, &rvalue->where); 3501 return false; 3502 } 3503 /* Check for F08:C729. */ 3504 if (attr.flavor == FL_PROCEDURE) 3505 { 3506 if (attr.proc == PROC_ST_FUNCTION) 3507 { 3508 gfc_error ("Statement function %qs is invalid " 3509 "in procedure pointer assignment at %L", 3510 rvalue->symtree->name, &rvalue->where); 3511 return false; 3512 } 3513 if (attr.proc == PROC_INTERNAL && 3514 !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs " 3515 "is invalid in procedure pointer assignment " 3516 "at %L", rvalue->symtree->name, &rvalue->where)) 3517 return false; 3518 if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, 3519 attr.subroutine) == 0) 3520 { 3521 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " 3522 "assignment", rvalue->symtree->name, &rvalue->where); 3523 return false; 3524 } 3525 } 3526 /* Check for F08:C730. */ 3527 if (attr.elemental && !attr.intrinsic) 3528 { 3529 gfc_error ("Nonintrinsic elemental procedure %qs is invalid " 3530 "in procedure pointer assignment at %L", 3531 rvalue->symtree->name, &rvalue->where); 3532 return false; 3533 } 3534 3535 /* Ensure that the calling convention is the same. As other attributes 3536 such as DLLEXPORT may differ, one explicitly only tests for the 3537 calling conventions. */ 3538 if (rvalue->expr_type == EXPR_VARIABLE 3539 && lvalue->symtree->n.sym->attr.ext_attr 3540 != rvalue->symtree->n.sym->attr.ext_attr) 3541 { 3542 symbol_attribute calls; 3543 3544 calls.ext_attr = 0; 3545 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL); 3546 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL); 3547 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL); 3548 3549 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) 3550 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) 3551 { 3552 gfc_error ("Mismatch in the procedure pointer assignment " 3553 "at %L: mismatch in the calling convention", 3554 &rvalue->where); 3555 return false; 3556 } 3557 } 3558 3559 comp = gfc_get_proc_ptr_comp (lvalue); 3560 if (comp) 3561 s1 = comp->ts.interface; 3562 else 3563 { 3564 s1 = lvalue->symtree->n.sym; 3565 if (s1->ts.interface) 3566 s1 = s1->ts.interface; 3567 } 3568 3569 comp = gfc_get_proc_ptr_comp (rvalue); 3570 if (comp) 3571 { 3572 if (rvalue->expr_type == EXPR_FUNCTION) 3573 { 3574 s2 = comp->ts.interface->result; 3575 name = s2->name; 3576 } 3577 else 3578 { 3579 s2 = comp->ts.interface; 3580 name = comp->name; 3581 } 3582 } 3583 else if (rvalue->expr_type == EXPR_FUNCTION) 3584 { 3585 if (rvalue->value.function.esym) 3586 s2 = rvalue->value.function.esym->result; 3587 else 3588 s2 = rvalue->symtree->n.sym->result; 3589 3590 name = s2->name; 3591 } 3592 else 3593 { 3594 s2 = rvalue->symtree->n.sym; 3595 name = s2->name; 3596 } 3597 3598 if (s2 && s2->attr.proc_pointer && s2->ts.interface) 3599 s2 = s2->ts.interface; 3600 3601 if (s1 == s2 || !s1 || !s2) 3602 return true; 3603 3604 /* F08:7.2.2.4 (4) */ 3605 if (s1->attr.if_source == IFSRC_UNKNOWN 3606 && gfc_explicit_interface_required (s2, err, sizeof(err))) 3607 { 3608 gfc_error ("Explicit interface required for %qs at %L: %s", 3609 s1->name, &lvalue->where, err); 3610 return false; 3611 } 3612 if (s2->attr.if_source == IFSRC_UNKNOWN 3613 && gfc_explicit_interface_required (s1, err, sizeof(err))) 3614 { 3615 gfc_error ("Explicit interface required for %qs at %L: %s", 3616 s2->name, &rvalue->where, err); 3617 return false; 3618 } 3619 3620 if (!gfc_compare_interfaces (s1, s2, name, 0, 1, 3621 err, sizeof(err), NULL, NULL)) 3622 { 3623 gfc_error ("Interface mismatch in procedure pointer assignment " 3624 "at %L: %s", &rvalue->where, err); 3625 return false; 3626 } 3627 3628 /* Check F2008Cor2, C729. */ 3629 if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN 3630 && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) 3631 { 3632 gfc_error ("Procedure pointer target %qs at %L must be either an " 3633 "intrinsic, host or use associated, referenced or have " 3634 "the EXTERNAL attribute", s2->name, &rvalue->where); 3635 return false; 3636 } 3637 3638 return true; 3639 } 3640 3641 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) 3642 { 3643 /* Check for F03:C717. */ 3644 if (UNLIMITED_POLY (rvalue) 3645 && !(UNLIMITED_POLY (lvalue) 3646 || (lvalue->ts.type == BT_DERIVED 3647 && (lvalue->ts.u.derived->attr.is_bind_c 3648 || lvalue->ts.u.derived->attr.sequence)))) 3649 gfc_error ("Data-pointer-object at %L must be unlimited " 3650 "polymorphic, or of a type with the BIND or SEQUENCE " 3651 "attribute, to be compatible with an unlimited " 3652 "polymorphic target", &lvalue->where); 3653 else 3654 gfc_error ("Different types in pointer assignment at %L; " 3655 "attempted assignment of %s to %s", &lvalue->where, 3656 gfc_typename (&rvalue->ts), 3657 gfc_typename (&lvalue->ts)); 3658 return false; 3659 } 3660 3661 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) 3662 { 3663 gfc_error ("Different kind type parameters in pointer " 3664 "assignment at %L", &lvalue->where); 3665 return false; 3666 } 3667 3668 if (lvalue->rank != rvalue->rank && !rank_remap) 3669 { 3670 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); 3671 return false; 3672 } 3673 3674 /* Make sure the vtab is present. */ 3675 if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)) 3676 gfc_find_vtab (&rvalue->ts); 3677 3678 /* Check rank remapping. */ 3679 if (rank_remap) 3680 { 3681 mpz_t lsize, rsize; 3682 3683 /* If this can be determined, check that the target must be at least as 3684 large as the pointer assigned to it is. */ 3685 if (gfc_array_size (lvalue, &lsize) 3686 && gfc_array_size (rvalue, &rsize) 3687 && mpz_cmp (rsize, lsize) < 0) 3688 { 3689 gfc_error ("Rank remapping target is smaller than size of the" 3690 " pointer (%ld < %ld) at %L", 3691 mpz_get_si (rsize), mpz_get_si (lsize), 3692 &lvalue->where); 3693 return false; 3694 } 3695 3696 /* The target must be either rank one or it must be simply contiguous 3697 and F2008 must be allowed. */ 3698 if (rvalue->rank != 1) 3699 { 3700 if (!gfc_is_simply_contiguous (rvalue, true)) 3701 { 3702 gfc_error ("Rank remapping target must be rank 1 or" 3703 " simply contiguous at %L", &rvalue->where); 3704 return false; 3705 } 3706 if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " 3707 "rank 1 at %L", &rvalue->where)) 3708 return false; 3709 } 3710 } 3711 3712 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ 3713 if (rvalue->expr_type == EXPR_NULL) 3714 return true; 3715 3716 if (lvalue->ts.type == BT_CHARACTER) 3717 { 3718 bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); 3719 if (!t) 3720 return false; 3721 } 3722 3723 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) 3724 lvalue->symtree->n.sym->attr.subref_array_pointer = 1; 3725 3726 attr = gfc_expr_attr (rvalue); 3727 3728 if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) 3729 { 3730 gfc_error ("Target expression in pointer assignment " 3731 "at %L must deliver a pointer result", 3732 &rvalue->where); 3733 return false; 3734 } 3735 3736 if (!attr.target && !attr.pointer) 3737 { 3738 gfc_error ("Pointer assignment target is neither TARGET " 3739 "nor POINTER at %L", &rvalue->where); 3740 return false; 3741 } 3742 3743 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) 3744 { 3745 gfc_error ("Bad target in pointer assignment in PURE " 3746 "procedure at %L", &rvalue->where); 3747 } 3748 3749 if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) 3750 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 3751 3752 if (gfc_has_vector_index (rvalue)) 3753 { 3754 gfc_error ("Pointer assignment with vector subscript " 3755 "on rhs at %L", &rvalue->where); 3756 return false; 3757 } 3758 3759 if (attr.is_protected && attr.use_assoc 3760 && !(attr.pointer || attr.proc_pointer)) 3761 { 3762 gfc_error ("Pointer assignment target has PROTECTED " 3763 "attribute at %L", &rvalue->where); 3764 return false; 3765 } 3766 3767 /* F2008, C725. For PURE also C1283. */ 3768 if (rvalue->expr_type == EXPR_VARIABLE 3769 && gfc_is_coindexed (rvalue)) 3770 { 3771 gfc_ref *ref; 3772 for (ref = rvalue->ref; ref; ref = ref->next) 3773 if (ref->type == REF_ARRAY && ref->u.ar.codimen) 3774 { 3775 gfc_error ("Data target at %L shall not have a coindex", 3776 &rvalue->where); 3777 return false; 3778 } 3779 } 3780 3781 /* Warn if it is the LHS pointer may lives longer than the RHS target. */ 3782 if (warn_target_lifetime 3783 && rvalue->expr_type == EXPR_VARIABLE 3784 && !rvalue->symtree->n.sym->attr.save 3785 && !attr.pointer && !rvalue->symtree->n.sym->attr.host_assoc 3786 && !rvalue->symtree->n.sym->attr.in_common 3787 && !rvalue->symtree->n.sym->attr.use_assoc 3788 && !rvalue->symtree->n.sym->attr.dummy) 3789 { 3790 bool warn; 3791 gfc_namespace *ns; 3792 3793 warn = lvalue->symtree->n.sym->attr.dummy 3794 || lvalue->symtree->n.sym->attr.result 3795 || lvalue->symtree->n.sym->attr.function 3796 || (lvalue->symtree->n.sym->attr.host_assoc 3797 && lvalue->symtree->n.sym->ns 3798 != rvalue->symtree->n.sym->ns) 3799 || lvalue->symtree->n.sym->attr.use_assoc 3800 || lvalue->symtree->n.sym->attr.in_common; 3801 3802 if (rvalue->symtree->n.sym->ns->proc_name 3803 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE 3804 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) 3805 for (ns = rvalue->symtree->n.sym->ns; 3806 ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; 3807 ns = ns->parent) 3808 if (ns->parent == lvalue->symtree->n.sym->ns) 3809 { 3810 warn = true; 3811 break; 3812 } 3813 3814 if (warn) 3815 gfc_warning (OPT_Wtarget_lifetime, 3816 "Pointer at %L in pointer assignment might outlive the " 3817 "pointer target", &lvalue->where); 3818 } 3819 3820 return true; 3821} 3822 3823 3824/* Relative of gfc_check_assign() except that the lvalue is a single 3825 symbol. Used for initialization assignments. */ 3826 3827bool 3828gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) 3829{ 3830 gfc_expr lvalue; 3831 bool r; 3832 bool pointer, proc_pointer; 3833 3834 memset (&lvalue, '\0', sizeof (gfc_expr)); 3835 3836 lvalue.expr_type = EXPR_VARIABLE; 3837 lvalue.ts = sym->ts; 3838 if (sym->as) 3839 lvalue.rank = sym->as->rank; 3840 lvalue.symtree = XCNEW (gfc_symtree); 3841 lvalue.symtree->n.sym = sym; 3842 lvalue.where = sym->declared_at; 3843 3844 if (comp) 3845 { 3846 lvalue.ref = gfc_get_ref (); 3847 lvalue.ref->type = REF_COMPONENT; 3848 lvalue.ref->u.c.component = comp; 3849 lvalue.ref->u.c.sym = sym; 3850 lvalue.ts = comp->ts; 3851 lvalue.rank = comp->as ? comp->as->rank : 0; 3852 lvalue.where = comp->loc; 3853 pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp) 3854 ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer; 3855 proc_pointer = comp->attr.proc_pointer; 3856 } 3857 else 3858 { 3859 pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym) 3860 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; 3861 proc_pointer = sym->attr.proc_pointer; 3862 } 3863 3864 if (pointer || proc_pointer) 3865 r = gfc_check_pointer_assign (&lvalue, rvalue); 3866 else 3867 { 3868 /* If a conversion function, e.g., __convert_i8_i4, was inserted 3869 into an array constructor, we should check if it can be reduced 3870 as an initialization expression. */ 3871 if (rvalue->expr_type == EXPR_FUNCTION 3872 && rvalue->value.function.isym 3873 && (rvalue->value.function.isym->conversion == 1)) 3874 gfc_check_init_expr (rvalue); 3875 3876 r = gfc_check_assign (&lvalue, rvalue, 1); 3877 } 3878 3879 free (lvalue.symtree); 3880 free (lvalue.ref); 3881 3882 if (!r) 3883 return r; 3884 3885 if (pointer && rvalue->expr_type != EXPR_NULL) 3886 { 3887 /* F08:C461. Additional checks for pointer initialization. */ 3888 symbol_attribute attr; 3889 attr = gfc_expr_attr (rvalue); 3890 if (attr.allocatable) 3891 { 3892 gfc_error ("Pointer initialization target at %L " 3893 "must not be ALLOCATABLE", &rvalue->where); 3894 return false; 3895 } 3896 if (!attr.target || attr.pointer) 3897 { 3898 gfc_error ("Pointer initialization target at %L " 3899 "must have the TARGET attribute", &rvalue->where); 3900 return false; 3901 } 3902 3903 if (!attr.save && rvalue->expr_type == EXPR_VARIABLE 3904 && rvalue->symtree->n.sym->ns->proc_name 3905 && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) 3906 { 3907 rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; 3908 attr.save = SAVE_IMPLICIT; 3909 } 3910 3911 if (!attr.save) 3912 { 3913 gfc_error ("Pointer initialization target at %L " 3914 "must have the SAVE attribute", &rvalue->where); 3915 return false; 3916 } 3917 } 3918 3919 if (proc_pointer && rvalue->expr_type != EXPR_NULL) 3920 { 3921 /* F08:C1220. Additional checks for procedure pointer initialization. */ 3922 symbol_attribute attr = gfc_expr_attr (rvalue); 3923 if (attr.proc_pointer) 3924 { 3925 gfc_error ("Procedure pointer initialization target at %L " 3926 "may not be a procedure pointer", &rvalue->where); 3927 return false; 3928 } 3929 } 3930 3931 return true; 3932} 3933 3934 3935/* Check for default initializer; sym->value is not enough 3936 as it is also set for EXPR_NULL of allocatables. */ 3937 3938bool 3939gfc_has_default_initializer (gfc_symbol *der) 3940{ 3941 gfc_component *c; 3942 3943 gcc_assert (der->attr.flavor == FL_DERIVED); 3944 for (c = der->components; c; c = c->next) 3945 if (c->ts.type == BT_DERIVED) 3946 { 3947 if (!c->attr.pointer 3948 && gfc_has_default_initializer (c->ts.u.derived)) 3949 return true; 3950 if (c->attr.pointer && c->initializer) 3951 return true; 3952 } 3953 else 3954 { 3955 if (c->initializer) 3956 return true; 3957 } 3958 3959 return false; 3960} 3961 3962 3963/* Get an expression for a default initializer. */ 3964 3965gfc_expr * 3966gfc_default_initializer (gfc_typespec *ts) 3967{ 3968 gfc_expr *init; 3969 gfc_component *comp; 3970 3971 /* See if we have a default initializer in this, but not in nested 3972 types (otherwise we could use gfc_has_default_initializer()). */ 3973 for (comp = ts->u.derived->components; comp; comp = comp->next) 3974 if (comp->initializer || comp->attr.allocatable 3975 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) 3976 && CLASS_DATA (comp)->attr.allocatable)) 3977 break; 3978 3979 if (!comp) 3980 return NULL; 3981 3982 init = gfc_get_structure_constructor_expr (ts->type, ts->kind, 3983 &ts->u.derived->declared_at); 3984 init->ts = *ts; 3985 3986 for (comp = ts->u.derived->components; comp; comp = comp->next) 3987 { 3988 gfc_constructor *ctor = gfc_constructor_get(); 3989 3990 if (comp->initializer) 3991 { 3992 ctor->expr = gfc_copy_expr (comp->initializer); 3993 if ((comp->ts.type != comp->initializer->ts.type 3994 || comp->ts.kind != comp->initializer->ts.kind) 3995 && !comp->attr.pointer && !comp->attr.proc_pointer) 3996 gfc_convert_type_warn (ctor->expr, &comp->ts, 2, false); 3997 } 3998 3999 if (comp->attr.allocatable 4000 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) 4001 { 4002 ctor->expr = gfc_get_expr (); 4003 ctor->expr->expr_type = EXPR_NULL; 4004 ctor->expr->ts = comp->ts; 4005 } 4006 4007 gfc_constructor_append (&init->value.constructor, ctor); 4008 } 4009 4010 return init; 4011} 4012 4013 4014/* Given a symbol, create an expression node with that symbol as a 4015 variable. If the symbol is array valued, setup a reference of the 4016 whole array. */ 4017 4018gfc_expr * 4019gfc_get_variable_expr (gfc_symtree *var) 4020{ 4021 gfc_expr *e; 4022 4023 e = gfc_get_expr (); 4024 e->expr_type = EXPR_VARIABLE; 4025 e->symtree = var; 4026 e->ts = var->n.sym->ts; 4027 4028 if (var->n.sym->attr.flavor != FL_PROCEDURE 4029 && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) 4030 || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym) 4031 && CLASS_DATA (var->n.sym)->as))) 4032 { 4033 e->rank = var->n.sym->ts.type == BT_CLASS 4034 ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; 4035 e->ref = gfc_get_ref (); 4036 e->ref->type = REF_ARRAY; 4037 e->ref->u.ar.type = AR_FULL; 4038 e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS 4039 ? CLASS_DATA (var->n.sym)->as 4040 : var->n.sym->as); 4041 } 4042 4043 return e; 4044} 4045 4046 4047/* Adds a full array reference to an expression, as needed. */ 4048 4049void 4050gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) 4051{ 4052 gfc_ref *ref; 4053 for (ref = e->ref; ref; ref = ref->next) 4054 if (!ref->next) 4055 break; 4056 if (ref) 4057 { 4058 ref->next = gfc_get_ref (); 4059 ref = ref->next; 4060 } 4061 else 4062 { 4063 e->ref = gfc_get_ref (); 4064 ref = e->ref; 4065 } 4066 ref->type = REF_ARRAY; 4067 ref->u.ar.type = AR_FULL; 4068 ref->u.ar.dimen = e->rank; 4069 ref->u.ar.where = e->where; 4070 ref->u.ar.as = as; 4071} 4072 4073 4074gfc_expr * 4075gfc_lval_expr_from_sym (gfc_symbol *sym) 4076{ 4077 gfc_expr *lval; 4078 lval = gfc_get_expr (); 4079 lval->expr_type = EXPR_VARIABLE; 4080 lval->where = sym->declared_at; 4081 lval->ts = sym->ts; 4082 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); 4083 4084 /* It will always be a full array. */ 4085 lval->rank = sym->as ? sym->as->rank : 0; 4086 if (lval->rank) 4087 gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ? 4088 CLASS_DATA (sym)->as : sym->as); 4089 return lval; 4090} 4091 4092 4093/* Returns the array_spec of a full array expression. A NULL is 4094 returned otherwise. */ 4095gfc_array_spec * 4096gfc_get_full_arrayspec_from_expr (gfc_expr *expr) 4097{ 4098 gfc_array_spec *as; 4099 gfc_ref *ref; 4100 4101 if (expr->rank == 0) 4102 return NULL; 4103 4104 /* Follow any component references. */ 4105 if (expr->expr_type == EXPR_VARIABLE 4106 || expr->expr_type == EXPR_CONSTANT) 4107 { 4108 as = expr->symtree->n.sym->as; 4109 for (ref = expr->ref; ref; ref = ref->next) 4110 { 4111 switch (ref->type) 4112 { 4113 case REF_COMPONENT: 4114 as = ref->u.c.component->as; 4115 continue; 4116 4117 case REF_SUBSTRING: 4118 continue; 4119 4120 case REF_ARRAY: 4121 { 4122 switch (ref->u.ar.type) 4123 { 4124 case AR_ELEMENT: 4125 case AR_SECTION: 4126 case AR_UNKNOWN: 4127 as = NULL; 4128 continue; 4129 4130 case AR_FULL: 4131 break; 4132 } 4133 break; 4134 } 4135 } 4136 } 4137 } 4138 else 4139 as = NULL; 4140 4141 return as; 4142} 4143 4144 4145/* General expression traversal function. */ 4146 4147bool 4148gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, 4149 bool (*func)(gfc_expr *, gfc_symbol *, int*), 4150 int f) 4151{ 4152 gfc_array_ref ar; 4153 gfc_ref *ref; 4154 gfc_actual_arglist *args; 4155 gfc_constructor *c; 4156 int i; 4157 4158 if (!expr) 4159 return false; 4160 4161 if ((*func) (expr, sym, &f)) 4162 return true; 4163 4164 if (expr->ts.type == BT_CHARACTER 4165 && expr->ts.u.cl 4166 && expr->ts.u.cl->length 4167 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT 4168 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) 4169 return true; 4170 4171 switch (expr->expr_type) 4172 { 4173 case EXPR_PPC: 4174 case EXPR_COMPCALL: 4175 case EXPR_FUNCTION: 4176 for (args = expr->value.function.actual; args; args = args->next) 4177 { 4178 if (gfc_traverse_expr (args->expr, sym, func, f)) 4179 return true; 4180 } 4181 break; 4182 4183 case EXPR_VARIABLE: 4184 case EXPR_CONSTANT: 4185 case EXPR_NULL: 4186 case EXPR_SUBSTRING: 4187 break; 4188 4189 case EXPR_STRUCTURE: 4190 case EXPR_ARRAY: 4191 for (c = gfc_constructor_first (expr->value.constructor); 4192 c; c = gfc_constructor_next (c)) 4193 { 4194 if (gfc_traverse_expr (c->expr, sym, func, f)) 4195 return true; 4196 if (c->iterator) 4197 { 4198 if (gfc_traverse_expr (c->iterator->var, sym, func, f)) 4199 return true; 4200 if (gfc_traverse_expr (c->iterator->start, sym, func, f)) 4201 return true; 4202 if (gfc_traverse_expr (c->iterator->end, sym, func, f)) 4203 return true; 4204 if (gfc_traverse_expr (c->iterator->step, sym, func, f)) 4205 return true; 4206 } 4207 } 4208 break; 4209 4210 case EXPR_OP: 4211 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) 4212 return true; 4213 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) 4214 return true; 4215 break; 4216 4217 default: 4218 gcc_unreachable (); 4219 break; 4220 } 4221 4222 ref = expr->ref; 4223 while (ref != NULL) 4224 { 4225 switch (ref->type) 4226 { 4227 case REF_ARRAY: 4228 ar = ref->u.ar; 4229 for (i = 0; i < GFC_MAX_DIMENSIONS; i++) 4230 { 4231 if (gfc_traverse_expr (ar.start[i], sym, func, f)) 4232 return true; 4233 if (gfc_traverse_expr (ar.end[i], sym, func, f)) 4234 return true; 4235 if (gfc_traverse_expr (ar.stride[i], sym, func, f)) 4236 return true; 4237 } 4238 break; 4239 4240 case REF_SUBSTRING: 4241 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) 4242 return true; 4243 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) 4244 return true; 4245 break; 4246 4247 case REF_COMPONENT: 4248 if (ref->u.c.component->ts.type == BT_CHARACTER 4249 && ref->u.c.component->ts.u.cl 4250 && ref->u.c.component->ts.u.cl->length 4251 && ref->u.c.component->ts.u.cl->length->expr_type 4252 != EXPR_CONSTANT 4253 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, 4254 sym, func, f)) 4255 return true; 4256 4257 if (ref->u.c.component->as) 4258 for (i = 0; i < ref->u.c.component->as->rank 4259 + ref->u.c.component->as->corank; i++) 4260 { 4261 if (gfc_traverse_expr (ref->u.c.component->as->lower[i], 4262 sym, func, f)) 4263 return true; 4264 if (gfc_traverse_expr (ref->u.c.component->as->upper[i], 4265 sym, func, f)) 4266 return true; 4267 } 4268 break; 4269 4270 default: 4271 gcc_unreachable (); 4272 } 4273 ref = ref->next; 4274 } 4275 return false; 4276} 4277 4278/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ 4279 4280static bool 4281expr_set_symbols_referenced (gfc_expr *expr, 4282 gfc_symbol *sym ATTRIBUTE_UNUSED, 4283 int *f ATTRIBUTE_UNUSED) 4284{ 4285 if (expr->expr_type != EXPR_VARIABLE) 4286 return false; 4287 gfc_set_sym_referenced (expr->symtree->n.sym); 4288 return false; 4289} 4290 4291void 4292gfc_expr_set_symbols_referenced (gfc_expr *expr) 4293{ 4294 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); 4295} 4296 4297 4298/* Determine if an expression is a procedure pointer component and return 4299 the component in that case. Otherwise return NULL. */ 4300 4301gfc_component * 4302gfc_get_proc_ptr_comp (gfc_expr *expr) 4303{ 4304 gfc_ref *ref; 4305 4306 if (!expr || !expr->ref) 4307 return NULL; 4308 4309 ref = expr->ref; 4310 while (ref->next) 4311 ref = ref->next; 4312 4313 if (ref->type == REF_COMPONENT 4314 && ref->u.c.component->attr.proc_pointer) 4315 return ref->u.c.component; 4316 4317 return NULL; 4318} 4319 4320 4321/* Determine if an expression is a procedure pointer component. */ 4322 4323bool 4324gfc_is_proc_ptr_comp (gfc_expr *expr) 4325{ 4326 return (gfc_get_proc_ptr_comp (expr) != NULL); 4327} 4328 4329 4330/* Determine if an expression is a function with an allocatable class scalar 4331 result. */ 4332bool 4333gfc_is_alloc_class_scalar_function (gfc_expr *expr) 4334{ 4335 if (expr->expr_type == EXPR_FUNCTION 4336 && expr->value.function.esym 4337 && expr->value.function.esym->result 4338 && expr->value.function.esym->result->ts.type == BT_CLASS 4339 && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension 4340 && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) 4341 return true; 4342 4343 return false; 4344} 4345 4346 4347/* Determine if an expression is a function with an allocatable class array 4348 result. */ 4349bool 4350gfc_is_alloc_class_array_function (gfc_expr *expr) 4351{ 4352 if (expr->expr_type == EXPR_FUNCTION 4353 && expr->value.function.esym 4354 && expr->value.function.esym->result 4355 && expr->value.function.esym->result->ts.type == BT_CLASS 4356 && CLASS_DATA (expr->value.function.esym->result)->attr.dimension 4357 && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) 4358 return true; 4359 4360 return false; 4361} 4362 4363 4364/* Walk an expression tree and check each variable encountered for being typed. 4365 If strict is not set, a top-level variable is tolerated untyped in -std=gnu 4366 mode as is a basic arithmetic expression using those; this is for things in 4367 legacy-code like: 4368 4369 INTEGER :: arr(n), n 4370 INTEGER :: arr(n + 1), n 4371 4372 The namespace is needed for IMPLICIT typing. */ 4373 4374static gfc_namespace* check_typed_ns; 4375 4376static bool 4377expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, 4378 int* f ATTRIBUTE_UNUSED) 4379{ 4380 bool t; 4381 4382 if (e->expr_type != EXPR_VARIABLE) 4383 return false; 4384 4385 gcc_assert (e->symtree); 4386 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, 4387 true, e->where); 4388 4389 return (!t); 4390} 4391 4392bool 4393gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) 4394{ 4395 bool error_found; 4396 4397 /* If this is a top-level variable or EXPR_OP, do the check with strict given 4398 to us. */ 4399 if (!strict) 4400 { 4401 if (e->expr_type == EXPR_VARIABLE && !e->ref) 4402 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); 4403 4404 if (e->expr_type == EXPR_OP) 4405 { 4406 bool t = true; 4407 4408 gcc_assert (e->value.op.op1); 4409 t = gfc_expr_check_typed (e->value.op.op1, ns, strict); 4410 4411 if (t && e->value.op.op2) 4412 t = gfc_expr_check_typed (e->value.op.op2, ns, strict); 4413 4414 return t; 4415 } 4416 } 4417 4418 /* Otherwise, walk the expression and do it strictly. */ 4419 check_typed_ns = ns; 4420 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); 4421 4422 return error_found ? false : true; 4423} 4424 4425 4426bool 4427gfc_ref_this_image (gfc_ref *ref) 4428{ 4429 int n; 4430 4431 gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0); 4432 4433 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) 4434 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) 4435 return false; 4436 4437 return true; 4438} 4439 4440 4441bool 4442gfc_is_coindexed (gfc_expr *e) 4443{ 4444 gfc_ref *ref; 4445 4446 for (ref = e->ref; ref; ref = ref->next) 4447 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 4448 return !gfc_ref_this_image (ref); 4449 4450 return false; 4451} 4452 4453 4454/* Coarrays are variables with a corank but not being coindexed. However, also 4455 the following is a coarray: A subobject of a coarray is a coarray if it does 4456 not have any cosubscripts, vector subscripts, allocatable component 4457 selection, or pointer component selection. (F2008, 2.4.7) */ 4458 4459bool 4460gfc_is_coarray (gfc_expr *e) 4461{ 4462 gfc_ref *ref; 4463 gfc_symbol *sym; 4464 gfc_component *comp; 4465 bool coindexed; 4466 bool coarray; 4467 int i; 4468 4469 if (e->expr_type != EXPR_VARIABLE) 4470 return false; 4471 4472 coindexed = false; 4473 sym = e->symtree->n.sym; 4474 4475 if (sym->ts.type == BT_CLASS && sym->attr.class_ok) 4476 coarray = CLASS_DATA (sym)->attr.codimension; 4477 else 4478 coarray = sym->attr.codimension; 4479 4480 for (ref = e->ref; ref; ref = ref->next) 4481 switch (ref->type) 4482 { 4483 case REF_COMPONENT: 4484 comp = ref->u.c.component; 4485 if (comp->ts.type == BT_CLASS && comp->attr.class_ok 4486 && (CLASS_DATA (comp)->attr.class_pointer 4487 || CLASS_DATA (comp)->attr.allocatable)) 4488 { 4489 coindexed = false; 4490 coarray = CLASS_DATA (comp)->attr.codimension; 4491 } 4492 else if (comp->attr.pointer || comp->attr.allocatable) 4493 { 4494 coindexed = false; 4495 coarray = comp->attr.codimension; 4496 } 4497 break; 4498 4499 case REF_ARRAY: 4500 if (!coarray) 4501 break; 4502 4503 if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) 4504 { 4505 coindexed = true; 4506 break; 4507 } 4508 4509 for (i = 0; i < ref->u.ar.dimen; i++) 4510 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 4511 { 4512 coarray = false; 4513 break; 4514 } 4515 break; 4516 4517 case REF_SUBSTRING: 4518 break; 4519 } 4520 4521 return coarray && !coindexed; 4522} 4523 4524 4525int 4526gfc_get_corank (gfc_expr *e) 4527{ 4528 int corank; 4529 gfc_ref *ref; 4530 4531 if (!gfc_is_coarray (e)) 4532 return 0; 4533 4534 if (e->ts.type == BT_CLASS && e->ts.u.derived->components) 4535 corank = e->ts.u.derived->components->as 4536 ? e->ts.u.derived->components->as->corank : 0; 4537 else 4538 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; 4539 4540 for (ref = e->ref; ref; ref = ref->next) 4541 { 4542 if (ref->type == REF_ARRAY) 4543 corank = ref->u.ar.as->corank; 4544 gcc_assert (ref->type != REF_SUBSTRING); 4545 } 4546 4547 return corank; 4548} 4549 4550 4551/* Check whether the expression has an ultimate allocatable component. 4552 Being itself allocatable does not count. */ 4553bool 4554gfc_has_ultimate_allocatable (gfc_expr *e) 4555{ 4556 gfc_ref *ref, *last = NULL; 4557 4558 if (e->expr_type != EXPR_VARIABLE) 4559 return false; 4560 4561 for (ref = e->ref; ref; ref = ref->next) 4562 if (ref->type == REF_COMPONENT) 4563 last = ref; 4564 4565 if (last && last->u.c.component->ts.type == BT_CLASS) 4566 return CLASS_DATA (last->u.c.component)->attr.alloc_comp; 4567 else if (last && last->u.c.component->ts.type == BT_DERIVED) 4568 return last->u.c.component->ts.u.derived->attr.alloc_comp; 4569 else if (last) 4570 return false; 4571 4572 if (e->ts.type == BT_CLASS) 4573 return CLASS_DATA (e)->attr.alloc_comp; 4574 else if (e->ts.type == BT_DERIVED) 4575 return e->ts.u.derived->attr.alloc_comp; 4576 else 4577 return false; 4578} 4579 4580 4581/* Check whether the expression has an pointer component. 4582 Being itself a pointer does not count. */ 4583bool 4584gfc_has_ultimate_pointer (gfc_expr *e) 4585{ 4586 gfc_ref *ref, *last = NULL; 4587 4588 if (e->expr_type != EXPR_VARIABLE) 4589 return false; 4590 4591 for (ref = e->ref; ref; ref = ref->next) 4592 if (ref->type == REF_COMPONENT) 4593 last = ref; 4594 4595 if (last && last->u.c.component->ts.type == BT_CLASS) 4596 return CLASS_DATA (last->u.c.component)->attr.pointer_comp; 4597 else if (last && last->u.c.component->ts.type == BT_DERIVED) 4598 return last->u.c.component->ts.u.derived->attr.pointer_comp; 4599 else if (last) 4600 return false; 4601 4602 if (e->ts.type == BT_CLASS) 4603 return CLASS_DATA (e)->attr.pointer_comp; 4604 else if (e->ts.type == BT_DERIVED) 4605 return e->ts.u.derived->attr.pointer_comp; 4606 else 4607 return false; 4608} 4609 4610 4611/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. 4612 Note: A scalar is not regarded as "simply contiguous" by the standard. 4613 if bool is not strict, some further checks are done - for instance, 4614 a "(::1)" is accepted. */ 4615 4616bool 4617gfc_is_simply_contiguous (gfc_expr *expr, bool strict) 4618{ 4619 bool colon; 4620 int i; 4621 gfc_array_ref *ar = NULL; 4622 gfc_ref *ref, *part_ref = NULL; 4623 gfc_symbol *sym; 4624 4625 if (expr->expr_type == EXPR_FUNCTION) 4626 return expr->value.function.esym 4627 ? expr->value.function.esym->result->attr.contiguous : false; 4628 else if (expr->expr_type != EXPR_VARIABLE) 4629 return false; 4630 4631 if (expr->rank == 0) 4632 return false; 4633 4634 for (ref = expr->ref; ref; ref = ref->next) 4635 { 4636 if (ar) 4637 return false; /* Array shall be last part-ref. */ 4638 4639 if (ref->type == REF_COMPONENT) 4640 part_ref = ref; 4641 else if (ref->type == REF_SUBSTRING) 4642 return false; 4643 else if (ref->u.ar.type != AR_ELEMENT) 4644 ar = &ref->u.ar; 4645 } 4646 4647 sym = expr->symtree->n.sym; 4648 if (expr->ts.type != BT_CLASS 4649 && ((part_ref 4650 && !part_ref->u.c.component->attr.contiguous 4651 && part_ref->u.c.component->attr.pointer) 4652 || (!part_ref 4653 && !sym->attr.contiguous 4654 && (sym->attr.pointer 4655 || sym->as->type == AS_ASSUMED_RANK 4656 || sym->as->type == AS_ASSUMED_SHAPE)))) 4657 return false; 4658 4659 if (!ar || ar->type == AR_FULL) 4660 return true; 4661 4662 gcc_assert (ar->type == AR_SECTION); 4663 4664 /* Check for simply contiguous array */ 4665 colon = true; 4666 for (i = 0; i < ar->dimen; i++) 4667 { 4668 if (ar->dimen_type[i] == DIMEN_VECTOR) 4669 return false; 4670 4671 if (ar->dimen_type[i] == DIMEN_ELEMENT) 4672 { 4673 colon = false; 4674 continue; 4675 } 4676 4677 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); 4678 4679 4680 /* If the previous section was not contiguous, that's an error, 4681 unless we have effective only one element and checking is not 4682 strict. */ 4683 if (!colon && (strict || !ar->start[i] || !ar->end[i] 4684 || ar->start[i]->expr_type != EXPR_CONSTANT 4685 || ar->end[i]->expr_type != EXPR_CONSTANT 4686 || mpz_cmp (ar->start[i]->value.integer, 4687 ar->end[i]->value.integer) != 0)) 4688 return false; 4689 4690 /* Following the standard, "(::1)" or - if known at compile time - 4691 "(lbound:ubound)" are not simply contiguous; if strict 4692 is false, they are regarded as simply contiguous. */ 4693 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT 4694 || ar->stride[i]->ts.type != BT_INTEGER 4695 || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) 4696 return false; 4697 4698 if (ar->start[i] 4699 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT 4700 || !ar->as->lower[i] 4701 || ar->as->lower[i]->expr_type != EXPR_CONSTANT 4702 || mpz_cmp (ar->start[i]->value.integer, 4703 ar->as->lower[i]->value.integer) != 0)) 4704 colon = false; 4705 4706 if (ar->end[i] 4707 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT 4708 || !ar->as->upper[i] 4709 || ar->as->upper[i]->expr_type != EXPR_CONSTANT 4710 || mpz_cmp (ar->end[i]->value.integer, 4711 ar->as->upper[i]->value.integer) != 0)) 4712 colon = false; 4713 } 4714 4715 return true; 4716} 4717 4718 4719/* Build call to an intrinsic procedure. The number of arguments has to be 4720 passed (rather than ending the list with a NULL value) because we may 4721 want to add arguments but with a NULL-expression. */ 4722 4723gfc_expr* 4724gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, 4725 locus where, unsigned numarg, ...) 4726{ 4727 gfc_expr* result; 4728 gfc_actual_arglist* atail; 4729 gfc_intrinsic_sym* isym; 4730 va_list ap; 4731 unsigned i; 4732 const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name); 4733 4734 isym = gfc_intrinsic_function_by_id (id); 4735 gcc_assert (isym); 4736 4737 result = gfc_get_expr (); 4738 result->expr_type = EXPR_FUNCTION; 4739 result->ts = isym->ts; 4740 result->where = where; 4741 result->value.function.name = mangled_name; 4742 result->value.function.isym = isym; 4743 4744 gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); 4745 gfc_commit_symbol (result->symtree->n.sym); 4746 gcc_assert (result->symtree 4747 && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE 4748 || result->symtree->n.sym->attr.flavor == FL_UNKNOWN)); 4749 result->symtree->n.sym->intmod_sym_id = id; 4750 result->symtree->n.sym->attr.flavor = FL_PROCEDURE; 4751 result->symtree->n.sym->attr.intrinsic = 1; 4752 result->symtree->n.sym->attr.artificial = 1; 4753 4754 va_start (ap, numarg); 4755 atail = NULL; 4756 for (i = 0; i < numarg; ++i) 4757 { 4758 if (atail) 4759 { 4760 atail->next = gfc_get_actual_arglist (); 4761 atail = atail->next; 4762 } 4763 else 4764 atail = result->value.function.actual = gfc_get_actual_arglist (); 4765 4766 atail->expr = va_arg (ap, gfc_expr*); 4767 } 4768 va_end (ap); 4769 4770 return result; 4771} 4772 4773 4774/* Check if an expression may appear in a variable definition context 4775 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). 4776 This is called from the various places when resolving 4777 the pieces that make up such a context. 4778 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do 4779 variables), some checks are not performed. 4780 4781 Optionally, a possible error message can be suppressed if context is NULL 4782 and just the return status (true / false) be requested. */ 4783 4784bool 4785gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, 4786 bool own_scope, const char* context) 4787{ 4788 gfc_symbol* sym = NULL; 4789 bool is_pointer; 4790 bool check_intentin; 4791 bool ptr_component; 4792 symbol_attribute attr; 4793 gfc_ref* ref; 4794 int i; 4795 4796 if (e->expr_type == EXPR_VARIABLE) 4797 { 4798 gcc_assert (e->symtree); 4799 sym = e->symtree->n.sym; 4800 } 4801 else if (e->expr_type == EXPR_FUNCTION) 4802 { 4803 gcc_assert (e->symtree); 4804 sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; 4805 } 4806 4807 attr = gfc_expr_attr (e); 4808 if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) 4809 { 4810 if (!(gfc_option.allow_std & GFC_STD_F2008)) 4811 { 4812 if (context) 4813 gfc_error ("Fortran 2008: Pointer functions in variable definition" 4814 " context (%s) at %L", context, &e->where); 4815 return false; 4816 } 4817 } 4818 else if (e->expr_type != EXPR_VARIABLE) 4819 { 4820 if (context) 4821 gfc_error ("Non-variable expression in variable definition context (%s)" 4822 " at %L", context, &e->where); 4823 return false; 4824 } 4825 4826 if (!pointer && sym->attr.flavor == FL_PARAMETER) 4827 { 4828 if (context) 4829 gfc_error ("Named constant %qs in variable definition context (%s)" 4830 " at %L", sym->name, context, &e->where); 4831 return false; 4832 } 4833 if (!pointer && sym->attr.flavor != FL_VARIABLE 4834 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) 4835 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) 4836 { 4837 if (context) 4838 gfc_error ("%qs in variable definition context (%s) at %L is not" 4839 " a variable", sym->name, context, &e->where); 4840 return false; 4841 } 4842 4843 /* Find out whether the expr is a pointer; this also means following 4844 component references to the last one. */ 4845 is_pointer = (attr.pointer || attr.proc_pointer); 4846 if (pointer && !is_pointer) 4847 { 4848 if (context) 4849 gfc_error ("Non-POINTER in pointer association context (%s)" 4850 " at %L", context, &e->where); 4851 return false; 4852 } 4853 4854 /* F2008, C1303. */ 4855 if (!alloc_obj 4856 && (attr.lock_comp 4857 || (e->ts.type == BT_DERIVED 4858 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 4859 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) 4860 { 4861 if (context) 4862 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", 4863 context, &e->where); 4864 return false; 4865 } 4866 4867 /* TS18508, C702/C203. */ 4868 if (!alloc_obj 4869 && (attr.lock_comp 4870 || (e->ts.type == BT_DERIVED 4871 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 4872 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) 4873 { 4874 if (context) 4875 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L", 4876 context, &e->where); 4877 return false; 4878 } 4879 4880 /* INTENT(IN) dummy argument. Check this, unless the object itself is the 4881 component of sub-component of a pointer; we need to distinguish 4882 assignment to a pointer component from pointer-assignment to a pointer 4883 component. Note that (normal) assignment to procedure pointers is not 4884 possible. */ 4885 check_intentin = !own_scope; 4886 ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) 4887 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; 4888 for (ref = e->ref; ref && check_intentin; ref = ref->next) 4889 { 4890 if (ptr_component && ref->type == REF_COMPONENT) 4891 check_intentin = false; 4892 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) 4893 { 4894 ptr_component = true; 4895 if (!pointer) 4896 check_intentin = false; 4897 } 4898 } 4899 if (check_intentin && sym->attr.intent == INTENT_IN) 4900 { 4901 if (pointer && is_pointer) 4902 { 4903 if (context) 4904 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" 4905 " association context (%s) at %L", 4906 sym->name, context, &e->where); 4907 return false; 4908 } 4909 if (!pointer && !is_pointer && !sym->attr.pointer) 4910 { 4911 if (context) 4912 gfc_error ("Dummy argument %qs with INTENT(IN) in variable" 4913 " definition context (%s) at %L", 4914 sym->name, context, &e->where); 4915 return false; 4916 } 4917 } 4918 4919 /* PROTECTED and use-associated. */ 4920 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) 4921 { 4922 if (pointer && is_pointer) 4923 { 4924 if (context) 4925 gfc_error ("Variable %qs is PROTECTED and can not appear in a" 4926 " pointer association context (%s) at %L", 4927 sym->name, context, &e->where); 4928 return false; 4929 } 4930 if (!pointer && !is_pointer) 4931 { 4932 if (context) 4933 gfc_error ("Variable %qs is PROTECTED and can not appear in a" 4934 " variable definition context (%s) at %L", 4935 sym->name, context, &e->where); 4936 return false; 4937 } 4938 } 4939 4940 /* Variable not assignable from a PURE procedure but appears in 4941 variable definition context. */ 4942 if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) 4943 { 4944 if (context) 4945 gfc_error ("Variable %qs can not appear in a variable definition" 4946 " context (%s) at %L in PURE procedure", 4947 sym->name, context, &e->where); 4948 return false; 4949 } 4950 4951 if (!pointer && context && gfc_implicit_pure (NULL) 4952 && gfc_impure_variable (sym)) 4953 { 4954 gfc_namespace *ns; 4955 gfc_symbol *sym; 4956 4957 for (ns = gfc_current_ns; ns; ns = ns->parent) 4958 { 4959 sym = ns->proc_name; 4960 if (sym == NULL) 4961 break; 4962 if (sym->attr.flavor == FL_PROCEDURE) 4963 { 4964 sym->attr.implicit_pure = 0; 4965 break; 4966 } 4967 } 4968 } 4969 /* Check variable definition context for associate-names. */ 4970 if (!pointer && sym->assoc) 4971 { 4972 const char* name; 4973 gfc_association_list* assoc; 4974 4975 gcc_assert (sym->assoc->target); 4976 4977 /* If this is a SELECT TYPE temporary (the association is used internally 4978 for SELECT TYPE), silently go over to the target. */ 4979 if (sym->attr.select_type_temporary) 4980 { 4981 gfc_expr* t = sym->assoc->target; 4982 4983 gcc_assert (t->expr_type == EXPR_VARIABLE); 4984 name = t->symtree->name; 4985 4986 if (t->symtree->n.sym->assoc) 4987 assoc = t->symtree->n.sym->assoc; 4988 else 4989 assoc = sym->assoc; 4990 } 4991 else 4992 { 4993 name = sym->name; 4994 assoc = sym->assoc; 4995 } 4996 gcc_assert (name && assoc); 4997 4998 /* Is association to a valid variable? */ 4999 if (!assoc->variable) 5000 { 5001 if (context) 5002 { 5003 if (assoc->target->expr_type == EXPR_VARIABLE) 5004 gfc_error ("%qs at %L associated to vector-indexed target can" 5005 " not be used in a variable definition context (%s)", 5006 name, &e->where, context); 5007 else 5008 gfc_error ("%qs at %L associated to expression can" 5009 " not be used in a variable definition context (%s)", 5010 name, &e->where, context); 5011 } 5012 return false; 5013 } 5014 5015 /* Target must be allowed to appear in a variable definition context. */ 5016 if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) 5017 { 5018 if (context) 5019 gfc_error_1 ("Associate-name '%s' can not appear in a variable" 5020 " definition context (%s) at %L because its target" 5021 " at %L can not, either", 5022 name, context, &e->where, 5023 &assoc->target->where); 5024 return false; 5025 } 5026 } 5027 5028 /* Check for same value in vector expression subscript. */ 5029 5030 if (e->rank > 0) 5031 for (ref = e->ref; ref != NULL; ref = ref->next) 5032 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 5033 for (i = 0; i < GFC_MAX_DIMENSIONS 5034 && ref->u.ar.dimen_type[i] != 0; i++) 5035 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 5036 { 5037 gfc_expr *arr = ref->u.ar.start[i]; 5038 if (arr->expr_type == EXPR_ARRAY) 5039 { 5040 gfc_constructor *c, *n; 5041 gfc_expr *ec, *en; 5042 5043 for (c = gfc_constructor_first (arr->value.constructor); 5044 c != NULL; c = gfc_constructor_next (c)) 5045 { 5046 if (c == NULL || c->iterator != NULL) 5047 continue; 5048 5049 ec = c->expr; 5050 5051 for (n = gfc_constructor_next (c); n != NULL; 5052 n = gfc_constructor_next (n)) 5053 { 5054 if (n->iterator != NULL) 5055 continue; 5056 5057 en = n->expr; 5058 if (gfc_dep_compare_expr (ec, en) == 0) 5059 { 5060 if (context) 5061 gfc_error_now_1 ("Elements with the same value " 5062 "at %L and %L in vector " 5063 "subscript in a variable " 5064 "definition context (%s)", 5065 &(ec->where), &(en->where), 5066 context); 5067 return false; 5068 } 5069 } 5070 } 5071 } 5072 } 5073 5074 return true; 5075} 5076