1 /* Primary expression subroutines 2 Copyright (C) 2000-2020 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5 This file is part of GCC. 6 7 GCC is free software; you can redistribute it and/or modify it under 8 the terms of the GNU General Public License as published by the Free 9 Software Foundation; either version 3, or (at your option) any later 10 version. 11 12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13 WARRANTY; without even the implied warranty of MERCHANTABILITY or 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15 for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with GCC; see the file COPYING3. If not see 19 <http://www.gnu.org/licenses/>. */ 20 21 #include "config.h" 22 #include "system.h" 23 #include "coretypes.h" 24 #include "options.h" 25 #include "gfortran.h" 26 #include "arith.h" 27 #include "match.h" 28 #include "parse.h" 29 #include "constructor.h" 30 31 int matching_actual_arglist = 0; 32 33 /* Matches a kind-parameter expression, which is either a named 34 symbolic constant or a nonnegative integer constant. If 35 successful, sets the kind value to the correct integer. 36 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING 37 symbol like e.g. 'c_int'. */ 38 39 static match 40 match_kind_param (int *kind, int *is_iso_c) 41 { 42 char name[GFC_MAX_SYMBOL_LEN + 1]; 43 gfc_symbol *sym; 44 match m; 45 46 *is_iso_c = 0; 47 48 m = gfc_match_small_literal_int (kind, NULL); 49 if (m != MATCH_NO) 50 return m; 51 52 m = gfc_match_name (name); 53 if (m != MATCH_YES) 54 return m; 55 56 if (gfc_find_symbol (name, NULL, 1, &sym)) 57 return MATCH_ERROR; 58 59 if (sym == NULL) 60 return MATCH_NO; 61 62 *is_iso_c = sym->attr.is_iso_c; 63 64 if (sym->attr.flavor != FL_PARAMETER) 65 return MATCH_NO; 66 67 if (sym->value == NULL) 68 return MATCH_NO; 69 70 if (gfc_extract_int (sym->value, kind)) 71 return MATCH_NO; 72 73 gfc_set_sym_referenced (sym); 74 75 if (*kind < 0) 76 return MATCH_NO; 77 78 return MATCH_YES; 79 } 80 81 82 /* Get a trailing kind-specification for non-character variables. 83 Returns: 84 * the integer kind value or 85 * -1 if an error was generated, 86 * -2 if no kind was found. 87 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING 88 symbol like e.g. 'c_int'. */ 89 90 static int 91 get_kind (int *is_iso_c) 92 { 93 int kind; 94 match m; 95 96 *is_iso_c = 0; 97 98 if (gfc_match_char ('_') != MATCH_YES) 99 return -2; 100 101 m = match_kind_param (&kind, is_iso_c); 102 if (m == MATCH_NO) 103 gfc_error ("Missing kind-parameter at %C"); 104 105 return (m == MATCH_YES) ? kind : -1; 106 } 107 108 109 /* Given a character and a radix, see if the character is a valid 110 digit in that radix. */ 111 112 int 113 gfc_check_digit (char c, int radix) 114 { 115 int r; 116 117 switch (radix) 118 { 119 case 2: 120 r = ('0' <= c && c <= '1'); 121 break; 122 123 case 8: 124 r = ('0' <= c && c <= '7'); 125 break; 126 127 case 10: 128 r = ('0' <= c && c <= '9'); 129 break; 130 131 case 16: 132 r = ISXDIGIT (c); 133 break; 134 135 default: 136 gfc_internal_error ("gfc_check_digit(): bad radix"); 137 } 138 139 return r; 140 } 141 142 143 /* Match the digit string part of an integer if signflag is not set, 144 the signed digit string part if signflag is set. If the buffer 145 is NULL, we just count characters for the resolution pass. Returns 146 the number of characters matched, -1 for no match. */ 147 148 static int 149 match_digits (int signflag, int radix, char *buffer) 150 { 151 locus old_loc; 152 int length; 153 char c; 154 155 length = 0; 156 c = gfc_next_ascii_char (); 157 158 if (signflag && (c == '+' || c == '-')) 159 { 160 if (buffer != NULL) 161 *buffer++ = c; 162 gfc_gobble_whitespace (); 163 c = gfc_next_ascii_char (); 164 length++; 165 } 166 167 if (!gfc_check_digit (c, radix)) 168 return -1; 169 170 length++; 171 if (buffer != NULL) 172 *buffer++ = c; 173 174 for (;;) 175 { 176 old_loc = gfc_current_locus; 177 c = gfc_next_ascii_char (); 178 179 if (!gfc_check_digit (c, radix)) 180 break; 181 182 if (buffer != NULL) 183 *buffer++ = c; 184 length++; 185 } 186 187 gfc_current_locus = old_loc; 188 189 return length; 190 } 191 192 /* Convert an integer string to an expression node. */ 193 194 static gfc_expr * 195 convert_integer (const char *buffer, int kind, int radix, locus *where) 196 { 197 gfc_expr *e; 198 const char *t; 199 200 e = gfc_get_constant_expr (BT_INTEGER, kind, where); 201 /* A leading plus is allowed, but not by mpz_set_str. */ 202 if (buffer[0] == '+') 203 t = buffer + 1; 204 else 205 t = buffer; 206 mpz_set_str (e->value.integer, t, radix); 207 208 return e; 209 } 210 211 212 /* Convert a real string to an expression node. */ 213 214 static gfc_expr * 215 convert_real (const char *buffer, int kind, locus *where) 216 { 217 gfc_expr *e; 218 219 e = gfc_get_constant_expr (BT_REAL, kind, where); 220 mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE); 221 222 return e; 223 } 224 225 226 /* Convert a pair of real, constant expression nodes to a single 227 complex expression node. */ 228 229 static gfc_expr * 230 convert_complex (gfc_expr *real, gfc_expr *imag, int kind) 231 { 232 gfc_expr *e; 233 234 e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where); 235 mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real, 236 GFC_MPC_RND_MODE); 237 238 return e; 239 } 240 241 242 /* Match an integer (digit string and optional kind). 243 A sign will be accepted if signflag is set. */ 244 245 static match 246 match_integer_constant (gfc_expr **result, int signflag) 247 { 248 int length, kind, is_iso_c; 249 locus old_loc; 250 char *buffer; 251 gfc_expr *e; 252 253 old_loc = gfc_current_locus; 254 gfc_gobble_whitespace (); 255 256 length = match_digits (signflag, 10, NULL); 257 gfc_current_locus = old_loc; 258 if (length == -1) 259 return MATCH_NO; 260 261 buffer = (char *) alloca (length + 1); 262 memset (buffer, '\0', length + 1); 263 264 gfc_gobble_whitespace (); 265 266 match_digits (signflag, 10, buffer); 267 268 kind = get_kind (&is_iso_c); 269 if (kind == -2) 270 kind = gfc_default_integer_kind; 271 if (kind == -1) 272 return MATCH_ERROR; 273 274 if (kind == 4 && flag_integer4_kind == 8) 275 kind = 8; 276 277 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0) 278 { 279 gfc_error ("Integer kind %d at %C not available", kind); 280 return MATCH_ERROR; 281 } 282 283 e = convert_integer (buffer, kind, 10, &gfc_current_locus); 284 e->ts.is_c_interop = is_iso_c; 285 286 if (gfc_range_check (e) != ARITH_OK) 287 { 288 gfc_error ("Integer too big for its kind at %C. This check can be " 289 "disabled with the option %<-fno-range-check%>"); 290 291 gfc_free_expr (e); 292 return MATCH_ERROR; 293 } 294 295 *result = e; 296 return MATCH_YES; 297 } 298 299 300 /* Match a Hollerith constant. */ 301 302 static match 303 match_hollerith_constant (gfc_expr **result) 304 { 305 locus old_loc; 306 gfc_expr *e = NULL; 307 int num, pad; 308 int i; 309 310 old_loc = gfc_current_locus; 311 gfc_gobble_whitespace (); 312 313 if (match_integer_constant (&e, 0) == MATCH_YES 314 && gfc_match_char ('h') == MATCH_YES) 315 { 316 if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C")) 317 goto cleanup; 318 319 if (gfc_extract_int (e, &num, 1)) 320 goto cleanup; 321 if (num == 0) 322 { 323 gfc_error ("Invalid Hollerith constant: %L must contain at least " 324 "one character", &old_loc); 325 goto cleanup; 326 } 327 if (e->ts.kind != gfc_default_integer_kind) 328 { 329 gfc_error ("Invalid Hollerith constant: Integer kind at %L " 330 "should be default", &old_loc); 331 goto cleanup; 332 } 333 else 334 { 335 gfc_free_expr (e); 336 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind, 337 &gfc_current_locus); 338 339 /* Calculate padding needed to fit default integer memory. */ 340 pad = gfc_default_integer_kind - (num % gfc_default_integer_kind); 341 342 e->representation.string = XCNEWVEC (char, num + pad + 1); 343 344 for (i = 0; i < num; i++) 345 { 346 gfc_char_t c = gfc_next_char_literal (INSTRING_WARN); 347 if (! gfc_wide_fits_in_byte (c)) 348 { 349 gfc_error ("Invalid Hollerith constant at %L contains a " 350 "wide character", &old_loc); 351 goto cleanup; 352 } 353 354 e->representation.string[i] = (unsigned char) c; 355 } 356 357 /* Now pad with blanks and end with a null char. */ 358 for (i = 0; i < pad; i++) 359 e->representation.string[num + i] = ' '; 360 361 e->representation.string[num + i] = '\0'; 362 e->representation.length = num + pad; 363 e->ts.u.pad = pad; 364 365 *result = e; 366 return MATCH_YES; 367 } 368 } 369 370 gfc_free_expr (e); 371 gfc_current_locus = old_loc; 372 return MATCH_NO; 373 374 cleanup: 375 gfc_free_expr (e); 376 return MATCH_ERROR; 377 } 378 379 380 /* Match a binary, octal or hexadecimal constant that can be found in 381 a DATA statement. The standard permits b'010...', o'73...', and 382 z'a1...' where b, o, and z can be capital letters. This function 383 also accepts postfixed forms of the constants: '01...'b, '73...'o, 384 and 'a1...'z. An additional extension is the use of x for z. */ 385 386 static match 387 match_boz_constant (gfc_expr **result) 388 { 389 int radix, length, x_hex; 390 locus old_loc, start_loc; 391 char *buffer, post, delim; 392 gfc_expr *e; 393 394 start_loc = old_loc = gfc_current_locus; 395 gfc_gobble_whitespace (); 396 397 x_hex = 0; 398 switch (post = gfc_next_ascii_char ()) 399 { 400 case 'b': 401 radix = 2; 402 post = 0; 403 break; 404 case 'o': 405 radix = 8; 406 post = 0; 407 break; 408 case 'x': 409 x_hex = 1; 410 /* Fall through. */ 411 case 'z': 412 radix = 16; 413 post = 0; 414 break; 415 case '\'': 416 /* Fall through. */ 417 case '\"': 418 delim = post; 419 post = 1; 420 radix = 16; /* Set to accept any valid digit string. */ 421 break; 422 default: 423 goto backup; 424 } 425 426 /* No whitespace allowed here. */ 427 428 if (post == 0) 429 delim = gfc_next_ascii_char (); 430 431 if (delim != '\'' && delim != '\"') 432 goto backup; 433 434 if (x_hex 435 && gfc_invalid_boz ("Hexadecimal constant at %L uses " 436 "nonstandard X instead of Z", &gfc_current_locus)) 437 return MATCH_ERROR; 438 439 old_loc = gfc_current_locus; 440 441 length = match_digits (0, radix, NULL); 442 if (length == -1) 443 { 444 gfc_error ("Empty set of digits in BOZ constant at %C"); 445 return MATCH_ERROR; 446 } 447 448 if (gfc_next_ascii_char () != delim) 449 { 450 gfc_error ("Illegal character in BOZ constant at %C"); 451 return MATCH_ERROR; 452 } 453 454 if (post == 1) 455 { 456 switch (gfc_next_ascii_char ()) 457 { 458 case 'b': 459 radix = 2; 460 break; 461 case 'o': 462 radix = 8; 463 break; 464 case 'x': 465 /* Fall through. */ 466 case 'z': 467 radix = 16; 468 break; 469 default: 470 goto backup; 471 } 472 473 if (gfc_invalid_boz ("BOZ constant at %C uses nonstandard postfix " 474 "syntax", &gfc_current_locus)) 475 return MATCH_ERROR; 476 } 477 478 gfc_current_locus = old_loc; 479 480 buffer = (char *) alloca (length + 1); 481 memset (buffer, '\0', length + 1); 482 483 match_digits (0, radix, buffer); 484 gfc_next_ascii_char (); /* Eat delimiter. */ 485 if (post == 1) 486 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */ 487 488 e = gfc_get_expr (); 489 e->expr_type = EXPR_CONSTANT; 490 e->ts.type = BT_BOZ; 491 e->where = gfc_current_locus; 492 e->boz.rdx = radix; 493 e->boz.len = length; 494 e->boz.str = XCNEWVEC (char, length + 1); 495 strncpy (e->boz.str, buffer, length); 496 497 if (!gfc_in_match_data () 498 && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA " 499 "statement at %L", &e->where))) 500 return MATCH_ERROR; 501 502 *result = e; 503 return MATCH_YES; 504 505 backup: 506 gfc_current_locus = start_loc; 507 return MATCH_NO; 508 } 509 510 511 /* Match a real constant of some sort. Allow a signed constant if signflag 512 is nonzero. */ 513 514 static match 515 match_real_constant (gfc_expr **result, int signflag) 516 { 517 int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent; 518 locus old_loc, temp_loc; 519 char *p, *buffer, c, exp_char; 520 gfc_expr *e; 521 bool negate; 522 523 old_loc = gfc_current_locus; 524 gfc_gobble_whitespace (); 525 526 e = NULL; 527 528 default_exponent = 0; 529 count = 0; 530 seen_dp = 0; 531 seen_digits = 0; 532 exp_char = ' '; 533 negate = FALSE; 534 535 c = gfc_next_ascii_char (); 536 if (signflag && (c == '+' || c == '-')) 537 { 538 if (c == '-') 539 negate = TRUE; 540 541 gfc_gobble_whitespace (); 542 c = gfc_next_ascii_char (); 543 } 544 545 /* Scan significand. */ 546 for (;; c = gfc_next_ascii_char (), count++) 547 { 548 if (c == '.') 549 { 550 if (seen_dp) 551 goto done; 552 553 /* Check to see if "." goes with a following operator like 554 ".eq.". */ 555 temp_loc = gfc_current_locus; 556 c = gfc_next_ascii_char (); 557 558 if (c == 'e' || c == 'd' || c == 'q') 559 { 560 c = gfc_next_ascii_char (); 561 if (c == '.') 562 goto done; /* Operator named .e. or .d. */ 563 } 564 565 if (ISALPHA (c)) 566 goto done; /* Distinguish 1.e9 from 1.eq.2 */ 567 568 gfc_current_locus = temp_loc; 569 seen_dp = 1; 570 continue; 571 } 572 573 if (ISDIGIT (c)) 574 { 575 seen_digits = 1; 576 continue; 577 } 578 579 break; 580 } 581 582 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q')) 583 goto done; 584 exp_char = c; 585 586 587 if (c == 'q') 588 { 589 if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in " 590 "real-literal-constant at %C")) 591 return MATCH_ERROR; 592 else if (warn_real_q_constant) 593 gfc_warning (OPT_Wreal_q_constant, 594 "Extension: exponent-letter %<q%> in real-literal-constant " 595 "at %C"); 596 } 597 598 /* Scan exponent. */ 599 c = gfc_next_ascii_char (); 600 count++; 601 602 if (c == '+' || c == '-') 603 { /* optional sign */ 604 c = gfc_next_ascii_char (); 605 count++; 606 } 607 608 if (!ISDIGIT (c)) 609 { 610 /* With -fdec, default exponent to 0 instead of complaining. */ 611 if (flag_dec) 612 default_exponent = 1; 613 else 614 { 615 gfc_error ("Missing exponent in real number at %C"); 616 return MATCH_ERROR; 617 } 618 } 619 620 while (ISDIGIT (c)) 621 { 622 c = gfc_next_ascii_char (); 623 count++; 624 } 625 626 done: 627 /* Check that we have a numeric constant. */ 628 if (!seen_digits || (!seen_dp && exp_char == ' ')) 629 { 630 gfc_current_locus = old_loc; 631 return MATCH_NO; 632 } 633 634 /* Convert the number. */ 635 gfc_current_locus = old_loc; 636 gfc_gobble_whitespace (); 637 638 buffer = (char *) alloca (count + default_exponent + 1); 639 memset (buffer, '\0', count + default_exponent + 1); 640 641 p = buffer; 642 c = gfc_next_ascii_char (); 643 if (c == '+' || c == '-') 644 { 645 gfc_gobble_whitespace (); 646 c = gfc_next_ascii_char (); 647 } 648 649 /* Hack for mpfr_set_str(). */ 650 for (;;) 651 { 652 if (c == 'd' || c == 'q') 653 *p = 'e'; 654 else 655 *p = c; 656 p++; 657 if (--count == 0) 658 break; 659 660 c = gfc_next_ascii_char (); 661 } 662 if (default_exponent) 663 *p++ = '0'; 664 665 kind = get_kind (&is_iso_c); 666 if (kind == -1) 667 goto cleanup; 668 669 switch (exp_char) 670 { 671 case 'd': 672 if (kind != -2) 673 { 674 gfc_error ("Real number at %C has a %<d%> exponent and an explicit " 675 "kind"); 676 goto cleanup; 677 } 678 kind = gfc_default_double_kind; 679 680 if (kind == 4) 681 { 682 if (flag_real4_kind == 8) 683 kind = 8; 684 if (flag_real4_kind == 10) 685 kind = 10; 686 if (flag_real4_kind == 16) 687 kind = 16; 688 } 689 690 if (kind == 8) 691 { 692 if (flag_real8_kind == 4) 693 kind = 4; 694 if (flag_real8_kind == 10) 695 kind = 10; 696 if (flag_real8_kind == 16) 697 kind = 16; 698 } 699 break; 700 701 case 'q': 702 if (kind != -2) 703 { 704 gfc_error ("Real number at %C has a %<q%> exponent and an explicit " 705 "kind"); 706 goto cleanup; 707 } 708 709 /* The maximum possible real kind type parameter is 16. First, try 710 that for the kind, then fallback to trying kind=10 (Intel 80 bit) 711 extended precision. If neither value works, just given up. */ 712 kind = 16; 713 if (gfc_validate_kind (BT_REAL, kind, true) < 0) 714 { 715 kind = 10; 716 if (gfc_validate_kind (BT_REAL, kind, true) < 0) 717 { 718 gfc_error ("Invalid exponent-letter %<q%> in " 719 "real-literal-constant at %C"); 720 goto cleanup; 721 } 722 } 723 break; 724 725 default: 726 if (kind == -2) 727 kind = gfc_default_real_kind; 728 729 if (kind == 4) 730 { 731 if (flag_real4_kind == 8) 732 kind = 8; 733 if (flag_real4_kind == 10) 734 kind = 10; 735 if (flag_real4_kind == 16) 736 kind = 16; 737 } 738 739 if (kind == 8) 740 { 741 if (flag_real8_kind == 4) 742 kind = 4; 743 if (flag_real8_kind == 10) 744 kind = 10; 745 if (flag_real8_kind == 16) 746 kind = 16; 747 } 748 749 if (gfc_validate_kind (BT_REAL, kind, true) < 0) 750 { 751 gfc_error ("Invalid real kind %d at %C", kind); 752 goto cleanup; 753 } 754 } 755 756 e = convert_real (buffer, kind, &gfc_current_locus); 757 if (negate) 758 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE); 759 e->ts.is_c_interop = is_iso_c; 760 761 switch (gfc_range_check (e)) 762 { 763 case ARITH_OK: 764 break; 765 case ARITH_OVERFLOW: 766 gfc_error ("Real constant overflows its kind at %C"); 767 goto cleanup; 768 769 case ARITH_UNDERFLOW: 770 if (warn_underflow) 771 gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C"); 772 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); 773 break; 774 775 default: 776 gfc_internal_error ("gfc_range_check() returned bad value"); 777 } 778 779 /* Warn about trailing digits which suggest the user added too many 780 trailing digits, which may cause the appearance of higher pecision 781 than the kind kan support. 782 783 This is done by replacing the rightmost non-zero digit with zero 784 and comparing with the original value. If these are equal, we 785 assume the user supplied more digits than intended (or forgot to 786 convert to the correct kind). 787 */ 788 789 if (warn_conversion_extra) 790 { 791 mpfr_t r; 792 char *c1; 793 bool did_break; 794 795 c1 = strchr (buffer, 'e'); 796 if (c1 == NULL) 797 c1 = buffer + strlen(buffer); 798 799 did_break = false; 800 for (p = c1; p > buffer;) 801 { 802 p--; 803 if (*p == '.') 804 continue; 805 806 if (*p != '0') 807 { 808 *p = '0'; 809 did_break = true; 810 break; 811 } 812 } 813 814 if (did_break) 815 { 816 mpfr_init (r); 817 mpfr_set_str (r, buffer, 10, GFC_RND_MODE); 818 if (negate) 819 mpfr_neg (r, r, GFC_RND_MODE); 820 821 mpfr_sub (r, r, e->value.real, GFC_RND_MODE); 822 823 if (mpfr_cmp_ui (r, 0) == 0) 824 gfc_warning (OPT_Wconversion_extra, "Non-significant digits " 825 "in %qs number at %C, maybe incorrect KIND", 826 gfc_typename (&e->ts)); 827 828 mpfr_clear (r); 829 } 830 } 831 832 *result = e; 833 return MATCH_YES; 834 835 cleanup: 836 gfc_free_expr (e); 837 return MATCH_ERROR; 838 } 839 840 841 /* Match a substring reference. */ 842 843 static match 844 match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred) 845 { 846 gfc_expr *start, *end; 847 locus old_loc; 848 gfc_ref *ref; 849 match m; 850 851 start = NULL; 852 end = NULL; 853 854 old_loc = gfc_current_locus; 855 856 m = gfc_match_char ('('); 857 if (m != MATCH_YES) 858 return MATCH_NO; 859 860 if (gfc_match_char (':') != MATCH_YES) 861 { 862 if (init) 863 m = gfc_match_init_expr (&start); 864 else 865 m = gfc_match_expr (&start); 866 867 if (m != MATCH_YES) 868 { 869 m = MATCH_NO; 870 goto cleanup; 871 } 872 873 m = gfc_match_char (':'); 874 if (m != MATCH_YES) 875 goto cleanup; 876 } 877 878 if (gfc_match_char (')') != MATCH_YES) 879 { 880 if (init) 881 m = gfc_match_init_expr (&end); 882 else 883 m = gfc_match_expr (&end); 884 885 if (m == MATCH_NO) 886 goto syntax; 887 if (m == MATCH_ERROR) 888 goto cleanup; 889 890 m = gfc_match_char (')'); 891 if (m == MATCH_NO) 892 goto syntax; 893 } 894 895 /* Optimize away the (:) reference. */ 896 if (start == NULL && end == NULL && !deferred) 897 ref = NULL; 898 else 899 { 900 ref = gfc_get_ref (); 901 902 ref->type = REF_SUBSTRING; 903 if (start == NULL) 904 start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); 905 ref->u.ss.start = start; 906 if (end == NULL && cl) 907 end = gfc_copy_expr (cl->length); 908 ref->u.ss.end = end; 909 ref->u.ss.length = cl; 910 } 911 912 *result = ref; 913 return MATCH_YES; 914 915 syntax: 916 gfc_error ("Syntax error in SUBSTRING specification at %C"); 917 m = MATCH_ERROR; 918 919 cleanup: 920 gfc_free_expr (start); 921 gfc_free_expr (end); 922 923 gfc_current_locus = old_loc; 924 return m; 925 } 926 927 928 /* Reads the next character of a string constant, taking care to 929 return doubled delimiters on the input as a single instance of 930 the delimiter. 931 932 Special return values for "ret" argument are: 933 -1 End of the string, as determined by the delimiter 934 -2 Unterminated string detected 935 936 Backslash codes are also expanded at this time. */ 937 938 static gfc_char_t 939 next_string_char (gfc_char_t delimiter, int *ret) 940 { 941 locus old_locus; 942 gfc_char_t c; 943 944 c = gfc_next_char_literal (INSTRING_WARN); 945 *ret = 0; 946 947 if (c == '\n') 948 { 949 *ret = -2; 950 return 0; 951 } 952 953 if (flag_backslash && c == '\\') 954 { 955 old_locus = gfc_current_locus; 956 957 if (gfc_match_special_char (&c) == MATCH_NO) 958 gfc_current_locus = old_locus; 959 960 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) 961 gfc_warning (0, "Extension: backslash character at %C"); 962 } 963 964 if (c != delimiter) 965 return c; 966 967 old_locus = gfc_current_locus; 968 c = gfc_next_char_literal (NONSTRING); 969 970 if (c == delimiter) 971 return c; 972 gfc_current_locus = old_locus; 973 974 *ret = -1; 975 return 0; 976 } 977 978 979 /* Special case of gfc_match_name() that matches a parameter kind name 980 before a string constant. This takes case of the weird but legal 981 case of: 982 983 kind_____'string' 984 985 where kind____ is a parameter. gfc_match_name() will happily slurp 986 up all the underscores, which leads to problems. If we return 987 MATCH_YES, the parse pointer points to the final underscore, which 988 is not part of the name. We never return MATCH_ERROR-- errors in 989 the name will be detected later. */ 990 991 static match 992 match_charkind_name (char *name) 993 { 994 locus old_loc; 995 char c, peek; 996 int len; 997 998 gfc_gobble_whitespace (); 999 c = gfc_next_ascii_char (); 1000 if (!ISALPHA (c)) 1001 return MATCH_NO; 1002 1003 *name++ = c; 1004 len = 1; 1005 1006 for (;;) 1007 { 1008 old_loc = gfc_current_locus; 1009 c = gfc_next_ascii_char (); 1010 1011 if (c == '_') 1012 { 1013 peek = gfc_peek_ascii_char (); 1014 1015 if (peek == '\'' || peek == '\"') 1016 { 1017 gfc_current_locus = old_loc; 1018 *name = '\0'; 1019 return MATCH_YES; 1020 } 1021 } 1022 1023 if (!ISALNUM (c) 1024 && c != '_' 1025 && (c != '$' || !flag_dollar_ok)) 1026 break; 1027 1028 *name++ = c; 1029 if (++len > GFC_MAX_SYMBOL_LEN) 1030 break; 1031 } 1032 1033 return MATCH_NO; 1034 } 1035 1036 1037 /* See if the current input matches a character constant. Lots of 1038 contortions have to be done to match the kind parameter which comes 1039 before the actual string. The main consideration is that we don't 1040 want to error out too quickly. For example, we don't actually do 1041 any validation of the kinds until we have actually seen a legal 1042 delimiter. Using match_kind_param() generates errors too quickly. */ 1043 1044 static match 1045 match_string_constant (gfc_expr **result) 1046 { 1047 char name[GFC_MAX_SYMBOL_LEN + 1], peek; 1048 size_t length; 1049 int kind,save_warn_ampersand, ret; 1050 locus old_locus, start_locus; 1051 gfc_symbol *sym; 1052 gfc_expr *e; 1053 match m; 1054 gfc_char_t c, delimiter, *p; 1055 1056 old_locus = gfc_current_locus; 1057 1058 gfc_gobble_whitespace (); 1059 1060 c = gfc_next_char (); 1061 if (c == '\'' || c == '"') 1062 { 1063 kind = gfc_default_character_kind; 1064 start_locus = gfc_current_locus; 1065 goto got_delim; 1066 } 1067 1068 if (gfc_wide_is_digit (c)) 1069 { 1070 kind = 0; 1071 1072 while (gfc_wide_is_digit (c)) 1073 { 1074 kind = kind * 10 + c - '0'; 1075 if (kind > 9999999) 1076 goto no_match; 1077 c = gfc_next_char (); 1078 } 1079 1080 } 1081 else 1082 { 1083 gfc_current_locus = old_locus; 1084 1085 m = match_charkind_name (name); 1086 if (m != MATCH_YES) 1087 goto no_match; 1088 1089 if (gfc_find_symbol (name, NULL, 1, &sym) 1090 || sym == NULL 1091 || sym->attr.flavor != FL_PARAMETER) 1092 goto no_match; 1093 1094 kind = -1; 1095 c = gfc_next_char (); 1096 } 1097 1098 if (c == ' ') 1099 { 1100 gfc_gobble_whitespace (); 1101 c = gfc_next_char (); 1102 } 1103 1104 if (c != '_') 1105 goto no_match; 1106 1107 gfc_gobble_whitespace (); 1108 1109 c = gfc_next_char (); 1110 if (c != '\'' && c != '"') 1111 goto no_match; 1112 1113 start_locus = gfc_current_locus; 1114 1115 if (kind == -1) 1116 { 1117 if (gfc_extract_int (sym->value, &kind, 1)) 1118 return MATCH_ERROR; 1119 gfc_set_sym_referenced (sym); 1120 } 1121 1122 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0) 1123 { 1124 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind); 1125 return MATCH_ERROR; 1126 } 1127 1128 got_delim: 1129 /* Scan the string into a block of memory by first figuring out how 1130 long it is, allocating the structure, then re-reading it. This 1131 isn't particularly efficient, but string constants aren't that 1132 common in most code. TODO: Use obstacks? */ 1133 1134 delimiter = c; 1135 length = 0; 1136 1137 for (;;) 1138 { 1139 c = next_string_char (delimiter, &ret); 1140 if (ret == -1) 1141 break; 1142 if (ret == -2) 1143 { 1144 gfc_current_locus = start_locus; 1145 gfc_error ("Unterminated character constant beginning at %C"); 1146 return MATCH_ERROR; 1147 } 1148 1149 length++; 1150 } 1151 1152 /* Peek at the next character to see if it is a b, o, z, or x for the 1153 postfixed BOZ literal constants. */ 1154 peek = gfc_peek_ascii_char (); 1155 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x') 1156 goto no_match; 1157 1158 e = gfc_get_character_expr (kind, &start_locus, NULL, length); 1159 1160 gfc_current_locus = start_locus; 1161 1162 /* We disable the warning for the following loop as the warning has already 1163 been printed in the loop above. */ 1164 save_warn_ampersand = warn_ampersand; 1165 warn_ampersand = false; 1166 1167 p = e->value.character.string; 1168 for (size_t i = 0; i < length; i++) 1169 { 1170 c = next_string_char (delimiter, &ret); 1171 1172 if (!gfc_check_character_range (c, kind)) 1173 { 1174 gfc_free_expr (e); 1175 gfc_error ("Character %qs in string at %C is not representable " 1176 "in character kind %d", gfc_print_wide_char (c), kind); 1177 return MATCH_ERROR; 1178 } 1179 1180 *p++ = c; 1181 } 1182 1183 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */ 1184 warn_ampersand = save_warn_ampersand; 1185 1186 next_string_char (delimiter, &ret); 1187 if (ret != -1) 1188 gfc_internal_error ("match_string_constant(): Delimiter not found"); 1189 1190 if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO) 1191 e->expr_type = EXPR_SUBSTRING; 1192 1193 /* Substrings with constant starting and ending points are eligible as 1194 designators (F2018, section 9.1). Simplify substrings to make them usable 1195 e.g. in data statements. */ 1196 if (e->expr_type == EXPR_SUBSTRING 1197 && e->ref && e->ref->type == REF_SUBSTRING 1198 && e->ref->u.ss.start->expr_type == EXPR_CONSTANT 1199 && (e->ref->u.ss.end == NULL 1200 || e->ref->u.ss.end->expr_type == EXPR_CONSTANT)) 1201 { 1202 gfc_expr *res; 1203 ptrdiff_t istart, iend; 1204 size_t length; 1205 bool equal_length = false; 1206 1207 /* Basic checks on substring starting and ending indices. */ 1208 if (!gfc_resolve_substring (e->ref, &equal_length)) 1209 return MATCH_ERROR; 1210 1211 length = e->value.character.length; 1212 istart = gfc_mpz_get_hwi (e->ref->u.ss.start->value.integer); 1213 if (e->ref->u.ss.end == NULL) 1214 iend = length; 1215 else 1216 iend = gfc_mpz_get_hwi (e->ref->u.ss.end->value.integer); 1217 1218 if (istart <= iend) 1219 { 1220 if (istart < 1) 1221 { 1222 gfc_error ("Substring start index (%ld) at %L below 1", 1223 (long) istart, &e->ref->u.ss.start->where); 1224 return MATCH_ERROR; 1225 } 1226 if (iend > (ssize_t) length) 1227 { 1228 gfc_error ("Substring end index (%ld) at %L exceeds string " 1229 "length", (long) iend, &e->ref->u.ss.end->where); 1230 return MATCH_ERROR; 1231 } 1232 length = iend - istart + 1; 1233 } 1234 else 1235 length = 0; 1236 1237 res = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where); 1238 res->value.character.string = gfc_get_wide_string (length + 1); 1239 res->value.character.length = length; 1240 if (length > 0) 1241 memcpy (res->value.character.string, 1242 &e->value.character.string[istart - 1], 1243 length * sizeof (gfc_char_t)); 1244 res->value.character.string[length] = '\0'; 1245 e = res; 1246 } 1247 1248 *result = e; 1249 1250 return MATCH_YES; 1251 1252 no_match: 1253 gfc_current_locus = old_locus; 1254 return MATCH_NO; 1255 } 1256 1257 1258 /* Match a .true. or .false. Returns 1 if a .true. was found, 1259 0 if a .false. was found, and -1 otherwise. */ 1260 static int 1261 match_logical_constant_string (void) 1262 { 1263 locus orig_loc = gfc_current_locus; 1264 1265 gfc_gobble_whitespace (); 1266 if (gfc_next_ascii_char () == '.') 1267 { 1268 char ch = gfc_next_ascii_char (); 1269 if (ch == 'f') 1270 { 1271 if (gfc_next_ascii_char () == 'a' 1272 && gfc_next_ascii_char () == 'l' 1273 && gfc_next_ascii_char () == 's' 1274 && gfc_next_ascii_char () == 'e' 1275 && gfc_next_ascii_char () == '.') 1276 /* Matched ".false.". */ 1277 return 0; 1278 } 1279 else if (ch == 't') 1280 { 1281 if (gfc_next_ascii_char () == 'r' 1282 && gfc_next_ascii_char () == 'u' 1283 && gfc_next_ascii_char () == 'e' 1284 && gfc_next_ascii_char () == '.') 1285 /* Matched ".true.". */ 1286 return 1; 1287 } 1288 } 1289 gfc_current_locus = orig_loc; 1290 return -1; 1291 } 1292 1293 /* Match a .true. or .false. */ 1294 1295 static match 1296 match_logical_constant (gfc_expr **result) 1297 { 1298 gfc_expr *e; 1299 int i, kind, is_iso_c; 1300 1301 i = match_logical_constant_string (); 1302 if (i == -1) 1303 return MATCH_NO; 1304 1305 kind = get_kind (&is_iso_c); 1306 if (kind == -1) 1307 return MATCH_ERROR; 1308 if (kind == -2) 1309 kind = gfc_default_logical_kind; 1310 1311 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0) 1312 { 1313 gfc_error ("Bad kind for logical constant at %C"); 1314 return MATCH_ERROR; 1315 } 1316 1317 e = gfc_get_logical_expr (kind, &gfc_current_locus, i); 1318 e->ts.is_c_interop = is_iso_c; 1319 1320 *result = e; 1321 return MATCH_YES; 1322 } 1323 1324 1325 /* Match a real or imaginary part of a complex constant that is a 1326 symbolic constant. */ 1327 1328 static match 1329 match_sym_complex_part (gfc_expr **result) 1330 { 1331 char name[GFC_MAX_SYMBOL_LEN + 1]; 1332 gfc_symbol *sym; 1333 gfc_expr *e; 1334 match m; 1335 1336 m = gfc_match_name (name); 1337 if (m != MATCH_YES) 1338 return m; 1339 1340 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL) 1341 return MATCH_NO; 1342 1343 if (sym->attr.flavor != FL_PARAMETER) 1344 { 1345 /* Give the matcher for implied do-loops a chance to run. This yields 1346 a much saner error message for "write(*,*) (i, i=1, 6" where the 1347 right parenthesis is missing. */ 1348 char c; 1349 gfc_gobble_whitespace (); 1350 c = gfc_peek_ascii_char (); 1351 if (c == '=' || c == ',') 1352 { 1353 m = MATCH_NO; 1354 } 1355 else 1356 { 1357 gfc_error ("Expected PARAMETER symbol in complex constant at %C"); 1358 m = MATCH_ERROR; 1359 } 1360 return m; 1361 } 1362 1363 if (!sym->value) 1364 goto error; 1365 1366 if (!gfc_numeric_ts (&sym->value->ts)) 1367 { 1368 gfc_error ("Numeric PARAMETER required in complex constant at %C"); 1369 return MATCH_ERROR; 1370 } 1371 1372 if (sym->value->rank != 0) 1373 { 1374 gfc_error ("Scalar PARAMETER required in complex constant at %C"); 1375 return MATCH_ERROR; 1376 } 1377 1378 if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in " 1379 "complex constant at %C")) 1380 return MATCH_ERROR; 1381 1382 switch (sym->value->ts.type) 1383 { 1384 case BT_REAL: 1385 e = gfc_copy_expr (sym->value); 1386 break; 1387 1388 case BT_COMPLEX: 1389 e = gfc_complex2real (sym->value, sym->value->ts.kind); 1390 if (e == NULL) 1391 goto error; 1392 break; 1393 1394 case BT_INTEGER: 1395 e = gfc_int2real (sym->value, gfc_default_real_kind); 1396 if (e == NULL) 1397 goto error; 1398 break; 1399 1400 default: 1401 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type"); 1402 } 1403 1404 *result = e; /* e is a scalar, real, constant expression. */ 1405 return MATCH_YES; 1406 1407 error: 1408 gfc_error ("Error converting PARAMETER constant in complex constant at %C"); 1409 return MATCH_ERROR; 1410 } 1411 1412 1413 /* Match a real or imaginary part of a complex number. */ 1414 1415 static match 1416 match_complex_part (gfc_expr **result) 1417 { 1418 match m; 1419 1420 m = match_sym_complex_part (result); 1421 if (m != MATCH_NO) 1422 return m; 1423 1424 m = match_real_constant (result, 1); 1425 if (m != MATCH_NO) 1426 return m; 1427 1428 return match_integer_constant (result, 1); 1429 } 1430 1431 1432 /* Try to match a complex constant. */ 1433 1434 static match 1435 match_complex_constant (gfc_expr **result) 1436 { 1437 gfc_expr *e, *real, *imag; 1438 gfc_error_buffer old_error; 1439 gfc_typespec target; 1440 locus old_loc; 1441 int kind; 1442 match m; 1443 1444 old_loc = gfc_current_locus; 1445 real = imag = e = NULL; 1446 1447 m = gfc_match_char ('('); 1448 if (m != MATCH_YES) 1449 return m; 1450 1451 gfc_push_error (&old_error); 1452 1453 m = match_complex_part (&real); 1454 if (m == MATCH_NO) 1455 { 1456 gfc_free_error (&old_error); 1457 goto cleanup; 1458 } 1459 1460 if (gfc_match_char (',') == MATCH_NO) 1461 { 1462 /* It is possible that gfc_int2real issued a warning when 1463 converting an integer to real. Throw this away here. */ 1464 1465 gfc_clear_warning (); 1466 gfc_pop_error (&old_error); 1467 m = MATCH_NO; 1468 goto cleanup; 1469 } 1470 1471 /* If m is error, then something was wrong with the real part and we 1472 assume we have a complex constant because we've seen the ','. An 1473 ambiguous case here is the start of an iterator list of some 1474 sort. These sort of lists are matched prior to coming here. */ 1475 1476 if (m == MATCH_ERROR) 1477 { 1478 gfc_free_error (&old_error); 1479 goto cleanup; 1480 } 1481 gfc_pop_error (&old_error); 1482 1483 m = match_complex_part (&imag); 1484 if (m == MATCH_NO) 1485 goto syntax; 1486 if (m == MATCH_ERROR) 1487 goto cleanup; 1488 1489 m = gfc_match_char (')'); 1490 if (m == MATCH_NO) 1491 { 1492 /* Give the matcher for implied do-loops a chance to run. This 1493 yields a much saner error message for (/ (i, 4=i, 6) /). */ 1494 if (gfc_peek_ascii_char () == '=') 1495 { 1496 m = MATCH_ERROR; 1497 goto cleanup; 1498 } 1499 else 1500 goto syntax; 1501 } 1502 1503 if (m == MATCH_ERROR) 1504 goto cleanup; 1505 1506 /* Decide on the kind of this complex number. */ 1507 if (real->ts.type == BT_REAL) 1508 { 1509 if (imag->ts.type == BT_REAL) 1510 kind = gfc_kind_max (real, imag); 1511 else 1512 kind = real->ts.kind; 1513 } 1514 else 1515 { 1516 if (imag->ts.type == BT_REAL) 1517 kind = imag->ts.kind; 1518 else 1519 kind = gfc_default_real_kind; 1520 } 1521 gfc_clear_ts (&target); 1522 target.type = BT_REAL; 1523 target.kind = kind; 1524 1525 if (real->ts.type != BT_REAL || kind != real->ts.kind) 1526 gfc_convert_type (real, &target, 2); 1527 if (imag->ts.type != BT_REAL || kind != imag->ts.kind) 1528 gfc_convert_type (imag, &target, 2); 1529 1530 e = convert_complex (real, imag, kind); 1531 e->where = gfc_current_locus; 1532 1533 gfc_free_expr (real); 1534 gfc_free_expr (imag); 1535 1536 *result = e; 1537 return MATCH_YES; 1538 1539 syntax: 1540 gfc_error ("Syntax error in COMPLEX constant at %C"); 1541 m = MATCH_ERROR; 1542 1543 cleanup: 1544 gfc_free_expr (e); 1545 gfc_free_expr (real); 1546 gfc_free_expr (imag); 1547 gfc_current_locus = old_loc; 1548 1549 return m; 1550 } 1551 1552 1553 /* Match constants in any of several forms. Returns nonzero for a 1554 match, zero for no match. */ 1555 1556 match 1557 gfc_match_literal_constant (gfc_expr **result, int signflag) 1558 { 1559 match m; 1560 1561 m = match_complex_constant (result); 1562 if (m != MATCH_NO) 1563 return m; 1564 1565 m = match_string_constant (result); 1566 if (m != MATCH_NO) 1567 return m; 1568 1569 m = match_boz_constant (result); 1570 if (m != MATCH_NO) 1571 return m; 1572 1573 m = match_real_constant (result, signflag); 1574 if (m != MATCH_NO) 1575 return m; 1576 1577 m = match_hollerith_constant (result); 1578 if (m != MATCH_NO) 1579 return m; 1580 1581 m = match_integer_constant (result, signflag); 1582 if (m != MATCH_NO) 1583 return m; 1584 1585 m = match_logical_constant (result); 1586 if (m != MATCH_NO) 1587 return m; 1588 1589 return MATCH_NO; 1590 } 1591 1592 1593 /* This checks if a symbol is the return value of an encompassing function. 1594 Function nesting can be maximally two levels deep, but we may have 1595 additional local namespaces like BLOCK etc. */ 1596 1597 bool 1598 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns) 1599 { 1600 if (!sym->attr.function || (sym->result != sym)) 1601 return false; 1602 while (ns) 1603 { 1604 if (ns->proc_name == sym) 1605 return true; 1606 ns = ns->parent; 1607 } 1608 return false; 1609 } 1610 1611 1612 /* Match a single actual argument value. An actual argument is 1613 usually an expression, but can also be a procedure name. If the 1614 argument is a single name, it is not always possible to tell 1615 whether the name is a dummy procedure or not. We treat these cases 1616 by creating an argument that looks like a dummy procedure and 1617 fixing things later during resolution. */ 1618 1619 static match 1620 match_actual_arg (gfc_expr **result) 1621 { 1622 char name[GFC_MAX_SYMBOL_LEN + 1]; 1623 gfc_symtree *symtree; 1624 locus where, w; 1625 gfc_expr *e; 1626 char c; 1627 1628 gfc_gobble_whitespace (); 1629 where = gfc_current_locus; 1630 1631 switch (gfc_match_name (name)) 1632 { 1633 case MATCH_ERROR: 1634 return MATCH_ERROR; 1635 1636 case MATCH_NO: 1637 break; 1638 1639 case MATCH_YES: 1640 w = gfc_current_locus; 1641 gfc_gobble_whitespace (); 1642 c = gfc_next_ascii_char (); 1643 gfc_current_locus = w; 1644 1645 if (c != ',' && c != ')') 1646 break; 1647 1648 if (gfc_find_sym_tree (name, NULL, 1, &symtree)) 1649 break; 1650 /* Handle error elsewhere. */ 1651 1652 /* Eliminate a couple of common cases where we know we don't 1653 have a function argument. */ 1654 if (symtree == NULL) 1655 { 1656 gfc_get_sym_tree (name, NULL, &symtree, false); 1657 gfc_set_sym_referenced (symtree->n.sym); 1658 } 1659 else 1660 { 1661 gfc_symbol *sym; 1662 1663 sym = symtree->n.sym; 1664 gfc_set_sym_referenced (sym); 1665 if (sym->attr.flavor == FL_NAMELIST) 1666 { 1667 gfc_error ("Namelist %qs cannot be an argument at %L", 1668 sym->name, &where); 1669 break; 1670 } 1671 if (sym->attr.flavor != FL_PROCEDURE 1672 && sym->attr.flavor != FL_UNKNOWN) 1673 break; 1674 1675 if (sym->attr.in_common && !sym->attr.proc_pointer) 1676 { 1677 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, 1678 sym->name, &sym->declared_at)) 1679 return MATCH_ERROR; 1680 break; 1681 } 1682 1683 /* If the symbol is a function with itself as the result and 1684 is being defined, then we have a variable. */ 1685 if (sym->attr.function && sym->result == sym) 1686 { 1687 if (gfc_is_function_return_value (sym, gfc_current_ns)) 1688 break; 1689 1690 if (sym->attr.entry 1691 && (sym->ns == gfc_current_ns 1692 || sym->ns == gfc_current_ns->parent)) 1693 { 1694 gfc_entry_list *el = NULL; 1695 1696 for (el = sym->ns->entries; el; el = el->next) 1697 if (sym == el->sym) 1698 break; 1699 1700 if (el) 1701 break; 1702 } 1703 } 1704 } 1705 1706 e = gfc_get_expr (); /* Leave it unknown for now */ 1707 e->symtree = symtree; 1708 e->expr_type = EXPR_VARIABLE; 1709 e->ts.type = BT_PROCEDURE; 1710 e->where = where; 1711 1712 *result = e; 1713 return MATCH_YES; 1714 } 1715 1716 gfc_current_locus = where; 1717 return gfc_match_expr (result); 1718 } 1719 1720 1721 /* Match a keyword argument or type parameter spec list.. */ 1722 1723 static match 1724 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt) 1725 { 1726 char name[GFC_MAX_SYMBOL_LEN + 1]; 1727 gfc_actual_arglist *a; 1728 locus name_locus; 1729 match m; 1730 1731 name_locus = gfc_current_locus; 1732 m = gfc_match_name (name); 1733 1734 if (m != MATCH_YES) 1735 goto cleanup; 1736 if (gfc_match_char ('=') != MATCH_YES) 1737 { 1738 m = MATCH_NO; 1739 goto cleanup; 1740 } 1741 1742 if (pdt) 1743 { 1744 if (gfc_match_char ('*') == MATCH_YES) 1745 { 1746 actual->spec_type = SPEC_ASSUMED; 1747 goto add_name; 1748 } 1749 else if (gfc_match_char (':') == MATCH_YES) 1750 { 1751 actual->spec_type = SPEC_DEFERRED; 1752 goto add_name; 1753 } 1754 else 1755 actual->spec_type = SPEC_EXPLICIT; 1756 } 1757 1758 m = match_actual_arg (&actual->expr); 1759 if (m != MATCH_YES) 1760 goto cleanup; 1761 1762 /* Make sure this name has not appeared yet. */ 1763 add_name: 1764 if (name[0] != '\0') 1765 { 1766 for (a = base; a; a = a->next) 1767 if (a->name != NULL && strcmp (a->name, name) == 0) 1768 { 1769 gfc_error ("Keyword %qs at %C has already appeared in the " 1770 "current argument list", name); 1771 return MATCH_ERROR; 1772 } 1773 } 1774 1775 actual->name = gfc_get_string ("%s", name); 1776 return MATCH_YES; 1777 1778 cleanup: 1779 gfc_current_locus = name_locus; 1780 return m; 1781 } 1782 1783 1784 /* Match an argument list function, such as %VAL. */ 1785 1786 static match 1787 match_arg_list_function (gfc_actual_arglist *result) 1788 { 1789 char name[GFC_MAX_SYMBOL_LEN + 1]; 1790 locus old_locus; 1791 match m; 1792 1793 old_locus = gfc_current_locus; 1794 1795 if (gfc_match_char ('%') != MATCH_YES) 1796 { 1797 m = MATCH_NO; 1798 goto cleanup; 1799 } 1800 1801 m = gfc_match ("%n (", name); 1802 if (m != MATCH_YES) 1803 goto cleanup; 1804 1805 if (name[0] != '\0') 1806 { 1807 switch (name[0]) 1808 { 1809 case 'l': 1810 if (gfc_str_startswith (name, "loc")) 1811 { 1812 result->name = "%LOC"; 1813 break; 1814 } 1815 /* FALLTHRU */ 1816 case 'r': 1817 if (gfc_str_startswith (name, "ref")) 1818 { 1819 result->name = "%REF"; 1820 break; 1821 } 1822 /* FALLTHRU */ 1823 case 'v': 1824 if (gfc_str_startswith (name, "val")) 1825 { 1826 result->name = "%VAL"; 1827 break; 1828 } 1829 /* FALLTHRU */ 1830 default: 1831 m = MATCH_ERROR; 1832 goto cleanup; 1833 } 1834 } 1835 1836 if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C")) 1837 { 1838 m = MATCH_ERROR; 1839 goto cleanup; 1840 } 1841 1842 m = match_actual_arg (&result->expr); 1843 if (m != MATCH_YES) 1844 goto cleanup; 1845 1846 if (gfc_match_char (')') != MATCH_YES) 1847 { 1848 m = MATCH_NO; 1849 goto cleanup; 1850 } 1851 1852 return MATCH_YES; 1853 1854 cleanup: 1855 gfc_current_locus = old_locus; 1856 return m; 1857 } 1858 1859 1860 /* Matches an actual argument list of a function or subroutine, from 1861 the opening parenthesis to the closing parenthesis. The argument 1862 list is assumed to allow keyword arguments because we don't know if 1863 the symbol associated with the procedure has an implicit interface 1864 or not. We make sure keywords are unique. If sub_flag is set, 1865 we're matching the argument list of a subroutine. 1866 1867 NOTE: An alternative use for this function is to match type parameter 1868 spec lists, which are so similar to actual argument lists that the 1869 machinery can be reused. This use is flagged by the optional argument 1870 'pdt'. */ 1871 1872 match 1873 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt) 1874 { 1875 gfc_actual_arglist *head, *tail; 1876 int seen_keyword; 1877 gfc_st_label *label; 1878 locus old_loc; 1879 match m; 1880 1881 *argp = tail = NULL; 1882 old_loc = gfc_current_locus; 1883 1884 seen_keyword = 0; 1885 1886 if (gfc_match_char ('(') == MATCH_NO) 1887 return (sub_flag) ? MATCH_YES : MATCH_NO; 1888 1889 if (gfc_match_char (')') == MATCH_YES) 1890 return MATCH_YES; 1891 1892 head = NULL; 1893 1894 matching_actual_arglist++; 1895 1896 for (;;) 1897 { 1898 if (head == NULL) 1899 head = tail = gfc_get_actual_arglist (); 1900 else 1901 { 1902 tail->next = gfc_get_actual_arglist (); 1903 tail = tail->next; 1904 } 1905 1906 if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES) 1907 { 1908 m = gfc_match_st_label (&label); 1909 if (m == MATCH_NO) 1910 gfc_error ("Expected alternate return label at %C"); 1911 if (m != MATCH_YES) 1912 goto cleanup; 1913 1914 if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument " 1915 "at %C")) 1916 goto cleanup; 1917 1918 tail->label = label; 1919 goto next; 1920 } 1921 1922 if (pdt && !seen_keyword) 1923 { 1924 if (gfc_match_char (':') == MATCH_YES) 1925 { 1926 tail->spec_type = SPEC_DEFERRED; 1927 goto next; 1928 } 1929 else if (gfc_match_char ('*') == MATCH_YES) 1930 { 1931 tail->spec_type = SPEC_ASSUMED; 1932 goto next; 1933 } 1934 else 1935 tail->spec_type = SPEC_EXPLICIT; 1936 1937 m = match_keyword_arg (tail, head, pdt); 1938 if (m == MATCH_YES) 1939 { 1940 seen_keyword = 1; 1941 goto next; 1942 } 1943 if (m == MATCH_ERROR) 1944 goto cleanup; 1945 } 1946 1947 /* After the first keyword argument is seen, the following 1948 arguments must also have keywords. */ 1949 if (seen_keyword) 1950 { 1951 m = match_keyword_arg (tail, head, pdt); 1952 1953 if (m == MATCH_ERROR) 1954 goto cleanup; 1955 if (m == MATCH_NO) 1956 { 1957 gfc_error ("Missing keyword name in actual argument list at %C"); 1958 goto cleanup; 1959 } 1960 1961 } 1962 else 1963 { 1964 /* Try an argument list function, like %VAL. */ 1965 m = match_arg_list_function (tail); 1966 if (m == MATCH_ERROR) 1967 goto cleanup; 1968 1969 /* See if we have the first keyword argument. */ 1970 if (m == MATCH_NO) 1971 { 1972 m = match_keyword_arg (tail, head, false); 1973 if (m == MATCH_YES) 1974 seen_keyword = 1; 1975 if (m == MATCH_ERROR) 1976 goto cleanup; 1977 } 1978 1979 if (m == MATCH_NO) 1980 { 1981 /* Try for a non-keyword argument. */ 1982 m = match_actual_arg (&tail->expr); 1983 if (m == MATCH_ERROR) 1984 goto cleanup; 1985 if (m == MATCH_NO) 1986 goto syntax; 1987 } 1988 } 1989 1990 1991 next: 1992 if (gfc_match_char (')') == MATCH_YES) 1993 break; 1994 if (gfc_match_char (',') != MATCH_YES) 1995 goto syntax; 1996 } 1997 1998 *argp = head; 1999 matching_actual_arglist--; 2000 return MATCH_YES; 2001 2002 syntax: 2003 gfc_error ("Syntax error in argument list at %C"); 2004 2005 cleanup: 2006 gfc_free_actual_arglist (head); 2007 gfc_current_locus = old_loc; 2008 matching_actual_arglist--; 2009 return MATCH_ERROR; 2010 } 2011 2012 2013 /* Used by gfc_match_varspec() to extend the reference list by one 2014 element. */ 2015 2016 static gfc_ref * 2017 extend_ref (gfc_expr *primary, gfc_ref *tail) 2018 { 2019 if (primary->ref == NULL) 2020 primary->ref = tail = gfc_get_ref (); 2021 else 2022 { 2023 if (tail == NULL) 2024 gfc_internal_error ("extend_ref(): Bad tail"); 2025 tail->next = gfc_get_ref (); 2026 tail = tail->next; 2027 } 2028 2029 return tail; 2030 } 2031 2032 2033 /* Used by gfc_match_varspec() to match an inquiry reference. */ 2034 2035 static bool 2036 is_inquiry_ref (const char *name, gfc_ref **ref) 2037 { 2038 inquiry_type type; 2039 2040 if (name == NULL) 2041 return false; 2042 2043 if (ref) *ref = NULL; 2044 2045 if (strcmp (name, "re") == 0) 2046 type = INQUIRY_RE; 2047 else if (strcmp (name, "im") == 0) 2048 type = INQUIRY_IM; 2049 else if (strcmp (name, "kind") == 0) 2050 type = INQUIRY_KIND; 2051 else if (strcmp (name, "len") == 0) 2052 type = INQUIRY_LEN; 2053 else 2054 return false; 2055 2056 if (ref) 2057 { 2058 *ref = gfc_get_ref (); 2059 (*ref)->type = REF_INQUIRY; 2060 (*ref)->u.i = type; 2061 } 2062 2063 return true; 2064 } 2065 2066 2067 /* Match any additional specifications associated with the current 2068 variable like member references or substrings. If equiv_flag is 2069 set we only match stuff that is allowed inside an EQUIVALENCE 2070 statement. sub_flag tells whether we expect a type-bound procedure found 2071 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer 2072 components, 'ppc_arg' determines whether the PPC may be called (with an 2073 argument list), or whether it may just be referred to as a pointer. */ 2074 2075 match 2076 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, 2077 bool ppc_arg) 2078 { 2079 char name[GFC_MAX_SYMBOL_LEN + 1]; 2080 gfc_ref *substring, *tail, *tmp; 2081 gfc_component *component = NULL; 2082 gfc_component *previous = NULL; 2083 gfc_symbol *sym = primary->symtree->n.sym; 2084 gfc_expr *tgt_expr = NULL; 2085 match m; 2086 bool unknown; 2087 bool inquiry; 2088 bool intrinsic; 2089 locus old_loc; 2090 char sep; 2091 2092 tail = NULL; 2093 2094 gfc_gobble_whitespace (); 2095 2096 if (gfc_peek_ascii_char () == '[') 2097 { 2098 if ((sym->ts.type != BT_CLASS && sym->attr.dimension) 2099 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 2100 && CLASS_DATA (sym)->attr.dimension)) 2101 { 2102 gfc_error ("Array section designator, e.g. '(:)', is required " 2103 "besides the coarray designator '[...]' at %C"); 2104 return MATCH_ERROR; 2105 } 2106 if ((sym->ts.type != BT_CLASS && !sym->attr.codimension) 2107 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 2108 && !CLASS_DATA (sym)->attr.codimension)) 2109 { 2110 gfc_error ("Coarray designator at %C but %qs is not a coarray", 2111 sym->name); 2112 return MATCH_ERROR; 2113 } 2114 } 2115 2116 if (sym->assoc && sym->assoc->target) 2117 tgt_expr = sym->assoc->target; 2118 2119 /* For associate names, we may not yet know whether they are arrays or not. 2120 If the selector expression is unambiguously an array; eg. a full array 2121 or an array section, then the associate name must be an array and we can 2122 fix it now. Otherwise, if parentheses follow and it is not a character 2123 type, we have to assume that it actually is one for now. The final 2124 decision will be made at resolution, of course. */ 2125 if (sym->assoc 2126 && gfc_peek_ascii_char () == '(' 2127 && sym->ts.type != BT_CLASS 2128 && !sym->attr.dimension) 2129 { 2130 gfc_ref *ref = NULL; 2131 2132 if (!sym->assoc->dangling && tgt_expr) 2133 { 2134 if (tgt_expr->expr_type == EXPR_VARIABLE) 2135 gfc_resolve_expr (tgt_expr); 2136 2137 ref = tgt_expr->ref; 2138 for (; ref; ref = ref->next) 2139 if (ref->type == REF_ARRAY 2140 && (ref->u.ar.type == AR_FULL 2141 || ref->u.ar.type == AR_SECTION)) 2142 break; 2143 } 2144 2145 if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER) 2146 && sym->assoc->st 2147 && sym->assoc->st->n.sym 2148 && sym->assoc->st->n.sym->attr.dimension == 0)) 2149 { 2150 sym->attr.dimension = 1; 2151 if (sym->as == NULL 2152 && sym->assoc->st 2153 && sym->assoc->st->n.sym 2154 && sym->assoc->st->n.sym->as) 2155 sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as); 2156 } 2157 } 2158 else if (sym->ts.type == BT_CLASS 2159 && tgt_expr 2160 && tgt_expr->expr_type == EXPR_VARIABLE 2161 && sym->ts.u.derived != tgt_expr->ts.u.derived) 2162 { 2163 gfc_resolve_expr (tgt_expr); 2164 if (tgt_expr->rank) 2165 sym->ts.u.derived = tgt_expr->ts.u.derived; 2166 } 2167 2168 if ((equiv_flag && gfc_peek_ascii_char () == '(') 2169 || gfc_peek_ascii_char () == '[' || sym->attr.codimension 2170 || (sym->attr.dimension && sym->ts.type != BT_CLASS 2171 && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary) 2172 && !(gfc_matching_procptr_assignment 2173 && sym->attr.flavor == FL_PROCEDURE)) 2174 || (sym->ts.type == BT_CLASS && sym->attr.class_ok 2175 && sym->ts.u.derived && CLASS_DATA (sym) 2176 && (CLASS_DATA (sym)->attr.dimension 2177 || CLASS_DATA (sym)->attr.codimension))) 2178 { 2179 gfc_array_spec *as; 2180 2181 tail = extend_ref (primary, tail); 2182 tail->type = REF_ARRAY; 2183 2184 /* In EQUIVALENCE, we don't know yet whether we are seeing 2185 an array, character variable or array of character 2186 variables. We'll leave the decision till resolve time. */ 2187 2188 if (equiv_flag) 2189 as = NULL; 2190 else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) 2191 as = CLASS_DATA (sym)->as; 2192 else 2193 as = sym->as; 2194 2195 m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, 2196 as ? as->corank : 0); 2197 if (m != MATCH_YES) 2198 return m; 2199 2200 gfc_gobble_whitespace (); 2201 if (equiv_flag && gfc_peek_ascii_char () == '(') 2202 { 2203 tail = extend_ref (primary, tail); 2204 tail->type = REF_ARRAY; 2205 2206 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0); 2207 if (m != MATCH_YES) 2208 return m; 2209 } 2210 } 2211 2212 primary->ts = sym->ts; 2213 2214 if (equiv_flag) 2215 return MATCH_YES; 2216 2217 /* With DEC extensions, member separator may be '.' or '%'. */ 2218 sep = gfc_peek_ascii_char (); 2219 m = gfc_match_member_sep (sym); 2220 if (m == MATCH_ERROR) 2221 return MATCH_ERROR; 2222 2223 inquiry = false; 2224 if (m == MATCH_YES && sep == '%' 2225 && primary->ts.type != BT_CLASS 2226 && primary->ts.type != BT_DERIVED) 2227 { 2228 match mm; 2229 old_loc = gfc_current_locus; 2230 mm = gfc_match_name (name); 2231 if (mm == MATCH_YES && is_inquiry_ref (name, &tmp)) 2232 inquiry = true; 2233 gfc_current_locus = old_loc; 2234 } 2235 2236 if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES 2237 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) 2238 gfc_set_default_type (sym, 0, sym->ns); 2239 2240 /* See if there is a usable typespec in the "no IMPLICIT type" error. */ 2241 if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES) 2242 { 2243 bool permissible; 2244 2245 /* These target expressions can be resolved at any time. */ 2246 permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym 2247 && (tgt_expr->symtree->n.sym->attr.use_assoc 2248 || tgt_expr->symtree->n.sym->attr.host_assoc 2249 || tgt_expr->symtree->n.sym->attr.if_source 2250 == IFSRC_DECL); 2251 permissible = permissible 2252 || (tgt_expr && tgt_expr->expr_type == EXPR_OP); 2253 2254 if (permissible) 2255 { 2256 gfc_resolve_expr (tgt_expr); 2257 sym->ts = tgt_expr->ts; 2258 } 2259 2260 if (sym->ts.type == BT_UNKNOWN) 2261 { 2262 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name); 2263 return MATCH_ERROR; 2264 } 2265 } 2266 else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) 2267 && m == MATCH_YES && !inquiry) 2268 { 2269 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C", 2270 sep, sym->name); 2271 return MATCH_ERROR; 2272 } 2273 2274 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry) 2275 || m != MATCH_YES) 2276 goto check_substring; 2277 2278 if (!inquiry) 2279 sym = sym->ts.u.derived; 2280 else 2281 sym = NULL; 2282 2283 for (;;) 2284 { 2285 bool t; 2286 gfc_symtree *tbp; 2287 2288 m = gfc_match_name (name); 2289 if (m == MATCH_NO) 2290 gfc_error ("Expected structure component name at %C"); 2291 if (m != MATCH_YES) 2292 return MATCH_ERROR; 2293 2294 intrinsic = false; 2295 if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED) 2296 { 2297 inquiry = is_inquiry_ref (name, &tmp); 2298 if (inquiry) 2299 sym = NULL; 2300 2301 if (sep == '%') 2302 { 2303 if (tmp) 2304 { 2305 switch (tmp->u.i) 2306 { 2307 case INQUIRY_RE: 2308 case INQUIRY_IM: 2309 if (!gfc_notify_std (GFC_STD_F2008, 2310 "RE or IM part_ref at %C")) 2311 return MATCH_ERROR; 2312 break; 2313 2314 case INQUIRY_KIND: 2315 if (!gfc_notify_std (GFC_STD_F2003, 2316 "KIND part_ref at %C")) 2317 return MATCH_ERROR; 2318 break; 2319 2320 case INQUIRY_LEN: 2321 if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) 2322 return MATCH_ERROR; 2323 break; 2324 } 2325 2326 if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM) 2327 && primary->ts.type != BT_COMPLEX) 2328 { 2329 gfc_error ("The RE or IM part_ref at %C must be " 2330 "applied to a COMPLEX expression"); 2331 return MATCH_ERROR; 2332 } 2333 else if (tmp->u.i == INQUIRY_LEN 2334 && primary->ts.type != BT_CHARACTER) 2335 { 2336 gfc_error ("The LEN part_ref at %C must be applied " 2337 "to a CHARACTER expression"); 2338 return MATCH_ERROR; 2339 } 2340 } 2341 if (primary->ts.type != BT_UNKNOWN) 2342 intrinsic = true; 2343 } 2344 } 2345 else 2346 inquiry = false; 2347 2348 if (sym && sym->f2k_derived) 2349 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus); 2350 else 2351 tbp = NULL; 2352 2353 if (tbp) 2354 { 2355 gfc_symbol* tbp_sym; 2356 2357 if (!t) 2358 return MATCH_ERROR; 2359 2360 gcc_assert (!tail || !tail->next); 2361 2362 if (!(primary->expr_type == EXPR_VARIABLE 2363 || (primary->expr_type == EXPR_STRUCTURE 2364 && primary->symtree && primary->symtree->n.sym 2365 && primary->symtree->n.sym->attr.flavor))) 2366 return MATCH_ERROR; 2367 2368 if (tbp->n.tb->is_generic) 2369 tbp_sym = NULL; 2370 else 2371 tbp_sym = tbp->n.tb->u.specific->n.sym; 2372 2373 primary->expr_type = EXPR_COMPCALL; 2374 primary->value.compcall.tbp = tbp->n.tb; 2375 primary->value.compcall.name = tbp->name; 2376 primary->value.compcall.ignore_pass = 0; 2377 primary->value.compcall.assign = 0; 2378 primary->value.compcall.base_object = NULL; 2379 gcc_assert (primary->symtree->n.sym->attr.referenced); 2380 if (tbp_sym) 2381 primary->ts = tbp_sym->ts; 2382 else 2383 gfc_clear_ts (&primary->ts); 2384 2385 m = gfc_match_actual_arglist (tbp->n.tb->subroutine, 2386 &primary->value.compcall.actual); 2387 if (m == MATCH_ERROR) 2388 return MATCH_ERROR; 2389 if (m == MATCH_NO) 2390 { 2391 if (sub_flag) 2392 primary->value.compcall.actual = NULL; 2393 else 2394 { 2395 gfc_error ("Expected argument list at %C"); 2396 return MATCH_ERROR; 2397 } 2398 } 2399 2400 break; 2401 } 2402 2403 previous = component; 2404 2405 if (!inquiry && !intrinsic) 2406 component = gfc_find_component (sym, name, false, false, &tmp); 2407 else 2408 component = NULL; 2409 2410 if (intrinsic && !inquiry) 2411 { 2412 if (previous) 2413 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic " 2414 "type component %qs", name, previous->name); 2415 else 2416 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic " 2417 "type component", name); 2418 return MATCH_ERROR; 2419 } 2420 else if (component == NULL && !inquiry) 2421 return MATCH_ERROR; 2422 2423 /* Extend the reference chain determined by gfc_find_component or 2424 is_inquiry_ref. */ 2425 if (primary->ref == NULL) 2426 primary->ref = tmp; 2427 else 2428 { 2429 /* Set by the for loop below for the last component ref. */ 2430 gcc_assert (tail != NULL); 2431 tail->next = tmp; 2432 } 2433 2434 /* The reference chain may be longer than one hop for union 2435 subcomponents; find the new tail. */ 2436 for (tail = tmp; tail->next; tail = tail->next) 2437 ; 2438 2439 if (tmp && tmp->type == REF_INQUIRY) 2440 { 2441 if (!primary->where.lb || !primary->where.nextc) 2442 primary->where = gfc_current_locus; 2443 gfc_simplify_expr (primary, 0); 2444 2445 if (primary->expr_type == EXPR_CONSTANT) 2446 goto check_done; 2447 2448 switch (tmp->u.i) 2449 { 2450 case INQUIRY_RE: 2451 case INQUIRY_IM: 2452 if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C")) 2453 return MATCH_ERROR; 2454 2455 if (primary->ts.type != BT_COMPLEX) 2456 { 2457 gfc_error ("The RE or IM part_ref at %C must be " 2458 "applied to a COMPLEX expression"); 2459 return MATCH_ERROR; 2460 } 2461 primary->ts.type = BT_REAL; 2462 break; 2463 2464 case INQUIRY_LEN: 2465 if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) 2466 return MATCH_ERROR; 2467 2468 if (primary->ts.type != BT_CHARACTER) 2469 { 2470 gfc_error ("The LEN part_ref at %C must be applied " 2471 "to a CHARACTER expression"); 2472 return MATCH_ERROR; 2473 } 2474 primary->ts.u.cl = NULL; 2475 primary->ts.type = BT_INTEGER; 2476 primary->ts.kind = gfc_default_integer_kind; 2477 break; 2478 2479 case INQUIRY_KIND: 2480 if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) 2481 return MATCH_ERROR; 2482 2483 if (primary->ts.type == BT_CLASS 2484 || primary->ts.type == BT_DERIVED) 2485 { 2486 gfc_error ("The KIND part_ref at %C must be applied " 2487 "to an expression of intrinsic type"); 2488 return MATCH_ERROR; 2489 } 2490 primary->ts.type = BT_INTEGER; 2491 primary->ts.kind = gfc_default_integer_kind; 2492 break; 2493 2494 default: 2495 gcc_unreachable (); 2496 } 2497 2498 goto check_done; 2499 } 2500 2501 primary->ts = component->ts; 2502 2503 if (component->attr.proc_pointer && ppc_arg) 2504 { 2505 /* Procedure pointer component call: Look for argument list. */ 2506 m = gfc_match_actual_arglist (sub_flag, 2507 &primary->value.compcall.actual); 2508 if (m == MATCH_ERROR) 2509 return MATCH_ERROR; 2510 2511 if (m == MATCH_NO && !gfc_matching_ptr_assignment 2512 && !gfc_matching_procptr_assignment && !matching_actual_arglist) 2513 { 2514 gfc_error ("Procedure pointer component %qs requires an " 2515 "argument list at %C", component->name); 2516 return MATCH_ERROR; 2517 } 2518 2519 if (m == MATCH_YES) 2520 primary->expr_type = EXPR_PPC; 2521 2522 break; 2523 } 2524 2525 if (component->as != NULL && !component->attr.proc_pointer) 2526 { 2527 tail = extend_ref (primary, tail); 2528 tail->type = REF_ARRAY; 2529 2530 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag, 2531 component->as->corank); 2532 if (m != MATCH_YES) 2533 return m; 2534 } 2535 else if (component->ts.type == BT_CLASS && component->attr.class_ok 2536 && CLASS_DATA (component)->as && !component->attr.proc_pointer) 2537 { 2538 tail = extend_ref (primary, tail); 2539 tail->type = REF_ARRAY; 2540 2541 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as, 2542 equiv_flag, 2543 CLASS_DATA (component)->as->corank); 2544 if (m != MATCH_YES) 2545 return m; 2546 } 2547 2548 check_done: 2549 /* In principle, we could have eg. expr%re%kind so we must allow for 2550 this possibility. */ 2551 if (gfc_match_char ('%') == MATCH_YES) 2552 { 2553 if (component && (component->ts.type == BT_DERIVED 2554 || component->ts.type == BT_CLASS)) 2555 sym = component->ts.u.derived; 2556 continue; 2557 } 2558 else if (inquiry) 2559 break; 2560 2561 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS) 2562 || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES) 2563 break; 2564 2565 if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS) 2566 sym = component->ts.u.derived; 2567 } 2568 2569 check_substring: 2570 unknown = false; 2571 if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor)) 2572 { 2573 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER) 2574 { 2575 gfc_set_default_type (sym, 0, sym->ns); 2576 primary->ts = sym->ts; 2577 unknown = true; 2578 } 2579 } 2580 2581 if (primary->ts.type == BT_CHARACTER) 2582 { 2583 bool def = primary->ts.deferred == 1; 2584 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def)) 2585 { 2586 case MATCH_YES: 2587 if (tail == NULL) 2588 primary->ref = substring; 2589 else 2590 tail->next = substring; 2591 2592 if (primary->expr_type == EXPR_CONSTANT) 2593 primary->expr_type = EXPR_SUBSTRING; 2594 2595 if (substring) 2596 primary->ts.u.cl = NULL; 2597 2598 break; 2599 2600 case MATCH_NO: 2601 if (unknown) 2602 { 2603 gfc_clear_ts (&primary->ts); 2604 gfc_clear_ts (&sym->ts); 2605 } 2606 break; 2607 2608 case MATCH_ERROR: 2609 return MATCH_ERROR; 2610 } 2611 } 2612 2613 /* F08:C611. */ 2614 if (primary->ts.type == BT_DERIVED && primary->ref 2615 && primary->ts.u.derived && primary->ts.u.derived->attr.abstract) 2616 { 2617 gfc_error ("Nonpolymorphic reference to abstract type at %C"); 2618 return MATCH_ERROR; 2619 } 2620 2621 /* F08:C727. */ 2622 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary)) 2623 { 2624 gfc_error ("Coindexed procedure-pointer component at %C"); 2625 return MATCH_ERROR; 2626 } 2627 2628 return MATCH_YES; 2629 } 2630 2631 2632 /* Given an expression that is a variable, figure out what the 2633 ultimate variable's type and attribute is, traversing the reference 2634 structures if necessary. 2635 2636 This subroutine is trickier than it looks. We start at the base 2637 symbol and store the attribute. Component references load a 2638 completely new attribute. 2639 2640 A couple of rules come into play. Subobjects of targets are always 2641 targets themselves. If we see a component that goes through a 2642 pointer, then the expression must also be a target, since the 2643 pointer is associated with something (if it isn't core will soon be 2644 dumped). If we see a full part or section of an array, the 2645 expression is also an array. 2646 2647 We can have at most one full array reference. */ 2648 2649 symbol_attribute 2650 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) 2651 { 2652 int dimension, codimension, pointer, allocatable, target; 2653 symbol_attribute attr; 2654 gfc_ref *ref; 2655 gfc_symbol *sym; 2656 gfc_component *comp; 2657 bool has_inquiry_part; 2658 2659 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) 2660 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable"); 2661 2662 sym = expr->symtree->n.sym; 2663 attr = sym->attr; 2664 2665 if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) 2666 { 2667 dimension = CLASS_DATA (sym)->attr.dimension; 2668 codimension = CLASS_DATA (sym)->attr.codimension; 2669 pointer = CLASS_DATA (sym)->attr.class_pointer; 2670 allocatable = CLASS_DATA (sym)->attr.allocatable; 2671 } 2672 else 2673 { 2674 dimension = attr.dimension; 2675 codimension = attr.codimension; 2676 pointer = attr.pointer; 2677 allocatable = attr.allocatable; 2678 } 2679 2680 target = attr.target; 2681 if (pointer || attr.proc_pointer) 2682 target = 1; 2683 2684 if (ts != NULL && expr->ts.type == BT_UNKNOWN) 2685 *ts = sym->ts; 2686 2687 has_inquiry_part = false; 2688 for (ref = expr->ref; ref; ref = ref->next) 2689 if (ref->type == REF_INQUIRY) 2690 { 2691 has_inquiry_part = true; 2692 break; 2693 } 2694 2695 for (ref = expr->ref; ref; ref = ref->next) 2696 switch (ref->type) 2697 { 2698 case REF_ARRAY: 2699 2700 switch (ref->u.ar.type) 2701 { 2702 case AR_FULL: 2703 dimension = 1; 2704 break; 2705 2706 case AR_SECTION: 2707 allocatable = pointer = 0; 2708 dimension = 1; 2709 break; 2710 2711 case AR_ELEMENT: 2712 /* Handle coarrays. */ 2713 if (ref->u.ar.dimen > 0) 2714 allocatable = pointer = 0; 2715 break; 2716 2717 case AR_UNKNOWN: 2718 /* For standard conforming code, AR_UNKNOWN should not happen. 2719 For nonconforming code, gfortran can end up here. Treat it 2720 as a no-op. */ 2721 break; 2722 } 2723 2724 break; 2725 2726 case REF_COMPONENT: 2727 comp = ref->u.c.component; 2728 attr = comp->attr; 2729 if (ts != NULL && !has_inquiry_part) 2730 { 2731 *ts = comp->ts; 2732 /* Don't set the string length if a substring reference 2733 follows. */ 2734 if (ts->type == BT_CHARACTER 2735 && ref->next && ref->next->type == REF_SUBSTRING) 2736 ts->u.cl = NULL; 2737 } 2738 2739 if (comp->ts.type == BT_CLASS) 2740 { 2741 codimension = CLASS_DATA (comp)->attr.codimension; 2742 pointer = CLASS_DATA (comp)->attr.class_pointer; 2743 allocatable = CLASS_DATA (comp)->attr.allocatable; 2744 } 2745 else 2746 { 2747 codimension = comp->attr.codimension; 2748 pointer = comp->attr.pointer; 2749 allocatable = comp->attr.allocatable; 2750 } 2751 if (pointer || attr.proc_pointer) 2752 target = 1; 2753 2754 break; 2755 2756 case REF_INQUIRY: 2757 case REF_SUBSTRING: 2758 allocatable = pointer = 0; 2759 break; 2760 } 2761 2762 attr.dimension = dimension; 2763 attr.codimension = codimension; 2764 attr.pointer = pointer; 2765 attr.allocatable = allocatable; 2766 attr.target = target; 2767 attr.save = sym->attr.save; 2768 2769 return attr; 2770 } 2771 2772 2773 /* Return the attribute from a general expression. */ 2774 2775 symbol_attribute 2776 gfc_expr_attr (gfc_expr *e) 2777 { 2778 symbol_attribute attr; 2779 2780 switch (e->expr_type) 2781 { 2782 case EXPR_VARIABLE: 2783 attr = gfc_variable_attr (e, NULL); 2784 break; 2785 2786 case EXPR_FUNCTION: 2787 gfc_clear_attr (&attr); 2788 2789 if (e->value.function.esym && e->value.function.esym->result) 2790 { 2791 gfc_symbol *sym = e->value.function.esym->result; 2792 attr = sym->attr; 2793 if (sym->ts.type == BT_CLASS) 2794 { 2795 attr.dimension = CLASS_DATA (sym)->attr.dimension; 2796 attr.pointer = CLASS_DATA (sym)->attr.class_pointer; 2797 attr.allocatable = CLASS_DATA (sym)->attr.allocatable; 2798 } 2799 } 2800 else if (e->value.function.isym 2801 && e->value.function.isym->transformational 2802 && e->ts.type == BT_CLASS) 2803 attr = CLASS_DATA (e)->attr; 2804 else 2805 attr = gfc_variable_attr (e, NULL); 2806 2807 /* TODO: NULL() returns pointers. May have to take care of this 2808 here. */ 2809 2810 break; 2811 2812 default: 2813 gfc_clear_attr (&attr); 2814 break; 2815 } 2816 2817 return attr; 2818 } 2819 2820 2821 /* Given an expression, figure out what the ultimate expression 2822 attribute is. This routine is similar to gfc_variable_attr with 2823 parts of gfc_expr_attr, but focuses more on the needs of 2824 coarrays. For coarrays a codimension attribute is kind of 2825 "infectious" being propagated once set and never cleared. 2826 The coarray_comp is only set, when the expression refs a coarray 2827 component. REFS_COMP is set when present to true only, when this EXPR 2828 refs a (non-_data) component. To check whether EXPR refs an allocatable 2829 component in a derived type coarray *refs_comp needs to be set and 2830 coarray_comp has to false. */ 2831 2832 static symbol_attribute 2833 caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp) 2834 { 2835 int dimension, codimension, pointer, allocatable, target, coarray_comp; 2836 symbol_attribute attr; 2837 gfc_ref *ref; 2838 gfc_symbol *sym; 2839 gfc_component *comp; 2840 2841 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) 2842 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable"); 2843 2844 sym = expr->symtree->n.sym; 2845 gfc_clear_attr (&attr); 2846 2847 if (refs_comp) 2848 *refs_comp = false; 2849 2850 if (sym->ts.type == BT_CLASS && sym->attr.class_ok) 2851 { 2852 dimension = CLASS_DATA (sym)->attr.dimension; 2853 codimension = CLASS_DATA (sym)->attr.codimension; 2854 pointer = CLASS_DATA (sym)->attr.class_pointer; 2855 allocatable = CLASS_DATA (sym)->attr.allocatable; 2856 attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp; 2857 attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp; 2858 } 2859 else 2860 { 2861 dimension = sym->attr.dimension; 2862 codimension = sym->attr.codimension; 2863 pointer = sym->attr.pointer; 2864 allocatable = sym->attr.allocatable; 2865 attr.alloc_comp = sym->ts.type == BT_DERIVED 2866 ? sym->ts.u.derived->attr.alloc_comp : 0; 2867 attr.pointer_comp = sym->ts.type == BT_DERIVED 2868 ? sym->ts.u.derived->attr.pointer_comp : 0; 2869 } 2870 2871 target = coarray_comp = 0; 2872 if (pointer || attr.proc_pointer) 2873 target = 1; 2874 2875 for (ref = expr->ref; ref; ref = ref->next) 2876 switch (ref->type) 2877 { 2878 case REF_ARRAY: 2879 2880 switch (ref->u.ar.type) 2881 { 2882 case AR_FULL: 2883 case AR_SECTION: 2884 dimension = 1; 2885 break; 2886 2887 case AR_ELEMENT: 2888 /* Handle coarrays. */ 2889 if (ref->u.ar.dimen > 0 && !in_allocate) 2890 allocatable = pointer = 0; 2891 break; 2892 2893 case AR_UNKNOWN: 2894 /* If any of start, end or stride is not integer, there will 2895 already have been an error issued. */ 2896 int errors; 2897 gfc_get_errors (NULL, &errors); 2898 if (errors == 0) 2899 gfc_internal_error ("gfc_caf_attr(): Bad array reference"); 2900 } 2901 2902 break; 2903 2904 case REF_COMPONENT: 2905 comp = ref->u.c.component; 2906 2907 if (comp->ts.type == BT_CLASS) 2908 { 2909 /* Set coarray_comp only, when this component introduces the 2910 coarray. */ 2911 coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension; 2912 codimension |= CLASS_DATA (comp)->attr.codimension; 2913 pointer = CLASS_DATA (comp)->attr.class_pointer; 2914 allocatable = CLASS_DATA (comp)->attr.allocatable; 2915 } 2916 else 2917 { 2918 /* Set coarray_comp only, when this component introduces the 2919 coarray. */ 2920 coarray_comp = !codimension && comp->attr.codimension; 2921 codimension |= comp->attr.codimension; 2922 pointer = comp->attr.pointer; 2923 allocatable = comp->attr.allocatable; 2924 } 2925 2926 if (refs_comp && strcmp (comp->name, "_data") != 0 2927 && (ref->next == NULL 2928 || (ref->next->type == REF_ARRAY && ref->next->next == NULL))) 2929 *refs_comp = true; 2930 2931 if (pointer || attr.proc_pointer) 2932 target = 1; 2933 2934 break; 2935 2936 case REF_SUBSTRING: 2937 case REF_INQUIRY: 2938 allocatable = pointer = 0; 2939 break; 2940 } 2941 2942 attr.dimension = dimension; 2943 attr.codimension = codimension; 2944 attr.pointer = pointer; 2945 attr.allocatable = allocatable; 2946 attr.target = target; 2947 attr.save = sym->attr.save; 2948 attr.coarray_comp = coarray_comp; 2949 2950 return attr; 2951 } 2952 2953 2954 symbol_attribute 2955 gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp) 2956 { 2957 symbol_attribute attr; 2958 2959 switch (e->expr_type) 2960 { 2961 case EXPR_VARIABLE: 2962 attr = caf_variable_attr (e, in_allocate, refs_comp); 2963 break; 2964 2965 case EXPR_FUNCTION: 2966 gfc_clear_attr (&attr); 2967 2968 if (e->value.function.esym && e->value.function.esym->result) 2969 { 2970 gfc_symbol *sym = e->value.function.esym->result; 2971 attr = sym->attr; 2972 if (sym->ts.type == BT_CLASS) 2973 { 2974 attr.dimension = CLASS_DATA (sym)->attr.dimension; 2975 attr.pointer = CLASS_DATA (sym)->attr.class_pointer; 2976 attr.allocatable = CLASS_DATA (sym)->attr.allocatable; 2977 attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp; 2978 attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived 2979 ->attr.pointer_comp; 2980 } 2981 } 2982 else if (e->symtree) 2983 attr = caf_variable_attr (e, in_allocate, refs_comp); 2984 else 2985 gfc_clear_attr (&attr); 2986 break; 2987 2988 default: 2989 gfc_clear_attr (&attr); 2990 break; 2991 } 2992 2993 return attr; 2994 } 2995 2996 2997 /* Match a structure constructor. The initial symbol has already been 2998 seen. */ 2999 3000 typedef struct gfc_structure_ctor_component 3001 { 3002 char* name; 3003 gfc_expr* val; 3004 locus where; 3005 struct gfc_structure_ctor_component* next; 3006 } 3007 gfc_structure_ctor_component; 3008 3009 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component) 3010 3011 static void 3012 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp) 3013 { 3014 free (comp->name); 3015 gfc_free_expr (comp->val); 3016 free (comp); 3017 } 3018 3019 3020 /* Translate the component list into the actual constructor by sorting it in 3021 the order required; this also checks along the way that each and every 3022 component actually has an initializer and handles default initializers 3023 for components without explicit value given. */ 3024 static bool 3025 build_actual_constructor (gfc_structure_ctor_component **comp_head, 3026 gfc_constructor_base *ctor_head, gfc_symbol *sym) 3027 { 3028 gfc_structure_ctor_component *comp_iter; 3029 gfc_component *comp; 3030 3031 for (comp = sym->components; comp; comp = comp->next) 3032 { 3033 gfc_structure_ctor_component **next_ptr; 3034 gfc_expr *value = NULL; 3035 3036 /* Try to find the initializer for the current component by name. */ 3037 next_ptr = comp_head; 3038 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next) 3039 { 3040 if (!strcmp (comp_iter->name, comp->name)) 3041 break; 3042 next_ptr = &comp_iter->next; 3043 } 3044 3045 /* If an extension, try building the parent derived type by building 3046 a value expression for the parent derived type and calling self. */ 3047 if (!comp_iter && comp == sym->components && sym->attr.extension) 3048 { 3049 value = gfc_get_structure_constructor_expr (comp->ts.type, 3050 comp->ts.kind, 3051 &gfc_current_locus); 3052 value->ts = comp->ts; 3053 3054 if (!build_actual_constructor (comp_head, 3055 &value->value.constructor, 3056 comp->ts.u.derived)) 3057 { 3058 gfc_free_expr (value); 3059 return false; 3060 } 3061 3062 gfc_constructor_append_expr (ctor_head, value, NULL); 3063 continue; 3064 } 3065 3066 /* If it was not found, apply NULL expression to set the component as 3067 unallocated. Then try the default initializer if there's any; 3068 otherwise, it's an error unless this is a deferred parameter. */ 3069 if (!comp_iter) 3070 { 3071 /* F2018 7.5.10: If an allocatable component has no corresponding 3072 component-data-source, then that component has an allocation 3073 status of unallocated.... */ 3074 if (comp->attr.allocatable 3075 || (comp->ts.type == BT_CLASS 3076 && CLASS_DATA (comp)->attr.allocatable)) 3077 { 3078 if (!gfc_notify_std (GFC_STD_F2008, "No initializer for " 3079 "allocatable component %qs given in the " 3080 "structure constructor at %C", comp->name)) 3081 return false; 3082 value = gfc_get_null_expr (&gfc_current_locus); 3083 } 3084 /* ....(Preceeding sentence) If a component with default 3085 initialization has no corresponding component-data-source, then 3086 the default initialization is applied to that component. */ 3087 else if (comp->initializer) 3088 { 3089 if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor " 3090 "with missing optional arguments at %C")) 3091 return false; 3092 value = gfc_copy_expr (comp->initializer); 3093 } 3094 /* Do not trap components such as the string length for deferred 3095 length character components. */ 3096 else if (!comp->attr.artificial) 3097 { 3098 gfc_error ("No initializer for component %qs given in the" 3099 " structure constructor at %C", comp->name); 3100 return false; 3101 } 3102 } 3103 else 3104 value = comp_iter->val; 3105 3106 /* Add the value to the constructor chain built. */ 3107 gfc_constructor_append_expr (ctor_head, value, NULL); 3108 3109 /* Remove the entry from the component list. We don't want the expression 3110 value to be free'd, so set it to NULL. */ 3111 if (comp_iter) 3112 { 3113 *next_ptr = comp_iter->next; 3114 comp_iter->val = NULL; 3115 gfc_free_structure_ctor_component (comp_iter); 3116 } 3117 } 3118 return true; 3119 } 3120 3121 3122 bool 3123 gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr, 3124 gfc_actual_arglist **arglist, 3125 bool parent) 3126 { 3127 gfc_actual_arglist *actual; 3128 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter; 3129 gfc_constructor_base ctor_head = NULL; 3130 gfc_component *comp; /* Is set NULL when named component is first seen */ 3131 const char* last_name = NULL; 3132 locus old_locus; 3133 gfc_expr *expr; 3134 3135 expr = parent ? *cexpr : e; 3136 old_locus = gfc_current_locus; 3137 if (parent) 3138 ; /* gfc_current_locus = *arglist->expr ? ->where;*/ 3139 else 3140 gfc_current_locus = expr->where; 3141 3142 comp_tail = comp_head = NULL; 3143 3144 if (!parent && sym->attr.abstract) 3145 { 3146 gfc_error ("Cannot construct ABSTRACT type %qs at %L", 3147 sym->name, &expr->where); 3148 goto cleanup; 3149 } 3150 3151 comp = sym->components; 3152 actual = parent ? *arglist : expr->value.function.actual; 3153 for ( ; actual; ) 3154 { 3155 gfc_component *this_comp = NULL; 3156 3157 if (!comp_head) 3158 comp_tail = comp_head = gfc_get_structure_ctor_component (); 3159 else 3160 { 3161 comp_tail->next = gfc_get_structure_ctor_component (); 3162 comp_tail = comp_tail->next; 3163 } 3164 if (actual->name) 3165 { 3166 if (!gfc_notify_std (GFC_STD_F2003, "Structure" 3167 " constructor with named arguments at %C")) 3168 goto cleanup; 3169 3170 comp_tail->name = xstrdup (actual->name); 3171 last_name = comp_tail->name; 3172 comp = NULL; 3173 } 3174 else 3175 { 3176 /* Components without name are not allowed after the first named 3177 component initializer! */ 3178 if (!comp || comp->attr.artificial) 3179 { 3180 if (last_name) 3181 gfc_error ("Component initializer without name after component" 3182 " named %s at %L", last_name, 3183 actual->expr ? &actual->expr->where 3184 : &gfc_current_locus); 3185 else 3186 gfc_error ("Too many components in structure constructor at " 3187 "%L", actual->expr ? &actual->expr->where 3188 : &gfc_current_locus); 3189 goto cleanup; 3190 } 3191 3192 comp_tail->name = xstrdup (comp->name); 3193 } 3194 3195 /* Find the current component in the structure definition and check 3196 its access is not private. */ 3197 if (comp) 3198 this_comp = gfc_find_component (sym, comp->name, false, false, NULL); 3199 else 3200 { 3201 this_comp = gfc_find_component (sym, (const char *)comp_tail->name, 3202 false, false, NULL); 3203 comp = NULL; /* Reset needed! */ 3204 } 3205 3206 /* Here we can check if a component name is given which does not 3207 correspond to any component of the defined structure. */ 3208 if (!this_comp) 3209 goto cleanup; 3210 3211 /* For a constant string constructor, make sure the length is 3212 correct; truncate of fill with blanks if needed. */ 3213 if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable 3214 && this_comp->ts.u.cl && this_comp->ts.u.cl->length 3215 && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT 3216 && actual->expr->ts.type == BT_CHARACTER 3217 && actual->expr->expr_type == EXPR_CONSTANT) 3218 { 3219 ptrdiff_t c, e1; 3220 c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer); 3221 e1 = actual->expr->value.character.length; 3222 3223 if (c != e1) 3224 { 3225 ptrdiff_t i, to; 3226 gfc_char_t *dest; 3227 dest = gfc_get_wide_string (c + 1); 3228 3229 to = e1 < c ? e1 : c; 3230 for (i = 0; i < to; i++) 3231 dest[i] = actual->expr->value.character.string[i]; 3232 3233 for (i = e1; i < c; i++) 3234 dest[i] = ' '; 3235 3236 dest[c] = '\0'; 3237 free (actual->expr->value.character.string); 3238 3239 actual->expr->value.character.length = c; 3240 actual->expr->value.character.string = dest; 3241 3242 if (warn_line_truncation && c < e1) 3243 gfc_warning_now (OPT_Wcharacter_truncation, 3244 "CHARACTER expression will be truncated " 3245 "in constructor (%ld/%ld) at %L", (long int) c, 3246 (long int) e1, &actual->expr->where); 3247 } 3248 } 3249 3250 comp_tail->val = actual->expr; 3251 if (actual->expr != NULL) 3252 comp_tail->where = actual->expr->where; 3253 actual->expr = NULL; 3254 3255 /* Check if this component is already given a value. */ 3256 for (comp_iter = comp_head; comp_iter != comp_tail; 3257 comp_iter = comp_iter->next) 3258 { 3259 gcc_assert (comp_iter); 3260 if (!strcmp (comp_iter->name, comp_tail->name)) 3261 { 3262 gfc_error ("Component %qs is initialized twice in the structure" 3263 " constructor at %L", comp_tail->name, 3264 comp_tail->val ? &comp_tail->where 3265 : &gfc_current_locus); 3266 goto cleanup; 3267 } 3268 } 3269 3270 /* F2008, R457/C725, for PURE C1283. */ 3271 if (this_comp->attr.pointer && comp_tail->val 3272 && gfc_is_coindexed (comp_tail->val)) 3273 { 3274 gfc_error ("Coindexed expression to pointer component %qs in " 3275 "structure constructor at %L", comp_tail->name, 3276 &comp_tail->where); 3277 goto cleanup; 3278 } 3279 3280 /* If not explicitly a parent constructor, gather up the components 3281 and build one. */ 3282 if (comp && comp == sym->components 3283 && sym->attr.extension 3284 && comp_tail->val 3285 && (!gfc_bt_struct (comp_tail->val->ts.type) 3286 || 3287 comp_tail->val->ts.u.derived != this_comp->ts.u.derived)) 3288 { 3289 bool m; 3290 gfc_actual_arglist *arg_null = NULL; 3291 3292 actual->expr = comp_tail->val; 3293 comp_tail->val = NULL; 3294 3295 m = gfc_convert_to_structure_constructor (NULL, 3296 comp->ts.u.derived, &comp_tail->val, 3297 comp->ts.u.derived->attr.zero_comp 3298 ? &arg_null : &actual, true); 3299 if (!m) 3300 goto cleanup; 3301 3302 if (comp->ts.u.derived->attr.zero_comp) 3303 { 3304 comp = comp->next; 3305 continue; 3306 } 3307 } 3308 3309 if (comp) 3310 comp = comp->next; 3311 if (parent && !comp) 3312 break; 3313 3314 if (actual) 3315 actual = actual->next; 3316 } 3317 3318 if (!build_actual_constructor (&comp_head, &ctor_head, sym)) 3319 goto cleanup; 3320 3321 /* No component should be left, as this should have caused an error in the 3322 loop constructing the component-list (name that does not correspond to any 3323 component in the structure definition). */ 3324 if (comp_head && sym->attr.extension) 3325 { 3326 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next) 3327 { 3328 gfc_error ("component %qs at %L has already been set by a " 3329 "parent derived type constructor", comp_iter->name, 3330 &comp_iter->where); 3331 } 3332 goto cleanup; 3333 } 3334 else 3335 gcc_assert (!comp_head); 3336 3337 if (parent) 3338 { 3339 expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus); 3340 expr->ts.u.derived = sym; 3341 expr->value.constructor = ctor_head; 3342 *cexpr = expr; 3343 } 3344 else 3345 { 3346 expr->ts.u.derived = sym; 3347 expr->ts.kind = 0; 3348 expr->ts.type = BT_DERIVED; 3349 expr->value.constructor = ctor_head; 3350 expr->expr_type = EXPR_STRUCTURE; 3351 } 3352 3353 gfc_current_locus = old_locus; 3354 if (parent) 3355 *arglist = actual; 3356 return true; 3357 3358 cleanup: 3359 gfc_current_locus = old_locus; 3360 3361 for (comp_iter = comp_head; comp_iter; ) 3362 { 3363 gfc_structure_ctor_component *next = comp_iter->next; 3364 gfc_free_structure_ctor_component (comp_iter); 3365 comp_iter = next; 3366 } 3367 gfc_constructor_free (ctor_head); 3368 3369 return false; 3370 } 3371 3372 3373 match 3374 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) 3375 { 3376 match m; 3377 gfc_expr *e; 3378 gfc_symtree *symtree; 3379 bool t = true; 3380 3381 gfc_get_ha_sym_tree (sym->name, &symtree); 3382 3383 e = gfc_get_expr (); 3384 e->symtree = symtree; 3385 e->expr_type = EXPR_FUNCTION; 3386 e->where = gfc_current_locus; 3387 3388 gcc_assert (gfc_fl_struct (sym->attr.flavor) 3389 && symtree->n.sym->attr.flavor == FL_PROCEDURE); 3390 e->value.function.esym = sym; 3391 e->symtree->n.sym->attr.generic = 1; 3392 3393 m = gfc_match_actual_arglist (0, &e->value.function.actual); 3394 if (m != MATCH_YES) 3395 { 3396 gfc_free_expr (e); 3397 return m; 3398 } 3399 3400 if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false)) 3401 { 3402 gfc_free_expr (e); 3403 return MATCH_ERROR; 3404 } 3405 3406 /* If a structure constructor is in a DATA statement, then each entity 3407 in the structure constructor must be a constant. Try to reduce the 3408 expression here. */ 3409 if (gfc_in_match_data ()) 3410 t = gfc_reduce_init_expr (e); 3411 3412 if (t) 3413 { 3414 *result = e; 3415 return MATCH_YES; 3416 } 3417 else 3418 { 3419 gfc_free_expr (e); 3420 return MATCH_ERROR; 3421 } 3422 } 3423 3424 3425 /* If the symbol is an implicit do loop index and implicitly typed, 3426 it should not be host associated. Provide a symtree from the 3427 current namespace. */ 3428 static match 3429 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym) 3430 { 3431 if ((*sym)->attr.flavor == FL_VARIABLE 3432 && (*sym)->ns != gfc_current_ns 3433 && (*sym)->attr.implied_index 3434 && (*sym)->attr.implicit_type 3435 && !(*sym)->attr.use_assoc) 3436 { 3437 int i; 3438 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false); 3439 if (i) 3440 return MATCH_ERROR; 3441 *sym = (*st)->n.sym; 3442 } 3443 return MATCH_YES; 3444 } 3445 3446 3447 /* Procedure pointer as function result: Replace the function symbol by the 3448 auto-generated hidden result variable named "ppr@". */ 3449 3450 static bool 3451 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st) 3452 { 3453 /* Check for procedure pointer result variable. */ 3454 if ((*sym)->attr.function && !(*sym)->attr.external 3455 && (*sym)->result && (*sym)->result != *sym 3456 && (*sym)->result->attr.proc_pointer 3457 && (*sym) == gfc_current_ns->proc_name 3458 && (*sym) == (*sym)->result->ns->proc_name 3459 && strcmp ("ppr@", (*sym)->result->name) == 0) 3460 { 3461 /* Automatic replacement with "hidden" result variable. */ 3462 (*sym)->result->attr.referenced = (*sym)->attr.referenced; 3463 *sym = (*sym)->result; 3464 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name); 3465 return true; 3466 } 3467 return false; 3468 } 3469 3470 3471 /* Matches a variable name followed by anything that might follow it-- 3472 array reference, argument list of a function, etc. */ 3473 3474 match 3475 gfc_match_rvalue (gfc_expr **result) 3476 { 3477 gfc_actual_arglist *actual_arglist; 3478 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1]; 3479 gfc_state_data *st; 3480 gfc_symbol *sym; 3481 gfc_symtree *symtree; 3482 locus where, old_loc; 3483 gfc_expr *e; 3484 match m, m2; 3485 int i; 3486 gfc_typespec *ts; 3487 bool implicit_char; 3488 gfc_ref *ref; 3489 3490 m = gfc_match ("%%loc"); 3491 if (m == MATCH_YES) 3492 { 3493 if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C")) 3494 return MATCH_ERROR; 3495 strncpy (name, "loc", 4); 3496 } 3497 3498 else 3499 { 3500 m = gfc_match_name (name); 3501 if (m != MATCH_YES) 3502 return m; 3503 } 3504 3505 /* Check if the symbol exists. */ 3506 if (gfc_find_sym_tree (name, NULL, 1, &symtree)) 3507 return MATCH_ERROR; 3508 3509 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT 3510 type. For derived types we create a generic symbol which links to the 3511 derived type symbol; STRUCTUREs are simpler and must not conflict with 3512 variables. */ 3513 if (!symtree) 3514 if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree)) 3515 return MATCH_ERROR; 3516 if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT) 3517 { 3518 if (gfc_find_state (COMP_INTERFACE) 3519 && !gfc_current_ns->has_import_set) 3520 i = gfc_get_sym_tree (name, NULL, &symtree, false); 3521 else 3522 i = gfc_get_ha_sym_tree (name, &symtree); 3523 if (i) 3524 return MATCH_ERROR; 3525 } 3526 3527 3528 sym = symtree->n.sym; 3529 e = NULL; 3530 where = gfc_current_locus; 3531 3532 replace_hidden_procptr_result (&sym, &symtree); 3533 3534 /* If this is an implicit do loop index and implicitly typed, 3535 it should not be host associated. */ 3536 m = check_for_implicit_index (&symtree, &sym); 3537 if (m != MATCH_YES) 3538 return m; 3539 3540 gfc_set_sym_referenced (sym); 3541 sym->attr.implied_index = 0; 3542 3543 if (sym->attr.function && sym->result == sym) 3544 { 3545 /* See if this is a directly recursive function call. */ 3546 gfc_gobble_whitespace (); 3547 if (sym->attr.recursive 3548 && gfc_peek_ascii_char () == '(' 3549 && gfc_current_ns->proc_name == sym 3550 && !sym->attr.dimension) 3551 { 3552 gfc_error ("%qs at %C is the name of a recursive function " 3553 "and so refers to the result variable. Use an " 3554 "explicit RESULT variable for direct recursion " 3555 "(12.5.2.1)", sym->name); 3556 return MATCH_ERROR; 3557 } 3558 3559 if (gfc_is_function_return_value (sym, gfc_current_ns)) 3560 goto variable; 3561 3562 if (sym->attr.entry 3563 && (sym->ns == gfc_current_ns 3564 || sym->ns == gfc_current_ns->parent)) 3565 { 3566 gfc_entry_list *el = NULL; 3567 3568 for (el = sym->ns->entries; el; el = el->next) 3569 if (sym == el->sym) 3570 goto variable; 3571 } 3572 } 3573 3574 if (gfc_matching_procptr_assignment) 3575 { 3576 /* It can be a procedure or a derived-type procedure or a not-yet-known 3577 type. */ 3578 if (sym->attr.flavor != FL_UNKNOWN 3579 && sym->attr.flavor != FL_PROCEDURE 3580 && sym->attr.flavor != FL_PARAMETER 3581 && sym->attr.flavor != FL_VARIABLE) 3582 { 3583 gfc_error ("Symbol at %C is not appropriate for an expression"); 3584 return MATCH_ERROR; 3585 } 3586 goto procptr0; 3587 } 3588 3589 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic) 3590 goto function0; 3591 3592 if (sym->attr.generic) 3593 goto generic_function; 3594 3595 switch (sym->attr.flavor) 3596 { 3597 case FL_VARIABLE: 3598 variable: 3599 e = gfc_get_expr (); 3600 3601 e->expr_type = EXPR_VARIABLE; 3602 e->symtree = symtree; 3603 3604 m = gfc_match_varspec (e, 0, false, true); 3605 break; 3606 3607 case FL_PARAMETER: 3608 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will 3609 end up here. Unfortunately, sym->value->expr_type is set to 3610 EXPR_CONSTANT, and so the if () branch would be followed without 3611 the !sym->as check. */ 3612 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as) 3613 e = gfc_copy_expr (sym->value); 3614 else 3615 { 3616 e = gfc_get_expr (); 3617 e->expr_type = EXPR_VARIABLE; 3618 } 3619 3620 e->symtree = symtree; 3621 m = gfc_match_varspec (e, 0, false, true); 3622 3623 if (sym->ts.is_c_interop || sym->ts.is_iso_c) 3624 break; 3625 3626 /* Variable array references to derived type parameters cause 3627 all sorts of headaches in simplification. Treating such 3628 expressions as variable works just fine for all array 3629 references. */ 3630 if (sym->value && sym->ts.type == BT_DERIVED && e->ref) 3631 { 3632 for (ref = e->ref; ref; ref = ref->next) 3633 if (ref->type == REF_ARRAY) 3634 break; 3635 3636 if (ref == NULL || ref->u.ar.type == AR_FULL) 3637 break; 3638 3639 ref = e->ref; 3640 e->ref = NULL; 3641 gfc_free_expr (e); 3642 e = gfc_get_expr (); 3643 e->expr_type = EXPR_VARIABLE; 3644 e->symtree = symtree; 3645 e->ref = ref; 3646 } 3647 3648 break; 3649 3650 case FL_STRUCT: 3651 case FL_DERIVED: 3652 sym = gfc_use_derived (sym); 3653 if (sym == NULL) 3654 m = MATCH_ERROR; 3655 else 3656 goto generic_function; 3657 break; 3658 3659 /* If we're here, then the name is known to be the name of a 3660 procedure, yet it is not sure to be the name of a function. */ 3661 case FL_PROCEDURE: 3662 3663 /* Procedure Pointer Assignments. */ 3664 procptr0: 3665 if (gfc_matching_procptr_assignment) 3666 { 3667 gfc_gobble_whitespace (); 3668 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(') 3669 /* Parse functions returning a procptr. */ 3670 goto function0; 3671 3672 e = gfc_get_expr (); 3673 e->expr_type = EXPR_VARIABLE; 3674 e->symtree = symtree; 3675 m = gfc_match_varspec (e, 0, false, true); 3676 if (!e->ref && sym->attr.flavor == FL_UNKNOWN 3677 && sym->ts.type == BT_UNKNOWN 3678 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL)) 3679 { 3680 m = MATCH_ERROR; 3681 break; 3682 } 3683 break; 3684 } 3685 3686 if (sym->attr.subroutine) 3687 { 3688 gfc_error ("Unexpected use of subroutine name %qs at %C", 3689 sym->name); 3690 m = MATCH_ERROR; 3691 break; 3692 } 3693 3694 /* At this point, the name has to be a non-statement function. 3695 If the name is the same as the current function being 3696 compiled, then we have a variable reference (to the function 3697 result) if the name is non-recursive. */ 3698 3699 st = gfc_enclosing_unit (NULL); 3700 3701 if (st != NULL 3702 && st->state == COMP_FUNCTION 3703 && st->sym == sym 3704 && !sym->attr.recursive) 3705 { 3706 e = gfc_get_expr (); 3707 e->symtree = symtree; 3708 e->expr_type = EXPR_VARIABLE; 3709 3710 m = gfc_match_varspec (e, 0, false, true); 3711 break; 3712 } 3713 3714 /* Match a function reference. */ 3715 function0: 3716 m = gfc_match_actual_arglist (0, &actual_arglist); 3717 if (m == MATCH_NO) 3718 { 3719 if (sym->attr.proc == PROC_ST_FUNCTION) 3720 gfc_error ("Statement function %qs requires argument list at %C", 3721 sym->name); 3722 else 3723 gfc_error ("Function %qs requires an argument list at %C", 3724 sym->name); 3725 3726 m = MATCH_ERROR; 3727 break; 3728 } 3729 3730 if (m != MATCH_YES) 3731 { 3732 m = MATCH_ERROR; 3733 break; 3734 } 3735 3736 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */ 3737 sym = symtree->n.sym; 3738 3739 replace_hidden_procptr_result (&sym, &symtree); 3740 3741 e = gfc_get_expr (); 3742 e->symtree = symtree; 3743 e->expr_type = EXPR_FUNCTION; 3744 e->value.function.actual = actual_arglist; 3745 e->where = gfc_current_locus; 3746 3747 if (sym->ts.type == BT_CLASS && sym->attr.class_ok 3748 && CLASS_DATA (sym)->as) 3749 e->rank = CLASS_DATA (sym)->as->rank; 3750 else if (sym->as != NULL) 3751 e->rank = sym->as->rank; 3752 3753 if (!sym->attr.function 3754 && !gfc_add_function (&sym->attr, sym->name, NULL)) 3755 { 3756 m = MATCH_ERROR; 3757 break; 3758 } 3759 3760 /* Check here for the existence of at least one argument for the 3761 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The 3762 argument(s) given will be checked in gfc_iso_c_func_interface, 3763 during resolution of the function call. */ 3764 if (sym->attr.is_iso_c == 1 3765 && (sym->from_intmod == INTMOD_ISO_C_BINDING 3766 && (sym->intmod_sym_id == ISOCBINDING_LOC 3767 || sym->intmod_sym_id == ISOCBINDING_FUNLOC 3768 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED))) 3769 { 3770 /* make sure we were given a param */ 3771 if (actual_arglist == NULL) 3772 { 3773 gfc_error ("Missing argument to %qs at %C", sym->name); 3774 m = MATCH_ERROR; 3775 break; 3776 } 3777 } 3778 3779 if (sym->result == NULL) 3780 sym->result = sym; 3781 3782 gfc_gobble_whitespace (); 3783 /* F08:C612. */ 3784 if (gfc_peek_ascii_char() == '%') 3785 { 3786 gfc_error ("The leftmost part-ref in a data-ref cannot be a " 3787 "function reference at %C"); 3788 m = MATCH_ERROR; 3789 break; 3790 } 3791 3792 m = MATCH_YES; 3793 break; 3794 3795 case FL_UNKNOWN: 3796 3797 /* Special case for derived type variables that get their types 3798 via an IMPLICIT statement. This can't wait for the 3799 resolution phase. */ 3800 3801 old_loc = gfc_current_locus; 3802 if (gfc_match_member_sep (sym) == MATCH_YES 3803 && sym->ts.type == BT_UNKNOWN 3804 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) 3805 gfc_set_default_type (sym, 0, sym->ns); 3806 gfc_current_locus = old_loc; 3807 3808 /* If the symbol has a (co)dimension attribute, the expression is a 3809 variable. */ 3810 3811 if (sym->attr.dimension || sym->attr.codimension) 3812 { 3813 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) 3814 { 3815 m = MATCH_ERROR; 3816 break; 3817 } 3818 3819 e = gfc_get_expr (); 3820 e->symtree = symtree; 3821 e->expr_type = EXPR_VARIABLE; 3822 m = gfc_match_varspec (e, 0, false, true); 3823 break; 3824 } 3825 3826 if (sym->ts.type == BT_CLASS && sym->attr.class_ok 3827 && (CLASS_DATA (sym)->attr.dimension 3828 || CLASS_DATA (sym)->attr.codimension)) 3829 { 3830 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) 3831 { 3832 m = MATCH_ERROR; 3833 break; 3834 } 3835 3836 e = gfc_get_expr (); 3837 e->symtree = symtree; 3838 e->expr_type = EXPR_VARIABLE; 3839 m = gfc_match_varspec (e, 0, false, true); 3840 break; 3841 } 3842 3843 /* Name is not an array, so we peek to see if a '(' implies a 3844 function call or a substring reference. Otherwise the 3845 variable is just a scalar. */ 3846 3847 gfc_gobble_whitespace (); 3848 if (gfc_peek_ascii_char () != '(') 3849 { 3850 /* Assume a scalar variable */ 3851 e = gfc_get_expr (); 3852 e->symtree = symtree; 3853 e->expr_type = EXPR_VARIABLE; 3854 3855 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) 3856 { 3857 m = MATCH_ERROR; 3858 break; 3859 } 3860 3861 /*FIXME:??? gfc_match_varspec does set this for us: */ 3862 e->ts = sym->ts; 3863 m = gfc_match_varspec (e, 0, false, true); 3864 break; 3865 } 3866 3867 /* See if this is a function reference with a keyword argument 3868 as first argument. We do this because otherwise a spurious 3869 symbol would end up in the symbol table. */ 3870 3871 old_loc = gfc_current_locus; 3872 m2 = gfc_match (" ( %n =", argname); 3873 gfc_current_locus = old_loc; 3874 3875 e = gfc_get_expr (); 3876 e->symtree = symtree; 3877 3878 if (m2 != MATCH_YES) 3879 { 3880 /* Try to figure out whether we're dealing with a character type. 3881 We're peeking ahead here, because we don't want to call 3882 match_substring if we're dealing with an implicitly typed 3883 non-character variable. */ 3884 implicit_char = false; 3885 if (sym->ts.type == BT_UNKNOWN) 3886 { 3887 ts = gfc_get_default_type (sym->name, NULL); 3888 if (ts->type == BT_CHARACTER) 3889 implicit_char = true; 3890 } 3891 3892 /* See if this could possibly be a substring reference of a name 3893 that we're not sure is a variable yet. */ 3894 3895 if ((implicit_char || sym->ts.type == BT_CHARACTER) 3896 && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES) 3897 { 3898 3899 e->expr_type = EXPR_VARIABLE; 3900 3901 if (sym->attr.flavor != FL_VARIABLE 3902 && !gfc_add_flavor (&sym->attr, FL_VARIABLE, 3903 sym->name, NULL)) 3904 { 3905 m = MATCH_ERROR; 3906 break; 3907 } 3908 3909 if (sym->ts.type == BT_UNKNOWN 3910 && !gfc_set_default_type (sym, 1, NULL)) 3911 { 3912 m = MATCH_ERROR; 3913 break; 3914 } 3915 3916 e->ts = sym->ts; 3917 if (e->ref) 3918 e->ts.u.cl = NULL; 3919 m = MATCH_YES; 3920 break; 3921 } 3922 } 3923 3924 /* Give up, assume we have a function. */ 3925 3926 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */ 3927 sym = symtree->n.sym; 3928 e->expr_type = EXPR_FUNCTION; 3929 3930 if (!sym->attr.function 3931 && !gfc_add_function (&sym->attr, sym->name, NULL)) 3932 { 3933 m = MATCH_ERROR; 3934 break; 3935 } 3936 3937 sym->result = sym; 3938 3939 m = gfc_match_actual_arglist (0, &e->value.function.actual); 3940 if (m == MATCH_NO) 3941 gfc_error ("Missing argument list in function %qs at %C", sym->name); 3942 3943 if (m != MATCH_YES) 3944 { 3945 m = MATCH_ERROR; 3946 break; 3947 } 3948 3949 /* If our new function returns a character, array or structure 3950 type, it might have subsequent references. */ 3951 3952 m = gfc_match_varspec (e, 0, false, true); 3953 if (m == MATCH_NO) 3954 m = MATCH_YES; 3955 3956 break; 3957 3958 generic_function: 3959 /* Look for symbol first; if not found, look for STRUCTURE type symbol 3960 specially. Creates a generic symbol for derived types. */ 3961 gfc_find_sym_tree (name, NULL, 1, &symtree); 3962 if (!symtree) 3963 gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree); 3964 if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT) 3965 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */ 3966 3967 e = gfc_get_expr (); 3968 e->symtree = symtree; 3969 e->expr_type = EXPR_FUNCTION; 3970 3971 if (gfc_fl_struct (sym->attr.flavor)) 3972 { 3973 e->value.function.esym = sym; 3974 e->symtree->n.sym->attr.generic = 1; 3975 } 3976 3977 m = gfc_match_actual_arglist (0, &e->value.function.actual); 3978 break; 3979 3980 case FL_NAMELIST: 3981 m = MATCH_ERROR; 3982 break; 3983 3984 default: 3985 gfc_error ("Symbol at %C is not appropriate for an expression"); 3986 return MATCH_ERROR; 3987 } 3988 3989 if (m == MATCH_YES) 3990 { 3991 e->where = where; 3992 *result = e; 3993 } 3994 else 3995 gfc_free_expr (e); 3996 3997 return m; 3998 } 3999 4000 4001 /* Match a variable, i.e. something that can be assigned to. This 4002 starts as a symbol, can be a structure component or an array 4003 reference. It can be a function if the function doesn't have a 4004 separate RESULT variable. If the symbol has not been previously 4005 seen, we assume it is a variable. 4006 4007 This function is called by two interface functions: 4008 gfc_match_variable, which has host_flag = 1, and 4009 gfc_match_equiv_variable, with host_flag = 0, to restrict the 4010 match of the symbol to the local scope. */ 4011 4012 static match 4013 match_variable (gfc_expr **result, int equiv_flag, int host_flag) 4014 { 4015 gfc_symbol *sym, *dt_sym; 4016 gfc_symtree *st; 4017 gfc_expr *expr; 4018 locus where, old_loc; 4019 match m; 4020 4021 /* Since nothing has any business being an lvalue in a module 4022 specification block, an interface block or a contains section, 4023 we force the changed_symbols mechanism to work by setting 4024 host_flag to 0. This prevents valid symbols that have the name 4025 of keywords, such as 'end', being turned into variables by 4026 failed matching to assignments for, e.g., END INTERFACE. */ 4027 if (gfc_current_state () == COMP_MODULE 4028 || gfc_current_state () == COMP_SUBMODULE 4029 || gfc_current_state () == COMP_INTERFACE 4030 || gfc_current_state () == COMP_CONTAINS) 4031 host_flag = 0; 4032 4033 where = gfc_current_locus; 4034 m = gfc_match_sym_tree (&st, host_flag); 4035 if (m != MATCH_YES) 4036 return m; 4037 4038 sym = st->n.sym; 4039 4040 /* If this is an implicit do loop index and implicitly typed, 4041 it should not be host associated. */ 4042 m = check_for_implicit_index (&st, &sym); 4043 if (m != MATCH_YES) 4044 return m; 4045 4046 sym->attr.implied_index = 0; 4047 4048 gfc_set_sym_referenced (sym); 4049 4050 /* STRUCTUREs may share names with variables, but derived types may not. */ 4051 if (sym->attr.flavor == FL_PROCEDURE && sym->generic 4052 && (dt_sym = gfc_find_dt_in_generic (sym))) 4053 { 4054 if (dt_sym->attr.flavor == FL_DERIVED) 4055 gfc_error ("Derived type %qs cannot be used as a variable at %C", 4056 sym->name); 4057 return MATCH_ERROR; 4058 } 4059 4060 switch (sym->attr.flavor) 4061 { 4062 case FL_VARIABLE: 4063 /* Everything is alright. */ 4064 break; 4065 4066 case FL_UNKNOWN: 4067 { 4068 sym_flavor flavor = FL_UNKNOWN; 4069 4070 gfc_gobble_whitespace (); 4071 4072 if (sym->attr.external || sym->attr.procedure 4073 || sym->attr.function || sym->attr.subroutine) 4074 flavor = FL_PROCEDURE; 4075 4076 /* If it is not a procedure, is not typed and is host associated, 4077 we cannot give it a flavor yet. */ 4078 else if (sym->ns == gfc_current_ns->parent 4079 && sym->ts.type == BT_UNKNOWN) 4080 break; 4081 4082 /* These are definitive indicators that this is a variable. */ 4083 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN 4084 || sym->attr.pointer || sym->as != NULL) 4085 flavor = FL_VARIABLE; 4086 4087 if (flavor != FL_UNKNOWN 4088 && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL)) 4089 return MATCH_ERROR; 4090 } 4091 break; 4092 4093 case FL_PARAMETER: 4094 if (equiv_flag) 4095 { 4096 gfc_error ("Named constant at %C in an EQUIVALENCE"); 4097 return MATCH_ERROR; 4098 } 4099 /* Otherwise this is checked for and an error given in the 4100 variable definition context checks. */ 4101 break; 4102 4103 case FL_PROCEDURE: 4104 /* Check for a nonrecursive function result variable. */ 4105 if (sym->attr.function 4106 && !sym->attr.external 4107 && sym->result == sym 4108 && (gfc_is_function_return_value (sym, gfc_current_ns) 4109 || (sym->attr.entry 4110 && sym->ns == gfc_current_ns) 4111 || (sym->attr.entry 4112 && sym->ns == gfc_current_ns->parent))) 4113 { 4114 /* If a function result is a derived type, then the derived 4115 type may still have to be resolved. */ 4116 4117 if (sym->ts.type == BT_DERIVED 4118 && gfc_use_derived (sym->ts.u.derived) == NULL) 4119 return MATCH_ERROR; 4120 break; 4121 } 4122 4123 if (sym->attr.proc_pointer 4124 || replace_hidden_procptr_result (&sym, &st)) 4125 break; 4126 4127 /* Fall through to error */ 4128 gcc_fallthrough (); 4129 4130 default: 4131 gfc_error ("%qs at %C is not a variable", sym->name); 4132 return MATCH_ERROR; 4133 } 4134 4135 /* Special case for derived type variables that get their types 4136 via an IMPLICIT statement. This can't wait for the 4137 resolution phase. */ 4138 4139 { 4140 gfc_namespace * implicit_ns; 4141 4142 if (gfc_current_ns->proc_name == sym) 4143 implicit_ns = gfc_current_ns; 4144 else 4145 implicit_ns = sym->ns; 4146 4147 old_loc = gfc_current_locus; 4148 if (gfc_match_member_sep (sym) == MATCH_YES 4149 && sym->ts.type == BT_UNKNOWN 4150 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED) 4151 gfc_set_default_type (sym, 0, implicit_ns); 4152 gfc_current_locus = old_loc; 4153 } 4154 4155 expr = gfc_get_expr (); 4156 4157 expr->expr_type = EXPR_VARIABLE; 4158 expr->symtree = st; 4159 expr->ts = sym->ts; 4160 expr->where = where; 4161 4162 /* Now see if we have to do more. */ 4163 m = gfc_match_varspec (expr, equiv_flag, false, false); 4164 if (m != MATCH_YES) 4165 { 4166 gfc_free_expr (expr); 4167 return m; 4168 } 4169 4170 *result = expr; 4171 return MATCH_YES; 4172 } 4173 4174 4175 match 4176 gfc_match_variable (gfc_expr **result, int equiv_flag) 4177 { 4178 return match_variable (result, equiv_flag, 1); 4179 } 4180 4181 4182 match 4183 gfc_match_equiv_variable (gfc_expr **result) 4184 { 4185 return match_variable (result, 1, 0); 4186 } 4187 4188