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