1 /* Matching subroutines in all sizes, shapes and colors. 2 Copyright (C) 2000-2019 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5 This file is part of GCC. 6 7 GCC is free software; you can redistribute it and/or modify it under 8 the terms of the GNU General Public License as published by the Free 9 Software Foundation; either version 3, or (at your option) any later 10 version. 11 12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13 WARRANTY; without even the implied warranty of MERCHANTABILITY or 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15 for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with GCC; see the file COPYING3. If not see 19 <http://www.gnu.org/licenses/>. */ 20 21 #include "config.h" 22 #include "system.h" 23 #include "coretypes.h" 24 #include "options.h" 25 #include "gfortran.h" 26 #include "match.h" 27 #include "parse.h" 28 29 int gfc_matching_ptr_assignment = 0; 30 int gfc_matching_procptr_assignment = 0; 31 bool gfc_matching_prefix = false; 32 33 /* Stack of SELECT TYPE statements. */ 34 gfc_select_type_stack *select_type_stack = NULL; 35 36 /* List of type parameter expressions. */ 37 gfc_actual_arglist *type_param_spec_list; 38 39 /* For debugging and diagnostic purposes. Return the textual representation 40 of the intrinsic operator OP. */ 41 const char * 42 gfc_op2string (gfc_intrinsic_op op) 43 { 44 switch (op) 45 { 46 case INTRINSIC_UPLUS: 47 case INTRINSIC_PLUS: 48 return "+"; 49 50 case INTRINSIC_UMINUS: 51 case INTRINSIC_MINUS: 52 return "-"; 53 54 case INTRINSIC_POWER: 55 return "**"; 56 case INTRINSIC_CONCAT: 57 return "//"; 58 case INTRINSIC_TIMES: 59 return "*"; 60 case INTRINSIC_DIVIDE: 61 return "/"; 62 63 case INTRINSIC_AND: 64 return ".and."; 65 case INTRINSIC_OR: 66 return ".or."; 67 case INTRINSIC_EQV: 68 return ".eqv."; 69 case INTRINSIC_NEQV: 70 return ".neqv."; 71 72 case INTRINSIC_EQ_OS: 73 return ".eq."; 74 case INTRINSIC_EQ: 75 return "=="; 76 case INTRINSIC_NE_OS: 77 return ".ne."; 78 case INTRINSIC_NE: 79 return "/="; 80 case INTRINSIC_GE_OS: 81 return ".ge."; 82 case INTRINSIC_GE: 83 return ">="; 84 case INTRINSIC_LE_OS: 85 return ".le."; 86 case INTRINSIC_LE: 87 return "<="; 88 case INTRINSIC_LT_OS: 89 return ".lt."; 90 case INTRINSIC_LT: 91 return "<"; 92 case INTRINSIC_GT_OS: 93 return ".gt."; 94 case INTRINSIC_GT: 95 return ">"; 96 case INTRINSIC_NOT: 97 return ".not."; 98 99 case INTRINSIC_ASSIGN: 100 return "="; 101 102 case INTRINSIC_PARENTHESES: 103 return "parens"; 104 105 case INTRINSIC_NONE: 106 return "none"; 107 108 /* DTIO */ 109 case INTRINSIC_FORMATTED: 110 return "formatted"; 111 case INTRINSIC_UNFORMATTED: 112 return "unformatted"; 113 114 default: 115 break; 116 } 117 118 gfc_internal_error ("gfc_op2string(): Bad code"); 119 /* Not reached. */ 120 } 121 122 123 /******************** Generic matching subroutines ************************/ 124 125 /* Matches a member separator. With standard FORTRAN this is '%', but with 126 DEC structures we must carefully match dot ('.'). 127 Because operators are spelled ".op.", a dotted string such as "x.y.z..." 128 can be either a component reference chain or a combination of binary 129 operations. 130 There is no real way to win because the string may be grammatically 131 ambiguous. The following rules help avoid ambiguities - they match 132 some behavior of other (older) compilers. If the rules here are changed 133 the test cases should be updated. If the user has problems with these rules 134 they probably deserve the consequences. Consider "x.y.z": 135 (1) If any user defined operator ".y." exists, this is always y(x,z) 136 (even if ".y." is the wrong type and/or x has a member y). 137 (2) Otherwise if x has a member y, and y is itself a derived type, 138 this is (x->y)->z, even if an intrinsic operator exists which 139 can handle (x,z). 140 (3) If x has no member y or (x->y) is not a derived type but ".y." 141 is an intrinsic operator (such as ".eq."), this is y(x,z). 142 (4) Lastly if there is no operator ".y." and x has no member "y", it is an 143 error. 144 It is worth noting that the logic here does not support mixed use of member 145 accessors within a single string. That is, even if x has component y and y 146 has component z, the following are all syntax errors: 147 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z" 148 */ 149 150 match 151 gfc_match_member_sep(gfc_symbol *sym) 152 { 153 char name[GFC_MAX_SYMBOL_LEN + 1]; 154 locus dot_loc, start_loc; 155 gfc_intrinsic_op iop; 156 match m; 157 gfc_symbol *tsym; 158 gfc_component *c = NULL; 159 160 /* What a relief: '%' is an unambiguous member separator. */ 161 if (gfc_match_char ('%') == MATCH_YES) 162 return MATCH_YES; 163 164 /* Beware ye who enter here. */ 165 if (!flag_dec_structure || !sym) 166 return MATCH_NO; 167 168 tsym = NULL; 169 170 /* We may be given either a derived type variable or the derived type 171 declaration itself (which actually contains the components); 172 we need the latter to search for components. */ 173 if (gfc_fl_struct (sym->attr.flavor)) 174 tsym = sym; 175 else if (gfc_bt_struct (sym->ts.type)) 176 tsym = sym->ts.u.derived; 177 178 iop = INTRINSIC_NONE; 179 name[0] = '\0'; 180 m = MATCH_NO; 181 182 /* If we have to reject come back here later. */ 183 start_loc = gfc_current_locus; 184 185 /* Look for a component access next. */ 186 if (gfc_match_char ('.') != MATCH_YES) 187 return MATCH_NO; 188 189 /* If we accept, come back here. */ 190 dot_loc = gfc_current_locus; 191 192 /* Try to match a symbol name following the dot. */ 193 if (gfc_match_name (name) != MATCH_YES) 194 { 195 gfc_error ("Expected structure component or operator name " 196 "after '.' at %C"); 197 goto error; 198 } 199 200 /* If no dot follows we have "x.y" which should be a component access. */ 201 if (gfc_match_char ('.') != MATCH_YES) 202 goto yes; 203 204 /* Now we have a string "x.y.z" which could be a nested member access 205 (x->y)->z or a binary operation y on x and z. */ 206 207 /* First use any user-defined operators ".y." */ 208 if (gfc_find_uop (name, sym->ns) != NULL) 209 goto no; 210 211 /* Match accesses to existing derived-type components for 212 derived-type vars: "x.y.z" = (x->y)->z */ 213 c = gfc_find_component(tsym, name, false, true, NULL); 214 if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS)) 215 goto yes; 216 217 /* If y is not a component or has no members, try intrinsic operators. */ 218 gfc_current_locus = start_loc; 219 if (gfc_match_intrinsic_op (&iop) != MATCH_YES) 220 { 221 /* If ".y." is not an intrinsic operator but y was a valid non- 222 structure component, match and leave the trailing dot to be 223 dealt with later. */ 224 if (c) 225 goto yes; 226 227 gfc_error ("%qs is neither a defined operator nor a " 228 "structure component in dotted string at %C", name); 229 goto error; 230 } 231 232 /* .y. is an intrinsic operator, overriding any possible member access. */ 233 goto no; 234 235 /* Return keeping the current locus consistent with the match result. */ 236 error: 237 m = MATCH_ERROR; 238 no: 239 gfc_current_locus = start_loc; 240 return m; 241 yes: 242 gfc_current_locus = dot_loc; 243 return MATCH_YES; 244 } 245 246 247 /* This function scans the current statement counting the opened and closed 248 parenthesis to make sure they are balanced. */ 249 250 match 251 gfc_match_parens (void) 252 { 253 locus old_loc, where; 254 int count; 255 gfc_instring instring; 256 gfc_char_t c, quote; 257 258 old_loc = gfc_current_locus; 259 count = 0; 260 instring = NONSTRING; 261 quote = ' '; 262 263 for (;;) 264 { 265 c = gfc_next_char_literal (instring); 266 if (c == '\n') 267 break; 268 if (quote == ' ' && ((c == '\'') || (c == '"'))) 269 { 270 quote = c; 271 instring = INSTRING_WARN; 272 continue; 273 } 274 if (quote != ' ' && c == quote) 275 { 276 quote = ' '; 277 instring = NONSTRING; 278 continue; 279 } 280 281 if (c == '(' && quote == ' ') 282 { 283 count++; 284 where = gfc_current_locus; 285 } 286 if (c == ')' && quote == ' ') 287 { 288 count--; 289 where = gfc_current_locus; 290 } 291 } 292 293 gfc_current_locus = old_loc; 294 295 if (count > 0) 296 { 297 gfc_error ("Missing %<)%> in statement at or before %L", &where); 298 return MATCH_ERROR; 299 } 300 if (count < 0) 301 { 302 gfc_error ("Missing %<(%> in statement at or before %L", &where); 303 return MATCH_ERROR; 304 } 305 306 return MATCH_YES; 307 } 308 309 310 /* See if the next character is a special character that has 311 escaped by a \ via the -fbackslash option. */ 312 313 match 314 gfc_match_special_char (gfc_char_t *res) 315 { 316 int len, i; 317 gfc_char_t c, n; 318 match m; 319 320 m = MATCH_YES; 321 322 switch ((c = gfc_next_char_literal (INSTRING_WARN))) 323 { 324 case 'a': 325 *res = '\a'; 326 break; 327 case 'b': 328 *res = '\b'; 329 break; 330 case 't': 331 *res = '\t'; 332 break; 333 case 'f': 334 *res = '\f'; 335 break; 336 case 'n': 337 *res = '\n'; 338 break; 339 case 'r': 340 *res = '\r'; 341 break; 342 case 'v': 343 *res = '\v'; 344 break; 345 case '\\': 346 *res = '\\'; 347 break; 348 case '0': 349 *res = '\0'; 350 break; 351 352 case 'x': 353 case 'u': 354 case 'U': 355 /* Hexadecimal form of wide characters. */ 356 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8)); 357 n = 0; 358 for (i = 0; i < len; i++) 359 { 360 char buf[2] = { '\0', '\0' }; 361 362 c = gfc_next_char_literal (INSTRING_WARN); 363 if (!gfc_wide_fits_in_byte (c) 364 || !gfc_check_digit ((unsigned char) c, 16)) 365 return MATCH_NO; 366 367 buf[0] = (unsigned char) c; 368 n = n << 4; 369 n += strtol (buf, NULL, 16); 370 } 371 *res = n; 372 break; 373 374 default: 375 /* Unknown backslash codes are simply not expanded. */ 376 m = MATCH_NO; 377 break; 378 } 379 380 return m; 381 } 382 383 384 /* In free form, match at least one space. Always matches in fixed 385 form. */ 386 387 match 388 gfc_match_space (void) 389 { 390 locus old_loc; 391 char c; 392 393 if (gfc_current_form == FORM_FIXED) 394 return MATCH_YES; 395 396 old_loc = gfc_current_locus; 397 398 c = gfc_next_ascii_char (); 399 if (!gfc_is_whitespace (c)) 400 { 401 gfc_current_locus = old_loc; 402 return MATCH_NO; 403 } 404 405 gfc_gobble_whitespace (); 406 407 return MATCH_YES; 408 } 409 410 411 /* Match an end of statement. End of statement is optional 412 whitespace, followed by a ';' or '\n' or comment '!'. If a 413 semicolon is found, we continue to eat whitespace and semicolons. */ 414 415 match 416 gfc_match_eos (void) 417 { 418 locus old_loc; 419 int flag; 420 char c; 421 422 flag = 0; 423 424 for (;;) 425 { 426 old_loc = gfc_current_locus; 427 gfc_gobble_whitespace (); 428 429 c = gfc_next_ascii_char (); 430 switch (c) 431 { 432 case '!': 433 do 434 { 435 c = gfc_next_ascii_char (); 436 } 437 while (c != '\n'); 438 439 /* Fall through. */ 440 441 case '\n': 442 return MATCH_YES; 443 444 case ';': 445 flag = 1; 446 continue; 447 } 448 449 break; 450 } 451 452 gfc_current_locus = old_loc; 453 return (flag) ? MATCH_YES : MATCH_NO; 454 } 455 456 457 /* Match a literal integer on the input, setting the value on 458 MATCH_YES. Literal ints occur in kind-parameters as well as 459 old-style character length specifications. If cnt is non-NULL it 460 will be set to the number of digits. */ 461 462 match 463 gfc_match_small_literal_int (int *value, int *cnt) 464 { 465 locus old_loc; 466 char c; 467 int i, j; 468 469 old_loc = gfc_current_locus; 470 471 *value = -1; 472 gfc_gobble_whitespace (); 473 c = gfc_next_ascii_char (); 474 if (cnt) 475 *cnt = 0; 476 477 if (!ISDIGIT (c)) 478 { 479 gfc_current_locus = old_loc; 480 return MATCH_NO; 481 } 482 483 i = c - '0'; 484 j = 1; 485 486 for (;;) 487 { 488 old_loc = gfc_current_locus; 489 c = gfc_next_ascii_char (); 490 491 if (!ISDIGIT (c)) 492 break; 493 494 i = 10 * i + c - '0'; 495 j++; 496 497 if (i > 99999999) 498 { 499 gfc_error ("Integer too large at %C"); 500 return MATCH_ERROR; 501 } 502 } 503 504 gfc_current_locus = old_loc; 505 506 *value = i; 507 if (cnt) 508 *cnt = j; 509 return MATCH_YES; 510 } 511 512 513 /* Match a small, constant integer expression, like in a kind 514 statement. On MATCH_YES, 'value' is set. */ 515 516 match 517 gfc_match_small_int (int *value) 518 { 519 gfc_expr *expr; 520 match m; 521 int i; 522 523 m = gfc_match_expr (&expr); 524 if (m != MATCH_YES) 525 return m; 526 527 if (gfc_extract_int (expr, &i, 1)) 528 m = MATCH_ERROR; 529 gfc_free_expr (expr); 530 531 *value = i; 532 return m; 533 } 534 535 536 /* This function is the same as the gfc_match_small_int, except that 537 we're keeping the pointer to the expr. This function could just be 538 removed and the previously mentioned one modified, though all calls 539 to it would have to be modified then (and there were a number of 540 them). Return MATCH_ERROR if fail to extract the int; otherwise, 541 return the result of gfc_match_expr(). The expr (if any) that was 542 matched is returned in the parameter expr. */ 543 544 match 545 gfc_match_small_int_expr (int *value, gfc_expr **expr) 546 { 547 match m; 548 int i; 549 550 m = gfc_match_expr (expr); 551 if (m != MATCH_YES) 552 return m; 553 554 if (gfc_extract_int (*expr, &i, 1)) 555 m = MATCH_ERROR; 556 557 *value = i; 558 return m; 559 } 560 561 562 /* Matches a statement label. Uses gfc_match_small_literal_int() to 563 do most of the work. */ 564 565 match 566 gfc_match_st_label (gfc_st_label **label) 567 { 568 locus old_loc; 569 match m; 570 int i, cnt; 571 572 old_loc = gfc_current_locus; 573 574 m = gfc_match_small_literal_int (&i, &cnt); 575 if (m != MATCH_YES) 576 return m; 577 578 if (cnt > 5) 579 { 580 gfc_error ("Too many digits in statement label at %C"); 581 goto cleanup; 582 } 583 584 if (i == 0) 585 { 586 gfc_error ("Statement label at %C is zero"); 587 goto cleanup; 588 } 589 590 *label = gfc_get_st_label (i); 591 return MATCH_YES; 592 593 cleanup: 594 595 gfc_current_locus = old_loc; 596 return MATCH_ERROR; 597 } 598 599 600 /* Match and validate a label associated with a named IF, DO or SELECT 601 statement. If the symbol does not have the label attribute, we add 602 it. We also make sure the symbol does not refer to another 603 (active) block. A matched label is pointed to by gfc_new_block. */ 604 605 match 606 gfc_match_label (void) 607 { 608 char name[GFC_MAX_SYMBOL_LEN + 1]; 609 match m; 610 611 gfc_new_block = NULL; 612 613 m = gfc_match (" %n :", name); 614 if (m != MATCH_YES) 615 return m; 616 617 if (gfc_get_symbol (name, NULL, &gfc_new_block)) 618 { 619 gfc_error ("Label name %qs at %C is ambiguous", name); 620 return MATCH_ERROR; 621 } 622 623 if (gfc_new_block->attr.flavor == FL_LABEL) 624 { 625 gfc_error ("Duplicate construct label %qs at %C", name); 626 return MATCH_ERROR; 627 } 628 629 if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, 630 gfc_new_block->name, NULL)) 631 return MATCH_ERROR; 632 633 return MATCH_YES; 634 } 635 636 637 /* See if the current input looks like a name of some sort. Modifies 638 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. 639 Note that options.c restricts max_identifier_length to not more 640 than GFC_MAX_SYMBOL_LEN. */ 641 642 match 643 gfc_match_name (char *buffer) 644 { 645 locus old_loc; 646 int i; 647 char c; 648 649 old_loc = gfc_current_locus; 650 gfc_gobble_whitespace (); 651 652 c = gfc_next_ascii_char (); 653 if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore))) 654 { 655 /* Special cases for unary minus and plus, which allows for a sensible 656 error message for code of the form 'c = exp(-a*b) )' where an 657 extra ')' appears at the end of statement. */ 658 if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+') 659 gfc_error ("Invalid character in name at %C"); 660 gfc_current_locus = old_loc; 661 return MATCH_NO; 662 } 663 664 i = 0; 665 666 do 667 { 668 buffer[i++] = c; 669 670 if (i > gfc_option.max_identifier_length) 671 { 672 gfc_error ("Name at %C is too long"); 673 return MATCH_ERROR; 674 } 675 676 old_loc = gfc_current_locus; 677 c = gfc_next_ascii_char (); 678 } 679 while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$')); 680 681 if (c == '$' && !flag_dollar_ok) 682 { 683 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to " 684 "allow it as an extension", &old_loc); 685 return MATCH_ERROR; 686 } 687 688 buffer[i] = '\0'; 689 gfc_current_locus = old_loc; 690 691 return MATCH_YES; 692 } 693 694 695 /* Match a symbol on the input. Modifies the pointer to the symbol 696 pointer if successful. */ 697 698 match 699 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) 700 { 701 char buffer[GFC_MAX_SYMBOL_LEN + 1]; 702 match m; 703 704 m = gfc_match_name (buffer); 705 if (m != MATCH_YES) 706 return m; 707 708 if (host_assoc) 709 return (gfc_get_ha_sym_tree (buffer, matched_symbol)) 710 ? MATCH_ERROR : MATCH_YES; 711 712 if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false)) 713 return MATCH_ERROR; 714 715 return MATCH_YES; 716 } 717 718 719 match 720 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) 721 { 722 gfc_symtree *st; 723 match m; 724 725 m = gfc_match_sym_tree (&st, host_assoc); 726 727 if (m == MATCH_YES) 728 { 729 if (st) 730 *matched_symbol = st->n.sym; 731 else 732 *matched_symbol = NULL; 733 } 734 else 735 *matched_symbol = NULL; 736 return m; 737 } 738 739 740 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, 741 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this 742 in matchexp.c. */ 743 744 match 745 gfc_match_intrinsic_op (gfc_intrinsic_op *result) 746 { 747 locus orig_loc = gfc_current_locus; 748 char ch; 749 750 gfc_gobble_whitespace (); 751 ch = gfc_next_ascii_char (); 752 switch (ch) 753 { 754 case '+': 755 /* Matched "+". */ 756 *result = INTRINSIC_PLUS; 757 return MATCH_YES; 758 759 case '-': 760 /* Matched "-". */ 761 *result = INTRINSIC_MINUS; 762 return MATCH_YES; 763 764 case '=': 765 if (gfc_next_ascii_char () == '=') 766 { 767 /* Matched "==". */ 768 *result = INTRINSIC_EQ; 769 return MATCH_YES; 770 } 771 break; 772 773 case '<': 774 if (gfc_peek_ascii_char () == '=') 775 { 776 /* Matched "<=". */ 777 gfc_next_ascii_char (); 778 *result = INTRINSIC_LE; 779 return MATCH_YES; 780 } 781 /* Matched "<". */ 782 *result = INTRINSIC_LT; 783 return MATCH_YES; 784 785 case '>': 786 if (gfc_peek_ascii_char () == '=') 787 { 788 /* Matched ">=". */ 789 gfc_next_ascii_char (); 790 *result = INTRINSIC_GE; 791 return MATCH_YES; 792 } 793 /* Matched ">". */ 794 *result = INTRINSIC_GT; 795 return MATCH_YES; 796 797 case '*': 798 if (gfc_peek_ascii_char () == '*') 799 { 800 /* Matched "**". */ 801 gfc_next_ascii_char (); 802 *result = INTRINSIC_POWER; 803 return MATCH_YES; 804 } 805 /* Matched "*". */ 806 *result = INTRINSIC_TIMES; 807 return MATCH_YES; 808 809 case '/': 810 ch = gfc_peek_ascii_char (); 811 if (ch == '=') 812 { 813 /* Matched "/=". */ 814 gfc_next_ascii_char (); 815 *result = INTRINSIC_NE; 816 return MATCH_YES; 817 } 818 else if (ch == '/') 819 { 820 /* Matched "//". */ 821 gfc_next_ascii_char (); 822 *result = INTRINSIC_CONCAT; 823 return MATCH_YES; 824 } 825 /* Matched "/". */ 826 *result = INTRINSIC_DIVIDE; 827 return MATCH_YES; 828 829 case '.': 830 ch = gfc_next_ascii_char (); 831 switch (ch) 832 { 833 case 'a': 834 if (gfc_next_ascii_char () == 'n' 835 && gfc_next_ascii_char () == 'd' 836 && gfc_next_ascii_char () == '.') 837 { 838 /* Matched ".and.". */ 839 *result = INTRINSIC_AND; 840 return MATCH_YES; 841 } 842 break; 843 844 case 'e': 845 if (gfc_next_ascii_char () == 'q') 846 { 847 ch = gfc_next_ascii_char (); 848 if (ch == '.') 849 { 850 /* Matched ".eq.". */ 851 *result = INTRINSIC_EQ_OS; 852 return MATCH_YES; 853 } 854 else if (ch == 'v') 855 { 856 if (gfc_next_ascii_char () == '.') 857 { 858 /* Matched ".eqv.". */ 859 *result = INTRINSIC_EQV; 860 return MATCH_YES; 861 } 862 } 863 } 864 break; 865 866 case 'g': 867 ch = gfc_next_ascii_char (); 868 if (ch == 'e') 869 { 870 if (gfc_next_ascii_char () == '.') 871 { 872 /* Matched ".ge.". */ 873 *result = INTRINSIC_GE_OS; 874 return MATCH_YES; 875 } 876 } 877 else if (ch == 't') 878 { 879 if (gfc_next_ascii_char () == '.') 880 { 881 /* Matched ".gt.". */ 882 *result = INTRINSIC_GT_OS; 883 return MATCH_YES; 884 } 885 } 886 break; 887 888 case 'l': 889 ch = gfc_next_ascii_char (); 890 if (ch == 'e') 891 { 892 if (gfc_next_ascii_char () == '.') 893 { 894 /* Matched ".le.". */ 895 *result = INTRINSIC_LE_OS; 896 return MATCH_YES; 897 } 898 } 899 else if (ch == 't') 900 { 901 if (gfc_next_ascii_char () == '.') 902 { 903 /* Matched ".lt.". */ 904 *result = INTRINSIC_LT_OS; 905 return MATCH_YES; 906 } 907 } 908 break; 909 910 case 'n': 911 ch = gfc_next_ascii_char (); 912 if (ch == 'e') 913 { 914 ch = gfc_next_ascii_char (); 915 if (ch == '.') 916 { 917 /* Matched ".ne.". */ 918 *result = INTRINSIC_NE_OS; 919 return MATCH_YES; 920 } 921 else if (ch == 'q') 922 { 923 if (gfc_next_ascii_char () == 'v' 924 && gfc_next_ascii_char () == '.') 925 { 926 /* Matched ".neqv.". */ 927 *result = INTRINSIC_NEQV; 928 return MATCH_YES; 929 } 930 } 931 } 932 else if (ch == 'o') 933 { 934 if (gfc_next_ascii_char () == 't' 935 && gfc_next_ascii_char () == '.') 936 { 937 /* Matched ".not.". */ 938 *result = INTRINSIC_NOT; 939 return MATCH_YES; 940 } 941 } 942 break; 943 944 case 'o': 945 if (gfc_next_ascii_char () == 'r' 946 && gfc_next_ascii_char () == '.') 947 { 948 /* Matched ".or.". */ 949 *result = INTRINSIC_OR; 950 return MATCH_YES; 951 } 952 break; 953 954 case 'x': 955 if (gfc_next_ascii_char () == 'o' 956 && gfc_next_ascii_char () == 'r' 957 && gfc_next_ascii_char () == '.') 958 { 959 if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C")) 960 return MATCH_ERROR; 961 /* Matched ".xor." - equivalent to ".neqv.". */ 962 *result = INTRINSIC_NEQV; 963 return MATCH_YES; 964 } 965 break; 966 967 default: 968 break; 969 } 970 break; 971 972 default: 973 break; 974 } 975 976 gfc_current_locus = orig_loc; 977 return MATCH_NO; 978 } 979 980 981 /* Match a loop control phrase: 982 983 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ] 984 985 If the final integer expression is not present, a constant unity 986 expression is returned. We don't return MATCH_ERROR until after 987 the equals sign is seen. */ 988 989 match 990 gfc_match_iterator (gfc_iterator *iter, int init_flag) 991 { 992 char name[GFC_MAX_SYMBOL_LEN + 1]; 993 gfc_expr *var, *e1, *e2, *e3; 994 locus start; 995 match m; 996 997 e1 = e2 = e3 = NULL; 998 999 /* Match the start of an iterator without affecting the symbol table. */ 1000 1001 start = gfc_current_locus; 1002 m = gfc_match (" %n =", name); 1003 gfc_current_locus = start; 1004 1005 if (m != MATCH_YES) 1006 return MATCH_NO; 1007 1008 m = gfc_match_variable (&var, 0); 1009 if (m != MATCH_YES) 1010 return MATCH_NO; 1011 1012 if (var->symtree->n.sym->attr.dimension) 1013 { 1014 gfc_error ("Loop variable at %C cannot be an array"); 1015 goto cleanup; 1016 } 1017 1018 /* F2008, C617 & C565. */ 1019 if (var->symtree->n.sym->attr.codimension) 1020 { 1021 gfc_error ("Loop variable at %C cannot be a coarray"); 1022 goto cleanup; 1023 } 1024 1025 if (var->ref != NULL) 1026 { 1027 gfc_error ("Loop variable at %C cannot be a sub-component"); 1028 goto cleanup; 1029 } 1030 1031 gfc_match_char ('='); 1032 1033 var->symtree->n.sym->attr.implied_index = 1; 1034 1035 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); 1036 if (m == MATCH_NO) 1037 goto syntax; 1038 if (m == MATCH_ERROR) 1039 goto cleanup; 1040 1041 if (gfc_match_char (',') != MATCH_YES) 1042 goto syntax; 1043 1044 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2); 1045 if (m == MATCH_NO) 1046 goto syntax; 1047 if (m == MATCH_ERROR) 1048 goto cleanup; 1049 1050 if (gfc_match_char (',') != MATCH_YES) 1051 { 1052 e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 1053 goto done; 1054 } 1055 1056 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3); 1057 if (m == MATCH_ERROR) 1058 goto cleanup; 1059 if (m == MATCH_NO) 1060 { 1061 gfc_error ("Expected a step value in iterator at %C"); 1062 goto cleanup; 1063 } 1064 1065 done: 1066 iter->var = var; 1067 iter->start = e1; 1068 iter->end = e2; 1069 iter->step = e3; 1070 return MATCH_YES; 1071 1072 syntax: 1073 gfc_error ("Syntax error in iterator at %C"); 1074 1075 cleanup: 1076 gfc_free_expr (e1); 1077 gfc_free_expr (e2); 1078 gfc_free_expr (e3); 1079 1080 return MATCH_ERROR; 1081 } 1082 1083 1084 /* Tries to match the next non-whitespace character on the input. 1085 This subroutine does not return MATCH_ERROR. */ 1086 1087 match 1088 gfc_match_char (char c) 1089 { 1090 locus where; 1091 1092 where = gfc_current_locus; 1093 gfc_gobble_whitespace (); 1094 1095 if (gfc_next_ascii_char () == c) 1096 return MATCH_YES; 1097 1098 gfc_current_locus = where; 1099 return MATCH_NO; 1100 } 1101 1102 1103 /* General purpose matching subroutine. The target string is a 1104 scanf-like format string in which spaces correspond to arbitrary 1105 whitespace (including no whitespace), characters correspond to 1106 themselves. The %-codes are: 1107 1108 %% Literal percent sign 1109 %e Expression, pointer to a pointer is set 1110 %s Symbol, pointer to the symbol is set 1111 %n Name, character buffer is set to name 1112 %t Matches end of statement. 1113 %o Matches an intrinsic operator, returned as an INTRINSIC enum. 1114 %l Matches a statement label 1115 %v Matches a variable expression (an lvalue) 1116 % Matches a required space (in free form) and optional spaces. */ 1117 1118 match 1119 gfc_match (const char *target, ...) 1120 { 1121 gfc_st_label **label; 1122 int matches, *ip; 1123 locus old_loc; 1124 va_list argp; 1125 char c, *np; 1126 match m, n; 1127 void **vp; 1128 const char *p; 1129 1130 old_loc = gfc_current_locus; 1131 va_start (argp, target); 1132 m = MATCH_NO; 1133 matches = 0; 1134 p = target; 1135 1136 loop: 1137 c = *p++; 1138 switch (c) 1139 { 1140 case ' ': 1141 gfc_gobble_whitespace (); 1142 goto loop; 1143 case '\0': 1144 m = MATCH_YES; 1145 break; 1146 1147 case '%': 1148 c = *p++; 1149 switch (c) 1150 { 1151 case 'e': 1152 vp = va_arg (argp, void **); 1153 n = gfc_match_expr ((gfc_expr **) vp); 1154 if (n != MATCH_YES) 1155 { 1156 m = n; 1157 goto not_yes; 1158 } 1159 1160 matches++; 1161 goto loop; 1162 1163 case 'v': 1164 vp = va_arg (argp, void **); 1165 n = gfc_match_variable ((gfc_expr **) vp, 0); 1166 if (n != MATCH_YES) 1167 { 1168 m = n; 1169 goto not_yes; 1170 } 1171 1172 matches++; 1173 goto loop; 1174 1175 case 's': 1176 vp = va_arg (argp, void **); 1177 n = gfc_match_symbol ((gfc_symbol **) vp, 0); 1178 if (n != MATCH_YES) 1179 { 1180 m = n; 1181 goto not_yes; 1182 } 1183 1184 matches++; 1185 goto loop; 1186 1187 case 'n': 1188 np = va_arg (argp, char *); 1189 n = gfc_match_name (np); 1190 if (n != MATCH_YES) 1191 { 1192 m = n; 1193 goto not_yes; 1194 } 1195 1196 matches++; 1197 goto loop; 1198 1199 case 'l': 1200 label = va_arg (argp, gfc_st_label **); 1201 n = gfc_match_st_label (label); 1202 if (n != MATCH_YES) 1203 { 1204 m = n; 1205 goto not_yes; 1206 } 1207 1208 matches++; 1209 goto loop; 1210 1211 case 'o': 1212 ip = va_arg (argp, int *); 1213 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip); 1214 if (n != MATCH_YES) 1215 { 1216 m = n; 1217 goto not_yes; 1218 } 1219 1220 matches++; 1221 goto loop; 1222 1223 case 't': 1224 if (gfc_match_eos () != MATCH_YES) 1225 { 1226 m = MATCH_NO; 1227 goto not_yes; 1228 } 1229 goto loop; 1230 1231 case ' ': 1232 if (gfc_match_space () == MATCH_YES) 1233 goto loop; 1234 m = MATCH_NO; 1235 goto not_yes; 1236 1237 case '%': 1238 break; /* Fall through to character matcher. */ 1239 1240 default: 1241 gfc_internal_error ("gfc_match(): Bad match code %c", c); 1242 } 1243 /* FALLTHRU */ 1244 1245 default: 1246 1247 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't 1248 expect an upper case character here! */ 1249 gcc_assert (TOLOWER (c) == c); 1250 1251 if (c == gfc_next_ascii_char ()) 1252 goto loop; 1253 break; 1254 } 1255 1256 not_yes: 1257 va_end (argp); 1258 1259 if (m != MATCH_YES) 1260 { 1261 /* Clean up after a failed match. */ 1262 gfc_current_locus = old_loc; 1263 va_start (argp, target); 1264 1265 p = target; 1266 for (; matches > 0; matches--) 1267 { 1268 while (*p++ != '%'); 1269 1270 switch (*p++) 1271 { 1272 case '%': 1273 matches++; 1274 break; /* Skip. */ 1275 1276 /* Matches that don't have to be undone */ 1277 case 'o': 1278 case 'l': 1279 case 'n': 1280 case 's': 1281 (void) va_arg (argp, void **); 1282 break; 1283 1284 case 'e': 1285 case 'v': 1286 vp = va_arg (argp, void **); 1287 gfc_free_expr ((struct gfc_expr *)*vp); 1288 *vp = NULL; 1289 break; 1290 } 1291 } 1292 1293 va_end (argp); 1294 } 1295 1296 return m; 1297 } 1298 1299 1300 /*********************** Statement level matching **********************/ 1301 1302 /* Matches the start of a program unit, which is the program keyword 1303 followed by an obligatory symbol. */ 1304 1305 match 1306 gfc_match_program (void) 1307 { 1308 gfc_symbol *sym; 1309 match m; 1310 1311 m = gfc_match ("% %s%t", &sym); 1312 1313 if (m == MATCH_NO) 1314 { 1315 gfc_error ("Invalid form of PROGRAM statement at %C"); 1316 m = MATCH_ERROR; 1317 } 1318 1319 if (m == MATCH_ERROR) 1320 return m; 1321 1322 if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL)) 1323 return MATCH_ERROR; 1324 1325 gfc_new_block = sym; 1326 1327 return MATCH_YES; 1328 } 1329 1330 1331 /* Match a simple assignment statement. */ 1332 1333 match 1334 gfc_match_assignment (void) 1335 { 1336 gfc_expr *lvalue, *rvalue; 1337 locus old_loc; 1338 match m; 1339 1340 old_loc = gfc_current_locus; 1341 1342 lvalue = NULL; 1343 m = gfc_match (" %v =", &lvalue); 1344 if (m != MATCH_YES) 1345 { 1346 gfc_current_locus = old_loc; 1347 gfc_free_expr (lvalue); 1348 return MATCH_NO; 1349 } 1350 1351 rvalue = NULL; 1352 m = gfc_match (" %e%t", &rvalue); 1353 1354 if (lvalue->expr_type == EXPR_CONSTANT) 1355 { 1356 /* This clobbers %len and %kind. */ 1357 m = MATCH_ERROR; 1358 gfc_error ("Assignment to a constant expression at %C"); 1359 } 1360 1361 if (m != MATCH_YES) 1362 { 1363 gfc_current_locus = old_loc; 1364 gfc_free_expr (lvalue); 1365 gfc_free_expr (rvalue); 1366 return m; 1367 } 1368 1369 gfc_set_sym_referenced (lvalue->symtree->n.sym); 1370 1371 new_st.op = EXEC_ASSIGN; 1372 new_st.expr1 = lvalue; 1373 new_st.expr2 = rvalue; 1374 1375 gfc_check_do_variable (lvalue->symtree); 1376 1377 if (lvalue->ts.type == BT_CLASS) 1378 gfc_find_vtab (&rvalue->ts); 1379 1380 return MATCH_YES; 1381 } 1382 1383 1384 /* Match a pointer assignment statement. */ 1385 1386 match 1387 gfc_match_pointer_assignment (void) 1388 { 1389 gfc_expr *lvalue, *rvalue; 1390 locus old_loc; 1391 match m; 1392 1393 old_loc = gfc_current_locus; 1394 1395 lvalue = rvalue = NULL; 1396 gfc_matching_ptr_assignment = 0; 1397 gfc_matching_procptr_assignment = 0; 1398 1399 m = gfc_match (" %v =>", &lvalue); 1400 if (m != MATCH_YES) 1401 { 1402 m = MATCH_NO; 1403 goto cleanup; 1404 } 1405 1406 if (lvalue->symtree->n.sym->attr.proc_pointer 1407 || gfc_is_proc_ptr_comp (lvalue)) 1408 gfc_matching_procptr_assignment = 1; 1409 else 1410 gfc_matching_ptr_assignment = 1; 1411 1412 m = gfc_match (" %e%t", &rvalue); 1413 gfc_matching_ptr_assignment = 0; 1414 gfc_matching_procptr_assignment = 0; 1415 if (m != MATCH_YES) 1416 goto cleanup; 1417 1418 new_st.op = EXEC_POINTER_ASSIGN; 1419 new_st.expr1 = lvalue; 1420 new_st.expr2 = rvalue; 1421 1422 return MATCH_YES; 1423 1424 cleanup: 1425 gfc_current_locus = old_loc; 1426 gfc_free_expr (lvalue); 1427 gfc_free_expr (rvalue); 1428 return m; 1429 } 1430 1431 1432 /* We try to match an easy arithmetic IF statement. This only happens 1433 when just after having encountered a simple IF statement. This code 1434 is really duplicate with parts of the gfc_match_if code, but this is 1435 *much* easier. */ 1436 1437 static match 1438 match_arithmetic_if (void) 1439 { 1440 gfc_st_label *l1, *l2, *l3; 1441 gfc_expr *expr; 1442 match m; 1443 1444 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3); 1445 if (m != MATCH_YES) 1446 return m; 1447 1448 if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) 1449 || !gfc_reference_st_label (l2, ST_LABEL_TARGET) 1450 || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) 1451 { 1452 gfc_free_expr (expr); 1453 return MATCH_ERROR; 1454 } 1455 1456 if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, 1457 "Arithmetic IF statement at %C")) 1458 return MATCH_ERROR; 1459 1460 new_st.op = EXEC_ARITHMETIC_IF; 1461 new_st.expr1 = expr; 1462 new_st.label1 = l1; 1463 new_st.label2 = l2; 1464 new_st.label3 = l3; 1465 1466 return MATCH_YES; 1467 } 1468 1469 1470 /* The IF statement is a bit of a pain. First of all, there are three 1471 forms of it, the simple IF, the IF that starts a block and the 1472 arithmetic IF. 1473 1474 There is a problem with the simple IF and that is the fact that we 1475 only have a single level of undo information on symbols. What this 1476 means is for a simple IF, we must re-match the whole IF statement 1477 multiple times in order to guarantee that the symbol table ends up 1478 in the proper state. */ 1479 1480 static match match_simple_forall (void); 1481 static match match_simple_where (void); 1482 1483 match 1484 gfc_match_if (gfc_statement *if_type) 1485 { 1486 gfc_expr *expr; 1487 gfc_st_label *l1, *l2, *l3; 1488 locus old_loc, old_loc2; 1489 gfc_code *p; 1490 match m, n; 1491 1492 n = gfc_match_label (); 1493 if (n == MATCH_ERROR) 1494 return n; 1495 1496 old_loc = gfc_current_locus; 1497 1498 m = gfc_match (" if ( %e", &expr); 1499 if (m != MATCH_YES) 1500 return m; 1501 1502 old_loc2 = gfc_current_locus; 1503 gfc_current_locus = old_loc; 1504 1505 if (gfc_match_parens () == MATCH_ERROR) 1506 return MATCH_ERROR; 1507 1508 gfc_current_locus = old_loc2; 1509 1510 if (gfc_match_char (')') != MATCH_YES) 1511 { 1512 gfc_error ("Syntax error in IF-expression at %C"); 1513 gfc_free_expr (expr); 1514 return MATCH_ERROR; 1515 } 1516 1517 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3); 1518 1519 if (m == MATCH_YES) 1520 { 1521 if (n == MATCH_YES) 1522 { 1523 gfc_error ("Block label not appropriate for arithmetic IF " 1524 "statement at %C"); 1525 gfc_free_expr (expr); 1526 return MATCH_ERROR; 1527 } 1528 1529 if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) 1530 || !gfc_reference_st_label (l2, ST_LABEL_TARGET) 1531 || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) 1532 { 1533 gfc_free_expr (expr); 1534 return MATCH_ERROR; 1535 } 1536 1537 if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, 1538 "Arithmetic IF statement at %C")) 1539 return MATCH_ERROR; 1540 1541 new_st.op = EXEC_ARITHMETIC_IF; 1542 new_st.expr1 = expr; 1543 new_st.label1 = l1; 1544 new_st.label2 = l2; 1545 new_st.label3 = l3; 1546 1547 *if_type = ST_ARITHMETIC_IF; 1548 return MATCH_YES; 1549 } 1550 1551 if (gfc_match (" then%t") == MATCH_YES) 1552 { 1553 new_st.op = EXEC_IF; 1554 new_st.expr1 = expr; 1555 *if_type = ST_IF_BLOCK; 1556 return MATCH_YES; 1557 } 1558 1559 if (n == MATCH_YES) 1560 { 1561 gfc_error ("Block label is not appropriate for IF statement at %C"); 1562 gfc_free_expr (expr); 1563 return MATCH_ERROR; 1564 } 1565 1566 /* At this point the only thing left is a simple IF statement. At 1567 this point, n has to be MATCH_NO, so we don't have to worry about 1568 re-matching a block label. From what we've got so far, try 1569 matching an assignment. */ 1570 1571 *if_type = ST_SIMPLE_IF; 1572 1573 m = gfc_match_assignment (); 1574 if (m == MATCH_YES) 1575 goto got_match; 1576 1577 gfc_free_expr (expr); 1578 gfc_undo_symbols (); 1579 gfc_current_locus = old_loc; 1580 1581 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled 1582 assignment was found. For MATCH_NO, continue to call the various 1583 matchers. */ 1584 if (m == MATCH_ERROR) 1585 return MATCH_ERROR; 1586 1587 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ 1588 1589 m = gfc_match_pointer_assignment (); 1590 if (m == MATCH_YES) 1591 goto got_match; 1592 1593 gfc_free_expr (expr); 1594 gfc_undo_symbols (); 1595 gfc_current_locus = old_loc; 1596 1597 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ 1598 1599 /* Look at the next keyword to see which matcher to call. Matching 1600 the keyword doesn't affect the symbol table, so we don't have to 1601 restore between tries. */ 1602 1603 #define match(string, subr, statement) \ 1604 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; } 1605 1606 gfc_clear_error (); 1607 1608 match ("allocate", gfc_match_allocate, ST_ALLOCATE) 1609 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) 1610 match ("backspace", gfc_match_backspace, ST_BACKSPACE) 1611 match ("call", gfc_match_call, ST_CALL) 1612 match ("change team", gfc_match_change_team, ST_CHANGE_TEAM) 1613 match ("close", gfc_match_close, ST_CLOSE) 1614 match ("continue", gfc_match_continue, ST_CONTINUE) 1615 match ("cycle", gfc_match_cycle, ST_CYCLE) 1616 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) 1617 match ("end file", gfc_match_endfile, ST_END_FILE) 1618 match ("end team", gfc_match_end_team, ST_END_TEAM) 1619 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) 1620 match ("event post", gfc_match_event_post, ST_EVENT_POST) 1621 match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT) 1622 match ("exit", gfc_match_exit, ST_EXIT) 1623 match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE) 1624 match ("flush", gfc_match_flush, ST_FLUSH) 1625 match ("forall", match_simple_forall, ST_FORALL) 1626 match ("form team", gfc_match_form_team, ST_FORM_TEAM) 1627 match ("go to", gfc_match_goto, ST_GOTO) 1628 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) 1629 match ("inquire", gfc_match_inquire, ST_INQUIRE) 1630 match ("lock", gfc_match_lock, ST_LOCK) 1631 match ("nullify", gfc_match_nullify, ST_NULLIFY) 1632 match ("open", gfc_match_open, ST_OPEN) 1633 match ("pause", gfc_match_pause, ST_NONE) 1634 match ("print", gfc_match_print, ST_WRITE) 1635 match ("read", gfc_match_read, ST_READ) 1636 match ("return", gfc_match_return, ST_RETURN) 1637 match ("rewind", gfc_match_rewind, ST_REWIND) 1638 match ("stop", gfc_match_stop, ST_STOP) 1639 match ("wait", gfc_match_wait, ST_WAIT) 1640 match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); 1641 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); 1642 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); 1643 match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM) 1644 match ("unlock", gfc_match_unlock, ST_UNLOCK) 1645 match ("where", match_simple_where, ST_WHERE) 1646 match ("write", gfc_match_write, ST_WRITE) 1647 1648 if (flag_dec) 1649 match ("type", gfc_match_print, ST_WRITE) 1650 1651 /* The gfc_match_assignment() above may have returned a MATCH_NO 1652 where the assignment was to a named constant. Check that 1653 special case here. */ 1654 m = gfc_match_assignment (); 1655 if (m == MATCH_NO) 1656 { 1657 gfc_error ("Cannot assign to a named constant at %C"); 1658 gfc_free_expr (expr); 1659 gfc_undo_symbols (); 1660 gfc_current_locus = old_loc; 1661 return MATCH_ERROR; 1662 } 1663 1664 /* All else has failed, so give up. See if any of the matchers has 1665 stored an error message of some sort. */ 1666 if (!gfc_error_check ()) 1667 gfc_error ("Unclassifiable statement in IF-clause at %C"); 1668 1669 gfc_free_expr (expr); 1670 return MATCH_ERROR; 1671 1672 got_match: 1673 if (m == MATCH_NO) 1674 gfc_error ("Syntax error in IF-clause at %C"); 1675 if (m != MATCH_YES) 1676 { 1677 gfc_free_expr (expr); 1678 return MATCH_ERROR; 1679 } 1680 1681 /* At this point, we've matched the single IF and the action clause 1682 is in new_st. Rearrange things so that the IF statement appears 1683 in new_st. */ 1684 1685 p = gfc_get_code (EXEC_IF); 1686 p->next = XCNEW (gfc_code); 1687 *p->next = new_st; 1688 p->next->loc = gfc_current_locus; 1689 1690 p->expr1 = expr; 1691 1692 gfc_clear_new_st (); 1693 1694 new_st.op = EXEC_IF; 1695 new_st.block = p; 1696 1697 return MATCH_YES; 1698 } 1699 1700 #undef match 1701 1702 1703 /* Match an ELSE statement. */ 1704 1705 match 1706 gfc_match_else (void) 1707 { 1708 char name[GFC_MAX_SYMBOL_LEN + 1]; 1709 1710 if (gfc_match_eos () == MATCH_YES) 1711 return MATCH_YES; 1712 1713 if (gfc_match_name (name) != MATCH_YES 1714 || gfc_current_block () == NULL 1715 || gfc_match_eos () != MATCH_YES) 1716 { 1717 gfc_error ("Unexpected junk after ELSE statement at %C"); 1718 return MATCH_ERROR; 1719 } 1720 1721 if (strcmp (name, gfc_current_block ()->name) != 0) 1722 { 1723 gfc_error ("Label %qs at %C doesn't match IF label %qs", 1724 name, gfc_current_block ()->name); 1725 return MATCH_ERROR; 1726 } 1727 1728 return MATCH_YES; 1729 } 1730 1731 1732 /* Match an ELSE IF statement. */ 1733 1734 match 1735 gfc_match_elseif (void) 1736 { 1737 char name[GFC_MAX_SYMBOL_LEN + 1]; 1738 gfc_expr *expr; 1739 match m; 1740 1741 m = gfc_match (" ( %e ) then", &expr); 1742 if (m != MATCH_YES) 1743 return m; 1744 1745 if (gfc_match_eos () == MATCH_YES) 1746 goto done; 1747 1748 if (gfc_match_name (name) != MATCH_YES 1749 || gfc_current_block () == NULL 1750 || gfc_match_eos () != MATCH_YES) 1751 { 1752 gfc_error ("Unexpected junk after ELSE IF statement at %C"); 1753 goto cleanup; 1754 } 1755 1756 if (strcmp (name, gfc_current_block ()->name) != 0) 1757 { 1758 gfc_error ("Label %qs at %C doesn't match IF label %qs", 1759 name, gfc_current_block ()->name); 1760 goto cleanup; 1761 } 1762 1763 done: 1764 new_st.op = EXEC_IF; 1765 new_st.expr1 = expr; 1766 return MATCH_YES; 1767 1768 cleanup: 1769 gfc_free_expr (expr); 1770 return MATCH_ERROR; 1771 } 1772 1773 1774 /* Free a gfc_iterator structure. */ 1775 1776 void 1777 gfc_free_iterator (gfc_iterator *iter, int flag) 1778 { 1779 1780 if (iter == NULL) 1781 return; 1782 1783 gfc_free_expr (iter->var); 1784 gfc_free_expr (iter->start); 1785 gfc_free_expr (iter->end); 1786 gfc_free_expr (iter->step); 1787 1788 if (flag) 1789 free (iter); 1790 } 1791 1792 1793 /* Match a CRITICAL statement. */ 1794 match 1795 gfc_match_critical (void) 1796 { 1797 gfc_st_label *label = NULL; 1798 1799 if (gfc_match_label () == MATCH_ERROR) 1800 return MATCH_ERROR; 1801 1802 if (gfc_match (" critical") != MATCH_YES) 1803 return MATCH_NO; 1804 1805 if (gfc_match_st_label (&label) == MATCH_ERROR) 1806 return MATCH_ERROR; 1807 1808 if (gfc_match_eos () != MATCH_YES) 1809 { 1810 gfc_syntax_error (ST_CRITICAL); 1811 return MATCH_ERROR; 1812 } 1813 1814 if (gfc_pure (NULL)) 1815 { 1816 gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); 1817 return MATCH_ERROR; 1818 } 1819 1820 if (gfc_find_state (COMP_DO_CONCURRENT)) 1821 { 1822 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT " 1823 "block"); 1824 return MATCH_ERROR; 1825 } 1826 1827 gfc_unset_implicit_pure (NULL); 1828 1829 if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C")) 1830 return MATCH_ERROR; 1831 1832 if (flag_coarray == GFC_FCOARRAY_NONE) 1833 { 1834 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " 1835 "enable"); 1836 return MATCH_ERROR; 1837 } 1838 1839 if (gfc_find_state (COMP_CRITICAL)) 1840 { 1841 gfc_error ("Nested CRITICAL block at %C"); 1842 return MATCH_ERROR; 1843 } 1844 1845 new_st.op = EXEC_CRITICAL; 1846 1847 if (label != NULL 1848 && !gfc_reference_st_label (label, ST_LABEL_TARGET)) 1849 return MATCH_ERROR; 1850 1851 return MATCH_YES; 1852 } 1853 1854 1855 /* Match a BLOCK statement. */ 1856 1857 match 1858 gfc_match_block (void) 1859 { 1860 match m; 1861 1862 if (gfc_match_label () == MATCH_ERROR) 1863 return MATCH_ERROR; 1864 1865 if (gfc_match (" block") != MATCH_YES) 1866 return MATCH_NO; 1867 1868 /* For this to be a correct BLOCK statement, the line must end now. */ 1869 m = gfc_match_eos (); 1870 if (m == MATCH_ERROR) 1871 return MATCH_ERROR; 1872 if (m == MATCH_NO) 1873 return MATCH_NO; 1874 1875 return MATCH_YES; 1876 } 1877 1878 1879 /* Match an ASSOCIATE statement. */ 1880 1881 match 1882 gfc_match_associate (void) 1883 { 1884 if (gfc_match_label () == MATCH_ERROR) 1885 return MATCH_ERROR; 1886 1887 if (gfc_match (" associate") != MATCH_YES) 1888 return MATCH_NO; 1889 1890 /* Match the association list. */ 1891 if (gfc_match_char ('(') != MATCH_YES) 1892 { 1893 gfc_error ("Expected association list at %C"); 1894 return MATCH_ERROR; 1895 } 1896 new_st.ext.block.assoc = NULL; 1897 while (true) 1898 { 1899 gfc_association_list* newAssoc = gfc_get_association_list (); 1900 gfc_association_list* a; 1901 1902 /* Match the next association. */ 1903 if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES) 1904 { 1905 gfc_error ("Expected association at %C"); 1906 goto assocListError; 1907 } 1908 1909 if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) 1910 { 1911 /* Have another go, allowing for procedure pointer selectors. */ 1912 gfc_matching_procptr_assignment = 1; 1913 if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) 1914 { 1915 gfc_error ("Invalid association target at %C"); 1916 goto assocListError; 1917 } 1918 gfc_matching_procptr_assignment = 0; 1919 } 1920 newAssoc->where = gfc_current_locus; 1921 1922 /* Check that the current name is not yet in the list. */ 1923 for (a = new_st.ext.block.assoc; a; a = a->next) 1924 if (!strcmp (a->name, newAssoc->name)) 1925 { 1926 gfc_error ("Duplicate name %qs in association at %C", 1927 newAssoc->name); 1928 goto assocListError; 1929 } 1930 1931 /* The target expression must not be coindexed. */ 1932 if (gfc_is_coindexed (newAssoc->target)) 1933 { 1934 gfc_error ("Association target at %C must not be coindexed"); 1935 goto assocListError; 1936 } 1937 1938 /* The `variable' field is left blank for now; because the target is not 1939 yet resolved, we can't use gfc_has_vector_subscript to determine it 1940 for now. This is set during resolution. */ 1941 1942 /* Put it into the list. */ 1943 newAssoc->next = new_st.ext.block.assoc; 1944 new_st.ext.block.assoc = newAssoc; 1945 1946 /* Try next one or end if closing parenthesis is found. */ 1947 gfc_gobble_whitespace (); 1948 if (gfc_peek_char () == ')') 1949 break; 1950 if (gfc_match_char (',') != MATCH_YES) 1951 { 1952 gfc_error ("Expected %<)%> or %<,%> at %C"); 1953 return MATCH_ERROR; 1954 } 1955 1956 continue; 1957 1958 assocListError: 1959 free (newAssoc); 1960 goto error; 1961 } 1962 if (gfc_match_char (')') != MATCH_YES) 1963 { 1964 /* This should never happen as we peek above. */ 1965 gcc_unreachable (); 1966 } 1967 1968 if (gfc_match_eos () != MATCH_YES) 1969 { 1970 gfc_error ("Junk after ASSOCIATE statement at %C"); 1971 goto error; 1972 } 1973 1974 return MATCH_YES; 1975 1976 error: 1977 gfc_free_association_list (new_st.ext.block.assoc); 1978 return MATCH_ERROR; 1979 } 1980 1981 1982 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of 1983 an accessible derived type. */ 1984 1985 static match 1986 match_derived_type_spec (gfc_typespec *ts) 1987 { 1988 char name[GFC_MAX_SYMBOL_LEN + 1]; 1989 locus old_locus; 1990 gfc_symbol *derived, *der_type; 1991 match m = MATCH_YES; 1992 gfc_actual_arglist *decl_type_param_list = NULL; 1993 bool is_pdt_template = false; 1994 1995 old_locus = gfc_current_locus; 1996 1997 if (gfc_match ("%n", name) != MATCH_YES) 1998 { 1999 gfc_current_locus = old_locus; 2000 return MATCH_NO; 2001 } 2002 2003 gfc_find_symbol (name, NULL, 1, &derived); 2004 2005 /* Match the PDT spec list, if there. */ 2006 if (derived && derived->attr.flavor == FL_PROCEDURE) 2007 { 2008 gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type); 2009 is_pdt_template = der_type 2010 && der_type->attr.flavor == FL_DERIVED 2011 && der_type->attr.pdt_template; 2012 } 2013 2014 if (is_pdt_template) 2015 m = gfc_match_actual_arglist (1, &decl_type_param_list, true); 2016 2017 if (m == MATCH_ERROR) 2018 { 2019 gfc_free_actual_arglist (decl_type_param_list); 2020 return m; 2021 } 2022 2023 if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic) 2024 derived = gfc_find_dt_in_generic (derived); 2025 2026 /* If this is a PDT, find the specific instance. */ 2027 if (m == MATCH_YES && is_pdt_template) 2028 { 2029 gfc_namespace *old_ns; 2030 2031 old_ns = gfc_current_ns; 2032 while (gfc_current_ns && gfc_current_ns->parent) 2033 gfc_current_ns = gfc_current_ns->parent; 2034 2035 if (type_param_spec_list) 2036 gfc_free_actual_arglist (type_param_spec_list); 2037 m = gfc_get_pdt_instance (decl_type_param_list, &der_type, 2038 &type_param_spec_list); 2039 gfc_free_actual_arglist (decl_type_param_list); 2040 2041 if (m != MATCH_YES) 2042 return m; 2043 derived = der_type; 2044 gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type); 2045 gfc_set_sym_referenced (derived); 2046 2047 gfc_current_ns = old_ns; 2048 } 2049 2050 if (derived && derived->attr.flavor == FL_DERIVED) 2051 { 2052 ts->type = BT_DERIVED; 2053 ts->u.derived = derived; 2054 return MATCH_YES; 2055 } 2056 2057 gfc_current_locus = old_locus; 2058 return MATCH_NO; 2059 } 2060 2061 2062 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to 2063 gfc_match_decl_type_spec() from decl.c, with the following exceptions: 2064 It only includes the intrinsic types from the Fortran 2003 standard 2065 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, 2066 the implicit_flag is not needed, so it was removed. Derived types are 2067 identified by their name alone. */ 2068 2069 match 2070 gfc_match_type_spec (gfc_typespec *ts) 2071 { 2072 match m; 2073 locus old_locus; 2074 char c, name[GFC_MAX_SYMBOL_LEN + 1]; 2075 2076 gfc_clear_ts (ts); 2077 gfc_gobble_whitespace (); 2078 old_locus = gfc_current_locus; 2079 2080 /* If c isn't [a-z], then return immediately. */ 2081 c = gfc_peek_ascii_char (); 2082 if (!ISALPHA(c)) 2083 return MATCH_NO; 2084 2085 type_param_spec_list = NULL; 2086 2087 if (match_derived_type_spec (ts) == MATCH_YES) 2088 { 2089 /* Enforce F03:C401. */ 2090 if (ts->u.derived->attr.abstract) 2091 { 2092 gfc_error ("Derived type %qs at %L may not be ABSTRACT", 2093 ts->u.derived->name, &old_locus); 2094 return MATCH_ERROR; 2095 } 2096 return MATCH_YES; 2097 } 2098 2099 if (gfc_match ("integer") == MATCH_YES) 2100 { 2101 ts->type = BT_INTEGER; 2102 ts->kind = gfc_default_integer_kind; 2103 goto kind_selector; 2104 } 2105 2106 if (gfc_match ("double precision") == MATCH_YES) 2107 { 2108 ts->type = BT_REAL; 2109 ts->kind = gfc_default_double_kind; 2110 return MATCH_YES; 2111 } 2112 2113 if (gfc_match ("complex") == MATCH_YES) 2114 { 2115 ts->type = BT_COMPLEX; 2116 ts->kind = gfc_default_complex_kind; 2117 goto kind_selector; 2118 } 2119 2120 if (gfc_match ("character") == MATCH_YES) 2121 { 2122 ts->type = BT_CHARACTER; 2123 2124 m = gfc_match_char_spec (ts); 2125 2126 if (m == MATCH_NO) 2127 m = MATCH_YES; 2128 2129 return m; 2130 } 2131 2132 /* REAL is a real pain because it can be a type, intrinsic subprogram, 2133 or list item in a type-list of an OpenMP reduction clause. Need to 2134 differentiate REAL([KIND]=scalar-int-initialization-expr) from 2135 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was 2136 written the use of LOGICAL as a type-spec or intrinsic subprogram 2137 was overlooked. */ 2138 2139 m = gfc_match (" %n", name); 2140 if (m == MATCH_YES 2141 && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0)) 2142 { 2143 char c; 2144 gfc_expr *e; 2145 locus where; 2146 2147 if (*name == 'r') 2148 { 2149 ts->type = BT_REAL; 2150 ts->kind = gfc_default_real_kind; 2151 } 2152 else 2153 { 2154 ts->type = BT_LOGICAL; 2155 ts->kind = gfc_default_logical_kind; 2156 } 2157 2158 gfc_gobble_whitespace (); 2159 2160 /* Prevent REAL*4, etc. */ 2161 c = gfc_peek_ascii_char (); 2162 if (c == '*') 2163 { 2164 gfc_error ("Invalid type-spec at %C"); 2165 return MATCH_ERROR; 2166 } 2167 2168 /* Found leading colon in REAL::, a trailing ')' in for example 2169 TYPE IS (REAL), or REAL, for an OpenMP list-item. */ 2170 if (c == ':' || c == ')' || (flag_openmp && c == ',')) 2171 return MATCH_YES; 2172 2173 /* Found something other than the opening '(' in REAL(... */ 2174 if (c != '(') 2175 return MATCH_NO; 2176 else 2177 gfc_next_char (); /* Burn the '('. */ 2178 2179 /* Look for the optional KIND=. */ 2180 where = gfc_current_locus; 2181 m = gfc_match ("%n", name); 2182 if (m == MATCH_YES) 2183 { 2184 gfc_gobble_whitespace (); 2185 c = gfc_next_char (); 2186 if (c == '=') 2187 { 2188 if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0) 2189 return MATCH_NO; 2190 else if (strcmp(name, "kind") == 0) 2191 goto found; 2192 else 2193 return MATCH_ERROR; 2194 } 2195 else 2196 gfc_current_locus = where; 2197 } 2198 else 2199 gfc_current_locus = where; 2200 2201 found: 2202 2203 m = gfc_match_init_expr (&e); 2204 if (m == MATCH_NO || m == MATCH_ERROR) 2205 return MATCH_NO; 2206 2207 /* If a comma appears, it is an intrinsic subprogram. */ 2208 gfc_gobble_whitespace (); 2209 c = gfc_peek_ascii_char (); 2210 if (c == ',') 2211 { 2212 gfc_free_expr (e); 2213 return MATCH_NO; 2214 } 2215 2216 /* If ')' appears, we have REAL(initialization-expr), here check for 2217 a scalar integer initialization-expr and valid kind parameter. */ 2218 if (c == ')') 2219 { 2220 if (e->ts.type != BT_INTEGER || e->rank > 0) 2221 { 2222 gfc_free_expr (e); 2223 return MATCH_NO; 2224 } 2225 2226 if (e->expr_type != EXPR_CONSTANT) 2227 goto ohno; 2228 2229 gfc_next_char (); /* Burn the ')'. */ 2230 ts->kind = (int) mpz_get_si (e->value.integer); 2231 if (gfc_validate_kind (ts->type, ts->kind , true) == -1) 2232 { 2233 gfc_error ("Invalid type-spec at %C"); 2234 return MATCH_ERROR; 2235 } 2236 2237 gfc_free_expr (e); 2238 2239 return MATCH_YES; 2240 } 2241 } 2242 2243 ohno: 2244 2245 /* If a type is not matched, simply return MATCH_NO. */ 2246 gfc_current_locus = old_locus; 2247 return MATCH_NO; 2248 2249 kind_selector: 2250 2251 gfc_gobble_whitespace (); 2252 2253 /* This prevents INTEGER*4, etc. */ 2254 if (gfc_peek_ascii_char () == '*') 2255 { 2256 gfc_error ("Invalid type-spec at %C"); 2257 return MATCH_ERROR; 2258 } 2259 2260 m = gfc_match_kind_spec (ts, false); 2261 2262 /* No kind specifier found. */ 2263 if (m == MATCH_NO) 2264 m = MATCH_YES; 2265 2266 return m; 2267 } 2268 2269 2270 /******************** FORALL subroutines ********************/ 2271 2272 /* Free a list of FORALL iterators. */ 2273 2274 void 2275 gfc_free_forall_iterator (gfc_forall_iterator *iter) 2276 { 2277 gfc_forall_iterator *next; 2278 2279 while (iter) 2280 { 2281 next = iter->next; 2282 gfc_free_expr (iter->var); 2283 gfc_free_expr (iter->start); 2284 gfc_free_expr (iter->end); 2285 gfc_free_expr (iter->stride); 2286 free (iter); 2287 iter = next; 2288 } 2289 } 2290 2291 2292 /* Match an iterator as part of a FORALL statement. The format is: 2293 2294 <var> = <start>:<end>[:<stride>] 2295 2296 On MATCH_NO, the caller tests for the possibility that there is a 2297 scalar mask expression. */ 2298 2299 static match 2300 match_forall_iterator (gfc_forall_iterator **result) 2301 { 2302 gfc_forall_iterator *iter; 2303 locus where; 2304 match m; 2305 2306 where = gfc_current_locus; 2307 iter = XCNEW (gfc_forall_iterator); 2308 2309 m = gfc_match_expr (&iter->var); 2310 if (m != MATCH_YES) 2311 goto cleanup; 2312 2313 if (gfc_match_char ('=') != MATCH_YES 2314 || iter->var->expr_type != EXPR_VARIABLE) 2315 { 2316 m = MATCH_NO; 2317 goto cleanup; 2318 } 2319 2320 m = gfc_match_expr (&iter->start); 2321 if (m != MATCH_YES) 2322 goto cleanup; 2323 2324 if (gfc_match_char (':') != MATCH_YES) 2325 goto syntax; 2326 2327 m = gfc_match_expr (&iter->end); 2328 if (m == MATCH_NO) 2329 goto syntax; 2330 if (m == MATCH_ERROR) 2331 goto cleanup; 2332 2333 if (gfc_match_char (':') == MATCH_NO) 2334 iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 2335 else 2336 { 2337 m = gfc_match_expr (&iter->stride); 2338 if (m == MATCH_NO) 2339 goto syntax; 2340 if (m == MATCH_ERROR) 2341 goto cleanup; 2342 } 2343 2344 /* Mark the iteration variable's symbol as used as a FORALL index. */ 2345 iter->var->symtree->n.sym->forall_index = true; 2346 2347 *result = iter; 2348 return MATCH_YES; 2349 2350 syntax: 2351 gfc_error ("Syntax error in FORALL iterator at %C"); 2352 m = MATCH_ERROR; 2353 2354 cleanup: 2355 2356 gfc_current_locus = where; 2357 gfc_free_forall_iterator (iter); 2358 return m; 2359 } 2360 2361 2362 /* Match the header of a FORALL statement. */ 2363 2364 static match 2365 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) 2366 { 2367 gfc_forall_iterator *head, *tail, *new_iter; 2368 gfc_expr *msk; 2369 match m; 2370 2371 gfc_gobble_whitespace (); 2372 2373 head = tail = NULL; 2374 msk = NULL; 2375 2376 if (gfc_match_char ('(') != MATCH_YES) 2377 return MATCH_NO; 2378 2379 m = match_forall_iterator (&new_iter); 2380 if (m == MATCH_ERROR) 2381 goto cleanup; 2382 if (m == MATCH_NO) 2383 goto syntax; 2384 2385 head = tail = new_iter; 2386 2387 for (;;) 2388 { 2389 if (gfc_match_char (',') != MATCH_YES) 2390 break; 2391 2392 m = match_forall_iterator (&new_iter); 2393 if (m == MATCH_ERROR) 2394 goto cleanup; 2395 2396 if (m == MATCH_YES) 2397 { 2398 tail->next = new_iter; 2399 tail = new_iter; 2400 continue; 2401 } 2402 2403 /* Have to have a mask expression. */ 2404 2405 m = gfc_match_expr (&msk); 2406 if (m == MATCH_NO) 2407 goto syntax; 2408 if (m == MATCH_ERROR) 2409 goto cleanup; 2410 2411 break; 2412 } 2413 2414 if (gfc_match_char (')') == MATCH_NO) 2415 goto syntax; 2416 2417 *phead = head; 2418 *mask = msk; 2419 return MATCH_YES; 2420 2421 syntax: 2422 gfc_syntax_error (ST_FORALL); 2423 2424 cleanup: 2425 gfc_free_expr (msk); 2426 gfc_free_forall_iterator (head); 2427 2428 return MATCH_ERROR; 2429 } 2430 2431 /* Match the rest of a simple FORALL statement that follows an 2432 IF statement. */ 2433 2434 static match 2435 match_simple_forall (void) 2436 { 2437 gfc_forall_iterator *head; 2438 gfc_expr *mask; 2439 gfc_code *c; 2440 match m; 2441 2442 mask = NULL; 2443 head = NULL; 2444 c = NULL; 2445 2446 m = match_forall_header (&head, &mask); 2447 2448 if (m == MATCH_NO) 2449 goto syntax; 2450 if (m != MATCH_YES) 2451 goto cleanup; 2452 2453 m = gfc_match_assignment (); 2454 2455 if (m == MATCH_ERROR) 2456 goto cleanup; 2457 if (m == MATCH_NO) 2458 { 2459 m = gfc_match_pointer_assignment (); 2460 if (m == MATCH_ERROR) 2461 goto cleanup; 2462 if (m == MATCH_NO) 2463 goto syntax; 2464 } 2465 2466 c = XCNEW (gfc_code); 2467 *c = new_st; 2468 c->loc = gfc_current_locus; 2469 2470 if (gfc_match_eos () != MATCH_YES) 2471 goto syntax; 2472 2473 gfc_clear_new_st (); 2474 new_st.op = EXEC_FORALL; 2475 new_st.expr1 = mask; 2476 new_st.ext.forall_iterator = head; 2477 new_st.block = gfc_get_code (EXEC_FORALL); 2478 new_st.block->next = c; 2479 2480 return MATCH_YES; 2481 2482 syntax: 2483 gfc_syntax_error (ST_FORALL); 2484 2485 cleanup: 2486 gfc_free_forall_iterator (head); 2487 gfc_free_expr (mask); 2488 2489 return MATCH_ERROR; 2490 } 2491 2492 2493 /* Match a FORALL statement. */ 2494 2495 match 2496 gfc_match_forall (gfc_statement *st) 2497 { 2498 gfc_forall_iterator *head; 2499 gfc_expr *mask; 2500 gfc_code *c; 2501 match m0, m; 2502 2503 head = NULL; 2504 mask = NULL; 2505 c = NULL; 2506 2507 m0 = gfc_match_label (); 2508 if (m0 == MATCH_ERROR) 2509 return MATCH_ERROR; 2510 2511 m = gfc_match (" forall"); 2512 if (m != MATCH_YES) 2513 return m; 2514 2515 m = match_forall_header (&head, &mask); 2516 if (m == MATCH_ERROR) 2517 goto cleanup; 2518 if (m == MATCH_NO) 2519 goto syntax; 2520 2521 if (gfc_match_eos () == MATCH_YES) 2522 { 2523 *st = ST_FORALL_BLOCK; 2524 new_st.op = EXEC_FORALL; 2525 new_st.expr1 = mask; 2526 new_st.ext.forall_iterator = head; 2527 return MATCH_YES; 2528 } 2529 2530 m = gfc_match_assignment (); 2531 if (m == MATCH_ERROR) 2532 goto cleanup; 2533 if (m == MATCH_NO) 2534 { 2535 m = gfc_match_pointer_assignment (); 2536 if (m == MATCH_ERROR) 2537 goto cleanup; 2538 if (m == MATCH_NO) 2539 goto syntax; 2540 } 2541 2542 c = XCNEW (gfc_code); 2543 *c = new_st; 2544 c->loc = gfc_current_locus; 2545 2546 gfc_clear_new_st (); 2547 new_st.op = EXEC_FORALL; 2548 new_st.expr1 = mask; 2549 new_st.ext.forall_iterator = head; 2550 new_st.block = gfc_get_code (EXEC_FORALL); 2551 new_st.block->next = c; 2552 2553 *st = ST_FORALL; 2554 return MATCH_YES; 2555 2556 syntax: 2557 gfc_syntax_error (ST_FORALL); 2558 2559 cleanup: 2560 gfc_free_forall_iterator (head); 2561 gfc_free_expr (mask); 2562 gfc_free_statements (c); 2563 return MATCH_NO; 2564 } 2565 2566 2567 /* Match a DO statement. */ 2568 2569 match 2570 gfc_match_do (void) 2571 { 2572 gfc_iterator iter, *ip; 2573 locus old_loc; 2574 gfc_st_label *label; 2575 match m; 2576 2577 old_loc = gfc_current_locus; 2578 2579 memset (&iter, '\0', sizeof (gfc_iterator)); 2580 label = NULL; 2581 2582 m = gfc_match_label (); 2583 if (m == MATCH_ERROR) 2584 return m; 2585 2586 if (gfc_match (" do") != MATCH_YES) 2587 return MATCH_NO; 2588 2589 m = gfc_match_st_label (&label); 2590 if (m == MATCH_ERROR) 2591 goto cleanup; 2592 2593 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ 2594 2595 if (gfc_match_eos () == MATCH_YES) 2596 { 2597 iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); 2598 new_st.op = EXEC_DO_WHILE; 2599 goto done; 2600 } 2601 2602 /* Match an optional comma, if no comma is found, a space is obligatory. */ 2603 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) 2604 return MATCH_NO; 2605 2606 /* Check for balanced parens. */ 2607 2608 if (gfc_match_parens () == MATCH_ERROR) 2609 return MATCH_ERROR; 2610 2611 if (gfc_match (" concurrent") == MATCH_YES) 2612 { 2613 gfc_forall_iterator *head; 2614 gfc_expr *mask; 2615 2616 if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C")) 2617 return MATCH_ERROR; 2618 2619 2620 mask = NULL; 2621 head = NULL; 2622 m = match_forall_header (&head, &mask); 2623 2624 if (m == MATCH_NO) 2625 return m; 2626 if (m == MATCH_ERROR) 2627 goto concurr_cleanup; 2628 2629 if (gfc_match_eos () != MATCH_YES) 2630 goto concurr_cleanup; 2631 2632 if (label != NULL 2633 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) 2634 goto concurr_cleanup; 2635 2636 new_st.label1 = label; 2637 new_st.op = EXEC_DO_CONCURRENT; 2638 new_st.expr1 = mask; 2639 new_st.ext.forall_iterator = head; 2640 2641 return MATCH_YES; 2642 2643 concurr_cleanup: 2644 gfc_syntax_error (ST_DO); 2645 gfc_free_expr (mask); 2646 gfc_free_forall_iterator (head); 2647 return MATCH_ERROR; 2648 } 2649 2650 /* See if we have a DO WHILE. */ 2651 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) 2652 { 2653 new_st.op = EXEC_DO_WHILE; 2654 goto done; 2655 } 2656 2657 /* The abortive DO WHILE may have done something to the symbol 2658 table, so we start over. */ 2659 gfc_undo_symbols (); 2660 gfc_current_locus = old_loc; 2661 2662 gfc_match_label (); /* This won't error. */ 2663 gfc_match (" do "); /* This will work. */ 2664 2665 gfc_match_st_label (&label); /* Can't error out. */ 2666 gfc_match_char (','); /* Optional comma. */ 2667 2668 m = gfc_match_iterator (&iter, 0); 2669 if (m == MATCH_NO) 2670 return MATCH_NO; 2671 if (m == MATCH_ERROR) 2672 goto cleanup; 2673 2674 iter.var->symtree->n.sym->attr.implied_index = 0; 2675 gfc_check_do_variable (iter.var->symtree); 2676 2677 if (gfc_match_eos () != MATCH_YES) 2678 { 2679 gfc_syntax_error (ST_DO); 2680 goto cleanup; 2681 } 2682 2683 new_st.op = EXEC_DO; 2684 2685 done: 2686 if (label != NULL 2687 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) 2688 goto cleanup; 2689 2690 new_st.label1 = label; 2691 2692 if (new_st.op == EXEC_DO_WHILE) 2693 new_st.expr1 = iter.end; 2694 else 2695 { 2696 new_st.ext.iterator = ip = gfc_get_iterator (); 2697 *ip = iter; 2698 } 2699 2700 return MATCH_YES; 2701 2702 cleanup: 2703 gfc_free_iterator (&iter, 0); 2704 2705 return MATCH_ERROR; 2706 } 2707 2708 2709 /* Match an EXIT or CYCLE statement. */ 2710 2711 static match 2712 match_exit_cycle (gfc_statement st, gfc_exec_op op) 2713 { 2714 gfc_state_data *p, *o; 2715 gfc_symbol *sym; 2716 match m; 2717 int cnt; 2718 2719 if (gfc_match_eos () == MATCH_YES) 2720 sym = NULL; 2721 else 2722 { 2723 char name[GFC_MAX_SYMBOL_LEN + 1]; 2724 gfc_symtree* stree; 2725 2726 m = gfc_match ("% %n%t", name); 2727 if (m == MATCH_ERROR) 2728 return MATCH_ERROR; 2729 if (m == MATCH_NO) 2730 { 2731 gfc_syntax_error (st); 2732 return MATCH_ERROR; 2733 } 2734 2735 /* Find the corresponding symbol. If there's a BLOCK statement 2736 between here and the label, it is not in gfc_current_ns but a parent 2737 namespace! */ 2738 stree = gfc_find_symtree_in_proc (name, gfc_current_ns); 2739 if (!stree) 2740 { 2741 gfc_error ("Name %qs in %s statement at %C is unknown", 2742 name, gfc_ascii_statement (st)); 2743 return MATCH_ERROR; 2744 } 2745 2746 sym = stree->n.sym; 2747 if (sym->attr.flavor != FL_LABEL) 2748 { 2749 gfc_error ("Name %qs in %s statement at %C is not a construct name", 2750 name, gfc_ascii_statement (st)); 2751 return MATCH_ERROR; 2752 } 2753 } 2754 2755 /* Find the loop specified by the label (or lack of a label). */ 2756 for (o = NULL, p = gfc_state_stack; p; p = p->previous) 2757 if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) 2758 o = p; 2759 else if (p->state == COMP_CRITICAL) 2760 { 2761 gfc_error("%s statement at %C leaves CRITICAL construct", 2762 gfc_ascii_statement (st)); 2763 return MATCH_ERROR; 2764 } 2765 else if (p->state == COMP_DO_CONCURRENT 2766 && (op == EXEC_EXIT || (sym && sym != p->sym))) 2767 { 2768 /* F2008, C821 & C845. */ 2769 gfc_error("%s statement at %C leaves DO CONCURRENT construct", 2770 gfc_ascii_statement (st)); 2771 return MATCH_ERROR; 2772 } 2773 else if ((sym && sym == p->sym) 2774 || (!sym && (p->state == COMP_DO 2775 || p->state == COMP_DO_CONCURRENT))) 2776 break; 2777 2778 if (p == NULL) 2779 { 2780 if (sym == NULL) 2781 gfc_error ("%s statement at %C is not within a construct", 2782 gfc_ascii_statement (st)); 2783 else 2784 gfc_error ("%s statement at %C is not within construct %qs", 2785 gfc_ascii_statement (st), sym->name); 2786 2787 return MATCH_ERROR; 2788 } 2789 2790 /* Special checks for EXIT from non-loop constructs. */ 2791 switch (p->state) 2792 { 2793 case COMP_DO: 2794 case COMP_DO_CONCURRENT: 2795 break; 2796 2797 case COMP_CRITICAL: 2798 /* This is already handled above. */ 2799 gcc_unreachable (); 2800 2801 case COMP_ASSOCIATE: 2802 case COMP_BLOCK: 2803 case COMP_IF: 2804 case COMP_SELECT: 2805 case COMP_SELECT_TYPE: 2806 gcc_assert (sym); 2807 if (op == EXEC_CYCLE) 2808 { 2809 gfc_error ("CYCLE statement at %C is not applicable to non-loop" 2810 " construct %qs", sym->name); 2811 return MATCH_ERROR; 2812 } 2813 gcc_assert (op == EXEC_EXIT); 2814 if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no" 2815 " do-construct-name at %C")) 2816 return MATCH_ERROR; 2817 break; 2818 2819 default: 2820 gfc_error ("%s statement at %C is not applicable to construct %qs", 2821 gfc_ascii_statement (st), sym->name); 2822 return MATCH_ERROR; 2823 } 2824 2825 if (o != NULL) 2826 { 2827 gfc_error (is_oacc (p) 2828 ? G_("%s statement at %C leaving OpenACC structured block") 2829 : G_("%s statement at %C leaving OpenMP structured block"), 2830 gfc_ascii_statement (st)); 2831 return MATCH_ERROR; 2832 } 2833 2834 for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) 2835 o = o->previous; 2836 if (cnt > 0 2837 && o != NULL 2838 && o->state == COMP_OMP_STRUCTURED_BLOCK 2839 && (o->head->op == EXEC_OACC_LOOP 2840 || o->head->op == EXEC_OACC_PARALLEL_LOOP)) 2841 { 2842 int collapse = 1; 2843 gcc_assert (o->head->next != NULL 2844 && (o->head->next->op == EXEC_DO 2845 || o->head->next->op == EXEC_DO_WHILE) 2846 && o->previous != NULL 2847 && o->previous->tail->op == o->head->op); 2848 if (o->previous->tail->ext.omp_clauses != NULL 2849 && o->previous->tail->ext.omp_clauses->collapse > 1) 2850 collapse = o->previous->tail->ext.omp_clauses->collapse; 2851 if (st == ST_EXIT && cnt <= collapse) 2852 { 2853 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop"); 2854 return MATCH_ERROR; 2855 } 2856 if (st == ST_CYCLE && cnt < collapse) 2857 { 2858 gfc_error ("CYCLE statement at %C to non-innermost collapsed" 2859 " !$ACC LOOP loop"); 2860 return MATCH_ERROR; 2861 } 2862 } 2863 if (cnt > 0 2864 && o != NULL 2865 && (o->state == COMP_OMP_STRUCTURED_BLOCK) 2866 && (o->head->op == EXEC_OMP_DO 2867 || o->head->op == EXEC_OMP_PARALLEL_DO 2868 || o->head->op == EXEC_OMP_SIMD 2869 || o->head->op == EXEC_OMP_DO_SIMD 2870 || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD)) 2871 { 2872 int count = 1; 2873 gcc_assert (o->head->next != NULL 2874 && (o->head->next->op == EXEC_DO 2875 || o->head->next->op == EXEC_DO_WHILE) 2876 && o->previous != NULL 2877 && o->previous->tail->op == o->head->op); 2878 if (o->previous->tail->ext.omp_clauses != NULL) 2879 { 2880 if (o->previous->tail->ext.omp_clauses->collapse > 1) 2881 count = o->previous->tail->ext.omp_clauses->collapse; 2882 if (o->previous->tail->ext.omp_clauses->orderedc) 2883 count = o->previous->tail->ext.omp_clauses->orderedc; 2884 } 2885 if (st == ST_EXIT && cnt <= count) 2886 { 2887 gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); 2888 return MATCH_ERROR; 2889 } 2890 if (st == ST_CYCLE && cnt < count) 2891 { 2892 gfc_error ("CYCLE statement at %C to non-innermost collapsed" 2893 " !$OMP DO loop"); 2894 return MATCH_ERROR; 2895 } 2896 } 2897 2898 /* Save the first statement in the construct - needed by the backend. */ 2899 new_st.ext.which_construct = p->construct; 2900 2901 new_st.op = op; 2902 2903 return MATCH_YES; 2904 } 2905 2906 2907 /* Match the EXIT statement. */ 2908 2909 match 2910 gfc_match_exit (void) 2911 { 2912 return match_exit_cycle (ST_EXIT, EXEC_EXIT); 2913 } 2914 2915 2916 /* Match the CYCLE statement. */ 2917 2918 match 2919 gfc_match_cycle (void) 2920 { 2921 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); 2922 } 2923 2924 2925 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The 2926 requirements for a stop-code differ in the standards. 2927 2928 Fortran 95 has 2929 2930 R840 stop-stmt is STOP [ stop-code ] 2931 R841 stop-code is scalar-char-constant 2932 or digit [ digit [ digit [ digit [ digit ] ] ] ] 2933 2934 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850. 2935 Fortran 2008 has 2936 2937 R855 stop-stmt is STOP [ stop-code ] 2938 R856 allstop-stmt is ALL STOP [ stop-code ] 2939 R857 stop-code is scalar-default-char-constant-expr 2940 or scalar-int-constant-expr 2941 2942 For free-form source code, all standards contain a statement of the form: 2943 2944 A blank shall be used to separate names, constants, or labels from 2945 adjacent keywords, names, constants, or labels. 2946 2947 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003, 2948 2949 STOP123 2950 2951 is valid, but it is invalid Fortran 2008. */ 2952 2953 static match 2954 gfc_match_stopcode (gfc_statement st) 2955 { 2956 gfc_expr *e = NULL; 2957 match m; 2958 bool f95, f03, f08; 2959 2960 /* Set f95 for -std=f95. */ 2961 f95 = (gfc_option.allow_std == GFC_STD_OPT_F95); 2962 2963 /* Set f03 for -std=f2003. */ 2964 f03 = (gfc_option.allow_std == GFC_STD_OPT_F03); 2965 2966 /* Set f08 for -std=f2008. */ 2967 f08 = (gfc_option.allow_std == GFC_STD_OPT_F08); 2968 2969 /* Look for a blank between STOP and the stop-code for F2008 or later. */ 2970 if (gfc_current_form != FORM_FIXED && !(f95 || f03)) 2971 { 2972 char c = gfc_peek_ascii_char (); 2973 2974 /* Look for end-of-statement. There is no stop-code. */ 2975 if (c == '\n' || c == '!' || c == ';') 2976 goto done; 2977 2978 if (c != ' ') 2979 { 2980 gfc_error ("Blank required in %s statement near %C", 2981 gfc_ascii_statement (st)); 2982 return MATCH_ERROR; 2983 } 2984 } 2985 2986 if (gfc_match_eos () != MATCH_YES) 2987 { 2988 int stopcode; 2989 locus old_locus; 2990 2991 /* First look for the F95 or F2003 digit [...] construct. */ 2992 old_locus = gfc_current_locus; 2993 m = gfc_match_small_int (&stopcode); 2994 if (m == MATCH_YES && (f95 || f03)) 2995 { 2996 if (stopcode < 0) 2997 { 2998 gfc_error ("STOP code at %C cannot be negative"); 2999 return MATCH_ERROR; 3000 } 3001 3002 if (stopcode > 99999) 3003 { 3004 gfc_error ("STOP code at %C contains too many digits"); 3005 return MATCH_ERROR; 3006 } 3007 } 3008 3009 /* Reset the locus and now load gfc_expr. */ 3010 gfc_current_locus = old_locus; 3011 m = gfc_match_expr (&e); 3012 if (m == MATCH_ERROR) 3013 goto cleanup; 3014 if (m == MATCH_NO) 3015 goto syntax; 3016 3017 if (gfc_match_eos () != MATCH_YES) 3018 goto syntax; 3019 } 3020 3021 if (gfc_pure (NULL)) 3022 { 3023 if (st == ST_ERROR_STOP) 3024 { 3025 if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE " 3026 "procedure", gfc_ascii_statement (st))) 3027 goto cleanup; 3028 } 3029 else 3030 { 3031 gfc_error ("%s statement not allowed in PURE procedure at %C", 3032 gfc_ascii_statement (st)); 3033 goto cleanup; 3034 } 3035 } 3036 3037 gfc_unset_implicit_pure (NULL); 3038 3039 if (st == ST_STOP && gfc_find_state (COMP_CRITICAL)) 3040 { 3041 gfc_error ("Image control statement STOP at %C in CRITICAL block"); 3042 goto cleanup; 3043 } 3044 if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT)) 3045 { 3046 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block"); 3047 goto cleanup; 3048 } 3049 3050 if (e != NULL) 3051 { 3052 gfc_simplify_expr (e, 0); 3053 3054 /* Test for F95 and F2003 style STOP stop-code. */ 3055 if (e->expr_type != EXPR_CONSTANT && (f95 || f03)) 3056 { 3057 gfc_error ("STOP code at %L must be a scalar CHARACTER constant " 3058 "or digit[digit[digit[digit[digit]]]]", &e->where); 3059 goto cleanup; 3060 } 3061 3062 /* Use the machinery for an initialization expression to reduce the 3063 stop-code to a constant. */ 3064 gfc_init_expr_flag = true; 3065 gfc_reduce_init_expr (e); 3066 gfc_init_expr_flag = false; 3067 3068 /* Test for F2008 style STOP stop-code. */ 3069 if (e->expr_type != EXPR_CONSTANT && f08) 3070 { 3071 gfc_error ("STOP code at %L must be a scalar default CHARACTER or " 3072 "INTEGER constant expression", &e->where); 3073 goto cleanup; 3074 } 3075 3076 if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) 3077 { 3078 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", 3079 &e->where); 3080 goto cleanup; 3081 } 3082 3083 if (e->rank != 0) 3084 { 3085 gfc_error ("STOP code at %L must be scalar", &e->where); 3086 goto cleanup; 3087 } 3088 3089 if (e->ts.type == BT_CHARACTER 3090 && e->ts.kind != gfc_default_character_kind) 3091 { 3092 gfc_error ("STOP code at %L must be default character KIND=%d", 3093 &e->where, (int) gfc_default_character_kind); 3094 goto cleanup; 3095 } 3096 3097 if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind) 3098 { 3099 gfc_error ("STOP code at %L must be default integer KIND=%d", 3100 &e->where, (int) gfc_default_integer_kind); 3101 goto cleanup; 3102 } 3103 } 3104 3105 done: 3106 3107 switch (st) 3108 { 3109 case ST_STOP: 3110 new_st.op = EXEC_STOP; 3111 break; 3112 case ST_ERROR_STOP: 3113 new_st.op = EXEC_ERROR_STOP; 3114 break; 3115 case ST_PAUSE: 3116 new_st.op = EXEC_PAUSE; 3117 break; 3118 default: 3119 gcc_unreachable (); 3120 } 3121 3122 new_st.expr1 = e; 3123 new_st.ext.stop_code = -1; 3124 3125 return MATCH_YES; 3126 3127 syntax: 3128 gfc_syntax_error (st); 3129 3130 cleanup: 3131 3132 gfc_free_expr (e); 3133 return MATCH_ERROR; 3134 } 3135 3136 3137 /* Match the (deprecated) PAUSE statement. */ 3138 3139 match 3140 gfc_match_pause (void) 3141 { 3142 match m; 3143 3144 m = gfc_match_stopcode (ST_PAUSE); 3145 if (m == MATCH_YES) 3146 { 3147 if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C")) 3148 m = MATCH_ERROR; 3149 } 3150 return m; 3151 } 3152 3153 3154 /* Match the STOP statement. */ 3155 3156 match 3157 gfc_match_stop (void) 3158 { 3159 return gfc_match_stopcode (ST_STOP); 3160 } 3161 3162 3163 /* Match the ERROR STOP statement. */ 3164 3165 match 3166 gfc_match_error_stop (void) 3167 { 3168 if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C")) 3169 return MATCH_ERROR; 3170 3171 return gfc_match_stopcode (ST_ERROR_STOP); 3172 } 3173 3174 /* Match EVENT POST/WAIT statement. Syntax: 3175 EVENT POST ( event-variable [, sync-stat-list] ) 3176 EVENT WAIT ( event-variable [, wait-spec-list] ) 3177 with 3178 wait-spec-list is sync-stat-list or until-spec 3179 until-spec is UNTIL_COUNT = scalar-int-expr 3180 sync-stat is STAT= or ERRMSG=. */ 3181 3182 static match 3183 event_statement (gfc_statement st) 3184 { 3185 match m; 3186 gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg; 3187 bool saw_until_count, saw_stat, saw_errmsg; 3188 3189 tmp = eventvar = until_count = stat = errmsg = NULL; 3190 saw_until_count = saw_stat = saw_errmsg = false; 3191 3192 if (gfc_pure (NULL)) 3193 { 3194 gfc_error ("Image control statement EVENT %s at %C in PURE procedure", 3195 st == ST_EVENT_POST ? "POST" : "WAIT"); 3196 return MATCH_ERROR; 3197 } 3198 3199 gfc_unset_implicit_pure (NULL); 3200 3201 if (flag_coarray == GFC_FCOARRAY_NONE) 3202 { 3203 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 3204 return MATCH_ERROR; 3205 } 3206 3207 if (gfc_find_state (COMP_CRITICAL)) 3208 { 3209 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block", 3210 st == ST_EVENT_POST ? "POST" : "WAIT"); 3211 return MATCH_ERROR; 3212 } 3213 3214 if (gfc_find_state (COMP_DO_CONCURRENT)) 3215 { 3216 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT " 3217 "block", st == ST_EVENT_POST ? "POST" : "WAIT"); 3218 return MATCH_ERROR; 3219 } 3220 3221 if (gfc_match_char ('(') != MATCH_YES) 3222 goto syntax; 3223 3224 if (gfc_match ("%e", &eventvar) != MATCH_YES) 3225 goto syntax; 3226 m = gfc_match_char (','); 3227 if (m == MATCH_ERROR) 3228 goto syntax; 3229 if (m == MATCH_NO) 3230 { 3231 m = gfc_match_char (')'); 3232 if (m == MATCH_YES) 3233 goto done; 3234 goto syntax; 3235 } 3236 3237 for (;;) 3238 { 3239 m = gfc_match (" stat = %v", &tmp); 3240 if (m == MATCH_ERROR) 3241 goto syntax; 3242 if (m == MATCH_YES) 3243 { 3244 if (saw_stat) 3245 { 3246 gfc_error ("Redundant STAT tag found at %L", &tmp->where); 3247 goto cleanup; 3248 } 3249 stat = tmp; 3250 saw_stat = true; 3251 3252 m = gfc_match_char (','); 3253 if (m == MATCH_YES) 3254 continue; 3255 3256 tmp = NULL; 3257 break; 3258 } 3259 3260 m = gfc_match (" errmsg = %v", &tmp); 3261 if (m == MATCH_ERROR) 3262 goto syntax; 3263 if (m == MATCH_YES) 3264 { 3265 if (saw_errmsg) 3266 { 3267 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); 3268 goto cleanup; 3269 } 3270 errmsg = tmp; 3271 saw_errmsg = true; 3272 3273 m = gfc_match_char (','); 3274 if (m == MATCH_YES) 3275 continue; 3276 3277 tmp = NULL; 3278 break; 3279 } 3280 3281 m = gfc_match (" until_count = %e", &tmp); 3282 if (m == MATCH_ERROR || st == ST_EVENT_POST) 3283 goto syntax; 3284 if (m == MATCH_YES) 3285 { 3286 if (saw_until_count) 3287 { 3288 gfc_error ("Redundant UNTIL_COUNT tag found at %L", 3289 &tmp->where); 3290 goto cleanup; 3291 } 3292 until_count = tmp; 3293 saw_until_count = true; 3294 3295 m = gfc_match_char (','); 3296 if (m == MATCH_YES) 3297 continue; 3298 3299 tmp = NULL; 3300 break; 3301 } 3302 3303 break; 3304 } 3305 3306 if (m == MATCH_ERROR) 3307 goto syntax; 3308 3309 if (gfc_match (" )%t") != MATCH_YES) 3310 goto syntax; 3311 3312 done: 3313 switch (st) 3314 { 3315 case ST_EVENT_POST: 3316 new_st.op = EXEC_EVENT_POST; 3317 break; 3318 case ST_EVENT_WAIT: 3319 new_st.op = EXEC_EVENT_WAIT; 3320 break; 3321 default: 3322 gcc_unreachable (); 3323 } 3324 3325 new_st.expr1 = eventvar; 3326 new_st.expr2 = stat; 3327 new_st.expr3 = errmsg; 3328 new_st.expr4 = until_count; 3329 3330 return MATCH_YES; 3331 3332 syntax: 3333 gfc_syntax_error (st); 3334 3335 cleanup: 3336 if (until_count != tmp) 3337 gfc_free_expr (until_count); 3338 if (errmsg != tmp) 3339 gfc_free_expr (errmsg); 3340 if (stat != tmp) 3341 gfc_free_expr (stat); 3342 3343 gfc_free_expr (tmp); 3344 gfc_free_expr (eventvar); 3345 3346 return MATCH_ERROR; 3347 3348 } 3349 3350 3351 match 3352 gfc_match_event_post (void) 3353 { 3354 if (!gfc_notify_std (GFC_STD_F2018, "EVENT POST statement at %C")) 3355 return MATCH_ERROR; 3356 3357 return event_statement (ST_EVENT_POST); 3358 } 3359 3360 3361 match 3362 gfc_match_event_wait (void) 3363 { 3364 if (!gfc_notify_std (GFC_STD_F2018, "EVENT WAIT statement at %C")) 3365 return MATCH_ERROR; 3366 3367 return event_statement (ST_EVENT_WAIT); 3368 } 3369 3370 3371 /* Match a FAIL IMAGE statement. */ 3372 3373 match 3374 gfc_match_fail_image (void) 3375 { 3376 if (!gfc_notify_std (GFC_STD_F2018, "FAIL IMAGE statement at %C")) 3377 return MATCH_ERROR; 3378 3379 if (gfc_match_char ('(') == MATCH_YES) 3380 goto syntax; 3381 3382 new_st.op = EXEC_FAIL_IMAGE; 3383 3384 return MATCH_YES; 3385 3386 syntax: 3387 gfc_syntax_error (ST_FAIL_IMAGE); 3388 3389 return MATCH_ERROR; 3390 } 3391 3392 /* Match a FORM TEAM statement. */ 3393 3394 match 3395 gfc_match_form_team (void) 3396 { 3397 match m; 3398 gfc_expr *teamid,*team; 3399 3400 if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C")) 3401 return MATCH_ERROR; 3402 3403 if (gfc_match_char ('(') == MATCH_NO) 3404 goto syntax; 3405 3406 new_st.op = EXEC_FORM_TEAM; 3407 3408 if (gfc_match ("%e", &teamid) != MATCH_YES) 3409 goto syntax; 3410 m = gfc_match_char (','); 3411 if (m == MATCH_ERROR) 3412 goto syntax; 3413 if (gfc_match ("%e", &team) != MATCH_YES) 3414 goto syntax; 3415 3416 m = gfc_match_char (')'); 3417 if (m == MATCH_NO) 3418 goto syntax; 3419 3420 new_st.expr1 = teamid; 3421 new_st.expr2 = team; 3422 3423 return MATCH_YES; 3424 3425 syntax: 3426 gfc_syntax_error (ST_FORM_TEAM); 3427 3428 return MATCH_ERROR; 3429 } 3430 3431 /* Match a CHANGE TEAM statement. */ 3432 3433 match 3434 gfc_match_change_team (void) 3435 { 3436 match m; 3437 gfc_expr *team; 3438 3439 if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C")) 3440 return MATCH_ERROR; 3441 3442 if (gfc_match_char ('(') == MATCH_NO) 3443 goto syntax; 3444 3445 new_st.op = EXEC_CHANGE_TEAM; 3446 3447 if (gfc_match ("%e", &team) != MATCH_YES) 3448 goto syntax; 3449 3450 m = gfc_match_char (')'); 3451 if (m == MATCH_NO) 3452 goto syntax; 3453 3454 new_st.expr1 = team; 3455 3456 return MATCH_YES; 3457 3458 syntax: 3459 gfc_syntax_error (ST_CHANGE_TEAM); 3460 3461 return MATCH_ERROR; 3462 } 3463 3464 /* Match a END TEAM statement. */ 3465 3466 match 3467 gfc_match_end_team (void) 3468 { 3469 if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C")) 3470 return MATCH_ERROR; 3471 3472 if (gfc_match_char ('(') == MATCH_YES) 3473 goto syntax; 3474 3475 new_st.op = EXEC_END_TEAM; 3476 3477 return MATCH_YES; 3478 3479 syntax: 3480 gfc_syntax_error (ST_END_TEAM); 3481 3482 return MATCH_ERROR; 3483 } 3484 3485 /* Match a SYNC TEAM statement. */ 3486 3487 match 3488 gfc_match_sync_team (void) 3489 { 3490 match m; 3491 gfc_expr *team; 3492 3493 if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C")) 3494 return MATCH_ERROR; 3495 3496 if (gfc_match_char ('(') == MATCH_NO) 3497 goto syntax; 3498 3499 new_st.op = EXEC_SYNC_TEAM; 3500 3501 if (gfc_match ("%e", &team) != MATCH_YES) 3502 goto syntax; 3503 3504 m = gfc_match_char (')'); 3505 if (m == MATCH_NO) 3506 goto syntax; 3507 3508 new_st.expr1 = team; 3509 3510 return MATCH_YES; 3511 3512 syntax: 3513 gfc_syntax_error (ST_SYNC_TEAM); 3514 3515 return MATCH_ERROR; 3516 } 3517 3518 /* Match LOCK/UNLOCK statement. Syntax: 3519 LOCK ( lock-variable [ , lock-stat-list ] ) 3520 UNLOCK ( lock-variable [ , sync-stat-list ] ) 3521 where lock-stat is ACQUIRED_LOCK or sync-stat 3522 and sync-stat is STAT= or ERRMSG=. */ 3523 3524 static match 3525 lock_unlock_statement (gfc_statement st) 3526 { 3527 match m; 3528 gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg; 3529 bool saw_acq_lock, saw_stat, saw_errmsg; 3530 3531 tmp = lockvar = acq_lock = stat = errmsg = NULL; 3532 saw_acq_lock = saw_stat = saw_errmsg = false; 3533 3534 if (gfc_pure (NULL)) 3535 { 3536 gfc_error ("Image control statement %s at %C in PURE procedure", 3537 st == ST_LOCK ? "LOCK" : "UNLOCK"); 3538 return MATCH_ERROR; 3539 } 3540 3541 gfc_unset_implicit_pure (NULL); 3542 3543 if (flag_coarray == GFC_FCOARRAY_NONE) 3544 { 3545 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 3546 return MATCH_ERROR; 3547 } 3548 3549 if (gfc_find_state (COMP_CRITICAL)) 3550 { 3551 gfc_error ("Image control statement %s at %C in CRITICAL block", 3552 st == ST_LOCK ? "LOCK" : "UNLOCK"); 3553 return MATCH_ERROR; 3554 } 3555 3556 if (gfc_find_state (COMP_DO_CONCURRENT)) 3557 { 3558 gfc_error ("Image control statement %s at %C in DO CONCURRENT block", 3559 st == ST_LOCK ? "LOCK" : "UNLOCK"); 3560 return MATCH_ERROR; 3561 } 3562 3563 if (gfc_match_char ('(') != MATCH_YES) 3564 goto syntax; 3565 3566 if (gfc_match ("%e", &lockvar) != MATCH_YES) 3567 goto syntax; 3568 m = gfc_match_char (','); 3569 if (m == MATCH_ERROR) 3570 goto syntax; 3571 if (m == MATCH_NO) 3572 { 3573 m = gfc_match_char (')'); 3574 if (m == MATCH_YES) 3575 goto done; 3576 goto syntax; 3577 } 3578 3579 for (;;) 3580 { 3581 m = gfc_match (" stat = %v", &tmp); 3582 if (m == MATCH_ERROR) 3583 goto syntax; 3584 if (m == MATCH_YES) 3585 { 3586 if (saw_stat) 3587 { 3588 gfc_error ("Redundant STAT tag found at %L", &tmp->where); 3589 goto cleanup; 3590 } 3591 stat = tmp; 3592 saw_stat = true; 3593 3594 m = gfc_match_char (','); 3595 if (m == MATCH_YES) 3596 continue; 3597 3598 tmp = NULL; 3599 break; 3600 } 3601 3602 m = gfc_match (" errmsg = %v", &tmp); 3603 if (m == MATCH_ERROR) 3604 goto syntax; 3605 if (m == MATCH_YES) 3606 { 3607 if (saw_errmsg) 3608 { 3609 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); 3610 goto cleanup; 3611 } 3612 errmsg = tmp; 3613 saw_errmsg = true; 3614 3615 m = gfc_match_char (','); 3616 if (m == MATCH_YES) 3617 continue; 3618 3619 tmp = NULL; 3620 break; 3621 } 3622 3623 m = gfc_match (" acquired_lock = %v", &tmp); 3624 if (m == MATCH_ERROR || st == ST_UNLOCK) 3625 goto syntax; 3626 if (m == MATCH_YES) 3627 { 3628 if (saw_acq_lock) 3629 { 3630 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L", 3631 &tmp->where); 3632 goto cleanup; 3633 } 3634 acq_lock = tmp; 3635 saw_acq_lock = true; 3636 3637 m = gfc_match_char (','); 3638 if (m == MATCH_YES) 3639 continue; 3640 3641 tmp = NULL; 3642 break; 3643 } 3644 3645 break; 3646 } 3647 3648 if (m == MATCH_ERROR) 3649 goto syntax; 3650 3651 if (gfc_match (" )%t") != MATCH_YES) 3652 goto syntax; 3653 3654 done: 3655 switch (st) 3656 { 3657 case ST_LOCK: 3658 new_st.op = EXEC_LOCK; 3659 break; 3660 case ST_UNLOCK: 3661 new_st.op = EXEC_UNLOCK; 3662 break; 3663 default: 3664 gcc_unreachable (); 3665 } 3666 3667 new_st.expr1 = lockvar; 3668 new_st.expr2 = stat; 3669 new_st.expr3 = errmsg; 3670 new_st.expr4 = acq_lock; 3671 3672 return MATCH_YES; 3673 3674 syntax: 3675 gfc_syntax_error (st); 3676 3677 cleanup: 3678 if (acq_lock != tmp) 3679 gfc_free_expr (acq_lock); 3680 if (errmsg != tmp) 3681 gfc_free_expr (errmsg); 3682 if (stat != tmp) 3683 gfc_free_expr (stat); 3684 3685 gfc_free_expr (tmp); 3686 gfc_free_expr (lockvar); 3687 3688 return MATCH_ERROR; 3689 } 3690 3691 3692 match 3693 gfc_match_lock (void) 3694 { 3695 if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C")) 3696 return MATCH_ERROR; 3697 3698 return lock_unlock_statement (ST_LOCK); 3699 } 3700 3701 3702 match 3703 gfc_match_unlock (void) 3704 { 3705 if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C")) 3706 return MATCH_ERROR; 3707 3708 return lock_unlock_statement (ST_UNLOCK); 3709 } 3710 3711 3712 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: 3713 SYNC ALL [(sync-stat-list)] 3714 SYNC MEMORY [(sync-stat-list)] 3715 SYNC IMAGES (image-set [, sync-stat-list] ) 3716 with sync-stat is int-expr or *. */ 3717 3718 static match 3719 sync_statement (gfc_statement st) 3720 { 3721 match m; 3722 gfc_expr *tmp, *imageset, *stat, *errmsg; 3723 bool saw_stat, saw_errmsg; 3724 3725 tmp = imageset = stat = errmsg = NULL; 3726 saw_stat = saw_errmsg = false; 3727 3728 if (gfc_pure (NULL)) 3729 { 3730 gfc_error ("Image control statement SYNC at %C in PURE procedure"); 3731 return MATCH_ERROR; 3732 } 3733 3734 gfc_unset_implicit_pure (NULL); 3735 3736 if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C")) 3737 return MATCH_ERROR; 3738 3739 if (flag_coarray == GFC_FCOARRAY_NONE) 3740 { 3741 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " 3742 "enable"); 3743 return MATCH_ERROR; 3744 } 3745 3746 if (gfc_find_state (COMP_CRITICAL)) 3747 { 3748 gfc_error ("Image control statement SYNC at %C in CRITICAL block"); 3749 return MATCH_ERROR; 3750 } 3751 3752 if (gfc_find_state (COMP_DO_CONCURRENT)) 3753 { 3754 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block"); 3755 return MATCH_ERROR; 3756 } 3757 3758 if (gfc_match_eos () == MATCH_YES) 3759 { 3760 if (st == ST_SYNC_IMAGES) 3761 goto syntax; 3762 goto done; 3763 } 3764 3765 if (gfc_match_char ('(') != MATCH_YES) 3766 goto syntax; 3767 3768 if (st == ST_SYNC_IMAGES) 3769 { 3770 /* Denote '*' as imageset == NULL. */ 3771 m = gfc_match_char ('*'); 3772 if (m == MATCH_ERROR) 3773 goto syntax; 3774 if (m == MATCH_NO) 3775 { 3776 if (gfc_match ("%e", &imageset) != MATCH_YES) 3777 goto syntax; 3778 } 3779 m = gfc_match_char (','); 3780 if (m == MATCH_ERROR) 3781 goto syntax; 3782 if (m == MATCH_NO) 3783 { 3784 m = gfc_match_char (')'); 3785 if (m == MATCH_YES) 3786 goto done; 3787 goto syntax; 3788 } 3789 } 3790 3791 for (;;) 3792 { 3793 m = gfc_match (" stat = %v", &tmp); 3794 if (m == MATCH_ERROR) 3795 goto syntax; 3796 if (m == MATCH_YES) 3797 { 3798 if (saw_stat) 3799 { 3800 gfc_error ("Redundant STAT tag found at %L", &tmp->where); 3801 goto cleanup; 3802 } 3803 stat = tmp; 3804 saw_stat = true; 3805 3806 if (gfc_match_char (',') == MATCH_YES) 3807 continue; 3808 3809 tmp = NULL; 3810 break; 3811 } 3812 3813 m = gfc_match (" errmsg = %v", &tmp); 3814 if (m == MATCH_ERROR) 3815 goto syntax; 3816 if (m == MATCH_YES) 3817 { 3818 if (saw_errmsg) 3819 { 3820 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); 3821 goto cleanup; 3822 } 3823 errmsg = tmp; 3824 saw_errmsg = true; 3825 3826 if (gfc_match_char (',') == MATCH_YES) 3827 continue; 3828 3829 tmp = NULL; 3830 break; 3831 } 3832 3833 break; 3834 } 3835 3836 if (gfc_match (" )%t") != MATCH_YES) 3837 goto syntax; 3838 3839 done: 3840 switch (st) 3841 { 3842 case ST_SYNC_ALL: 3843 new_st.op = EXEC_SYNC_ALL; 3844 break; 3845 case ST_SYNC_IMAGES: 3846 new_st.op = EXEC_SYNC_IMAGES; 3847 break; 3848 case ST_SYNC_MEMORY: 3849 new_st.op = EXEC_SYNC_MEMORY; 3850 break; 3851 default: 3852 gcc_unreachable (); 3853 } 3854 3855 new_st.expr1 = imageset; 3856 new_st.expr2 = stat; 3857 new_st.expr3 = errmsg; 3858 3859 return MATCH_YES; 3860 3861 syntax: 3862 gfc_syntax_error (st); 3863 3864 cleanup: 3865 if (stat != tmp) 3866 gfc_free_expr (stat); 3867 if (errmsg != tmp) 3868 gfc_free_expr (errmsg); 3869 3870 gfc_free_expr (tmp); 3871 gfc_free_expr (imageset); 3872 3873 return MATCH_ERROR; 3874 } 3875 3876 3877 /* Match SYNC ALL statement. */ 3878 3879 match 3880 gfc_match_sync_all (void) 3881 { 3882 return sync_statement (ST_SYNC_ALL); 3883 } 3884 3885 3886 /* Match SYNC IMAGES statement. */ 3887 3888 match 3889 gfc_match_sync_images (void) 3890 { 3891 return sync_statement (ST_SYNC_IMAGES); 3892 } 3893 3894 3895 /* Match SYNC MEMORY statement. */ 3896 3897 match 3898 gfc_match_sync_memory (void) 3899 { 3900 return sync_statement (ST_SYNC_MEMORY); 3901 } 3902 3903 3904 /* Match a CONTINUE statement. */ 3905 3906 match 3907 gfc_match_continue (void) 3908 { 3909 if (gfc_match_eos () != MATCH_YES) 3910 { 3911 gfc_syntax_error (ST_CONTINUE); 3912 return MATCH_ERROR; 3913 } 3914 3915 new_st.op = EXEC_CONTINUE; 3916 return MATCH_YES; 3917 } 3918 3919 3920 /* Match the (deprecated) ASSIGN statement. */ 3921 3922 match 3923 gfc_match_assign (void) 3924 { 3925 gfc_expr *expr; 3926 gfc_st_label *label; 3927 3928 if (gfc_match (" %l", &label) == MATCH_YES) 3929 { 3930 if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN)) 3931 return MATCH_ERROR; 3932 if (gfc_match (" to %v%t", &expr) == MATCH_YES) 3933 { 3934 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C")) 3935 return MATCH_ERROR; 3936 3937 expr->symtree->n.sym->attr.assign = 1; 3938 3939 new_st.op = EXEC_LABEL_ASSIGN; 3940 new_st.label1 = label; 3941 new_st.expr1 = expr; 3942 return MATCH_YES; 3943 } 3944 } 3945 return MATCH_NO; 3946 } 3947 3948 3949 /* Match the GO TO statement. As a computed GOTO statement is 3950 matched, it is transformed into an equivalent SELECT block. No 3951 tree is necessary, and the resulting jumps-to-jumps are 3952 specifically optimized away by the back end. */ 3953 3954 match 3955 gfc_match_goto (void) 3956 { 3957 gfc_code *head, *tail; 3958 gfc_expr *expr; 3959 gfc_case *cp; 3960 gfc_st_label *label; 3961 int i; 3962 match m; 3963 3964 if (gfc_match (" %l%t", &label) == MATCH_YES) 3965 { 3966 if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) 3967 return MATCH_ERROR; 3968 3969 new_st.op = EXEC_GOTO; 3970 new_st.label1 = label; 3971 return MATCH_YES; 3972 } 3973 3974 /* The assigned GO TO statement. */ 3975 3976 if (gfc_match_variable (&expr, 0) == MATCH_YES) 3977 { 3978 if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C")) 3979 return MATCH_ERROR; 3980 3981 new_st.op = EXEC_GOTO; 3982 new_st.expr1 = expr; 3983 3984 if (gfc_match_eos () == MATCH_YES) 3985 return MATCH_YES; 3986 3987 /* Match label list. */ 3988 gfc_match_char (','); 3989 if (gfc_match_char ('(') != MATCH_YES) 3990 { 3991 gfc_syntax_error (ST_GOTO); 3992 return MATCH_ERROR; 3993 } 3994 head = tail = NULL; 3995 3996 do 3997 { 3998 m = gfc_match_st_label (&label); 3999 if (m != MATCH_YES) 4000 goto syntax; 4001 4002 if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) 4003 goto cleanup; 4004 4005 if (head == NULL) 4006 head = tail = gfc_get_code (EXEC_GOTO); 4007 else 4008 { 4009 tail->block = gfc_get_code (EXEC_GOTO); 4010 tail = tail->block; 4011 } 4012 4013 tail->label1 = label; 4014 } 4015 while (gfc_match_char (',') == MATCH_YES); 4016 4017 if (gfc_match (")%t") != MATCH_YES) 4018 goto syntax; 4019 4020 if (head == NULL) 4021 { 4022 gfc_error ("Statement label list in GOTO at %C cannot be empty"); 4023 goto syntax; 4024 } 4025 new_st.block = head; 4026 4027 return MATCH_YES; 4028 } 4029 4030 /* Last chance is a computed GO TO statement. */ 4031 if (gfc_match_char ('(') != MATCH_YES) 4032 { 4033 gfc_syntax_error (ST_GOTO); 4034 return MATCH_ERROR; 4035 } 4036 4037 head = tail = NULL; 4038 i = 1; 4039 4040 do 4041 { 4042 m = gfc_match_st_label (&label); 4043 if (m != MATCH_YES) 4044 goto syntax; 4045 4046 if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) 4047 goto cleanup; 4048 4049 if (head == NULL) 4050 head = tail = gfc_get_code (EXEC_SELECT); 4051 else 4052 { 4053 tail->block = gfc_get_code (EXEC_SELECT); 4054 tail = tail->block; 4055 } 4056 4057 cp = gfc_get_case (); 4058 cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind, 4059 NULL, i++); 4060 4061 tail->ext.block.case_list = cp; 4062 4063 tail->next = gfc_get_code (EXEC_GOTO); 4064 tail->next->label1 = label; 4065 } 4066 while (gfc_match_char (',') == MATCH_YES); 4067 4068 if (gfc_match_char (')') != MATCH_YES) 4069 goto syntax; 4070 4071 if (head == NULL) 4072 { 4073 gfc_error ("Statement label list in GOTO at %C cannot be empty"); 4074 goto syntax; 4075 } 4076 4077 /* Get the rest of the statement. */ 4078 gfc_match_char (','); 4079 4080 if (gfc_match (" %e%t", &expr) != MATCH_YES) 4081 goto syntax; 4082 4083 if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C")) 4084 return MATCH_ERROR; 4085 4086 /* At this point, a computed GOTO has been fully matched and an 4087 equivalent SELECT statement constructed. */ 4088 4089 new_st.op = EXEC_SELECT; 4090 new_st.expr1 = NULL; 4091 4092 /* Hack: For a "real" SELECT, the expression is in expr. We put 4093 it in expr2 so we can distinguish then and produce the correct 4094 diagnostics. */ 4095 new_st.expr2 = expr; 4096 new_st.block = head; 4097 return MATCH_YES; 4098 4099 syntax: 4100 gfc_syntax_error (ST_GOTO); 4101 cleanup: 4102 gfc_free_statements (head); 4103 return MATCH_ERROR; 4104 } 4105 4106 4107 /* Frees a list of gfc_alloc structures. */ 4108 4109 void 4110 gfc_free_alloc_list (gfc_alloc *p) 4111 { 4112 gfc_alloc *q; 4113 4114 for (; p; p = q) 4115 { 4116 q = p->next; 4117 gfc_free_expr (p->expr); 4118 free (p); 4119 } 4120 } 4121 4122 4123 /* Match an ALLOCATE statement. */ 4124 4125 match 4126 gfc_match_allocate (void) 4127 { 4128 gfc_alloc *head, *tail; 4129 gfc_expr *stat, *errmsg, *tmp, *source, *mold; 4130 gfc_typespec ts; 4131 gfc_symbol *sym; 4132 match m; 4133 locus old_locus, deferred_locus, assumed_locus; 4134 bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; 4135 bool saw_unlimited = false, saw_assumed = false; 4136 4137 head = tail = NULL; 4138 stat = errmsg = source = mold = tmp = NULL; 4139 saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false; 4140 4141 if (gfc_match_char ('(') != MATCH_YES) 4142 { 4143 gfc_syntax_error (ST_ALLOCATE); 4144 return MATCH_ERROR; 4145 } 4146 4147 /* Match an optional type-spec. */ 4148 old_locus = gfc_current_locus; 4149 m = gfc_match_type_spec (&ts); 4150 if (m == MATCH_ERROR) 4151 goto cleanup; 4152 else if (m == MATCH_NO) 4153 { 4154 char name[GFC_MAX_SYMBOL_LEN + 3]; 4155 4156 if (gfc_match ("%n :: ", name) == MATCH_YES) 4157 { 4158 gfc_error ("Error in type-spec at %L", &old_locus); 4159 goto cleanup; 4160 } 4161 4162 ts.type = BT_UNKNOWN; 4163 } 4164 else 4165 { 4166 /* Needed for the F2008:C631 check below. */ 4167 assumed_locus = gfc_current_locus; 4168 4169 if (gfc_match (" :: ") == MATCH_YES) 4170 { 4171 if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L", 4172 &old_locus)) 4173 goto cleanup; 4174 4175 if (ts.deferred) 4176 { 4177 gfc_error ("Type-spec at %L cannot contain a deferred " 4178 "type parameter", &old_locus); 4179 goto cleanup; 4180 } 4181 4182 if (ts.type == BT_CHARACTER) 4183 { 4184 if (!ts.u.cl->length) 4185 saw_assumed = true; 4186 else 4187 ts.u.cl->length_from_typespec = true; 4188 } 4189 4190 if (type_param_spec_list 4191 && gfc_spec_list_type (type_param_spec_list, NULL) 4192 == SPEC_DEFERRED) 4193 { 4194 gfc_error ("The type parameter spec list in the type-spec at " 4195 "%L cannot contain DEFERRED parameters", &old_locus); 4196 goto cleanup; 4197 } 4198 } 4199 else 4200 { 4201 ts.type = BT_UNKNOWN; 4202 gfc_current_locus = old_locus; 4203 } 4204 } 4205 4206 for (;;) 4207 { 4208 if (head == NULL) 4209 head = tail = gfc_get_alloc (); 4210 else 4211 { 4212 tail->next = gfc_get_alloc (); 4213 tail = tail->next; 4214 } 4215 4216 m = gfc_match_variable (&tail->expr, 0); 4217 if (m == MATCH_NO) 4218 goto syntax; 4219 if (m == MATCH_ERROR) 4220 goto cleanup; 4221 4222 if (tail->expr->expr_type == EXPR_CONSTANT) 4223 { 4224 gfc_error ("Unexpected constant at %C"); 4225 goto cleanup; 4226 } 4227 4228 if (gfc_check_do_variable (tail->expr->symtree)) 4229 goto cleanup; 4230 4231 bool impure = gfc_impure_variable (tail->expr->symtree->n.sym); 4232 if (impure && gfc_pure (NULL)) 4233 { 4234 gfc_error ("Bad allocate-object at %C for a PURE procedure"); 4235 goto cleanup; 4236 } 4237 4238 if (impure) 4239 gfc_unset_implicit_pure (NULL); 4240 4241 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an 4242 asterisk if and only if each allocate-object is a dummy argument 4243 for which the corresponding type parameter is assumed. */ 4244 if (saw_assumed 4245 && (tail->expr->ts.deferred 4246 || (tail->expr->ts.u.cl && tail->expr->ts.u.cl->length) 4247 || tail->expr->symtree->n.sym->attr.dummy == 0)) 4248 { 4249 gfc_error ("Incompatible allocate-object at %C for CHARACTER " 4250 "type-spec at %L", &assumed_locus); 4251 goto cleanup; 4252 } 4253 4254 if (tail->expr->ts.deferred) 4255 { 4256 saw_deferred = true; 4257 deferred_locus = tail->expr->where; 4258 } 4259 4260 if (gfc_find_state (COMP_DO_CONCURRENT) 4261 || gfc_find_state (COMP_CRITICAL)) 4262 { 4263 gfc_ref *ref; 4264 bool coarray = tail->expr->symtree->n.sym->attr.codimension; 4265 for (ref = tail->expr->ref; ref; ref = ref->next) 4266 if (ref->type == REF_COMPONENT) 4267 coarray = ref->u.c.component->attr.codimension; 4268 4269 if (coarray && gfc_find_state (COMP_DO_CONCURRENT)) 4270 { 4271 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block"); 4272 goto cleanup; 4273 } 4274 if (coarray && gfc_find_state (COMP_CRITICAL)) 4275 { 4276 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block"); 4277 goto cleanup; 4278 } 4279 } 4280 4281 /* Check for F08:C628. */ 4282 sym = tail->expr->symtree->n.sym; 4283 b1 = !(tail->expr->ref 4284 && (tail->expr->ref->type == REF_COMPONENT 4285 || tail->expr->ref->type == REF_ARRAY)); 4286 if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok) 4287 b2 = !(CLASS_DATA (sym)->attr.allocatable 4288 || CLASS_DATA (sym)->attr.class_pointer); 4289 else 4290 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer 4291 || sym->attr.proc_pointer); 4292 b3 = sym && sym->ns && sym->ns->proc_name 4293 && (sym->ns->proc_name->attr.allocatable 4294 || sym->ns->proc_name->attr.pointer 4295 || sym->ns->proc_name->attr.proc_pointer); 4296 if (b1 && b2 && !b3) 4297 { 4298 gfc_error ("Allocate-object at %L is neither a data pointer " 4299 "nor an allocatable variable", &tail->expr->where); 4300 goto cleanup; 4301 } 4302 4303 /* The ALLOCATE statement had an optional typespec. Check the 4304 constraints. */ 4305 if (ts.type != BT_UNKNOWN) 4306 { 4307 /* Enforce F03:C624. */ 4308 if (!gfc_type_compatible (&tail->expr->ts, &ts)) 4309 { 4310 gfc_error ("Type of entity at %L is type incompatible with " 4311 "typespec", &tail->expr->where); 4312 goto cleanup; 4313 } 4314 4315 /* Enforce F03:C627. */ 4316 if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr)) 4317 { 4318 gfc_error ("Kind type parameter for entity at %L differs from " 4319 "the kind type parameter of the typespec", 4320 &tail->expr->where); 4321 goto cleanup; 4322 } 4323 } 4324 4325 if (tail->expr->ts.type == BT_DERIVED) 4326 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); 4327 4328 if (type_param_spec_list) 4329 tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list); 4330 4331 saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr); 4332 4333 if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) 4334 { 4335 gfc_error ("Shape specification for allocatable scalar at %C"); 4336 goto cleanup; 4337 } 4338 4339 if (gfc_match_char (',') != MATCH_YES) 4340 break; 4341 4342 alloc_opt_list: 4343 4344 m = gfc_match (" stat = %v", &tmp); 4345 if (m == MATCH_ERROR) 4346 goto cleanup; 4347 if (m == MATCH_YES) 4348 { 4349 /* Enforce C630. */ 4350 if (saw_stat) 4351 { 4352 gfc_error ("Redundant STAT tag found at %L", &tmp->where); 4353 goto cleanup; 4354 } 4355 4356 stat = tmp; 4357 tmp = NULL; 4358 saw_stat = true; 4359 4360 if (stat->expr_type == EXPR_CONSTANT) 4361 { 4362 gfc_error ("STAT tag at %L cannot be a constant", &stat->where); 4363 goto cleanup; 4364 } 4365 4366 if (gfc_check_do_variable (stat->symtree)) 4367 goto cleanup; 4368 4369 if (gfc_match_char (',') == MATCH_YES) 4370 goto alloc_opt_list; 4371 } 4372 4373 m = gfc_match (" errmsg = %v", &tmp); 4374 if (m == MATCH_ERROR) 4375 goto cleanup; 4376 if (m == MATCH_YES) 4377 { 4378 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where)) 4379 goto cleanup; 4380 4381 /* Enforce C630. */ 4382 if (saw_errmsg) 4383 { 4384 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); 4385 goto cleanup; 4386 } 4387 4388 errmsg = tmp; 4389 tmp = NULL; 4390 saw_errmsg = true; 4391 4392 if (gfc_match_char (',') == MATCH_YES) 4393 goto alloc_opt_list; 4394 } 4395 4396 m = gfc_match (" source = %e", &tmp); 4397 if (m == MATCH_ERROR) 4398 goto cleanup; 4399 if (m == MATCH_YES) 4400 { 4401 if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where)) 4402 goto cleanup; 4403 4404 /* Enforce C630. */ 4405 if (saw_source) 4406 { 4407 gfc_error ("Redundant SOURCE tag found at %L", &tmp->where); 4408 goto cleanup; 4409 } 4410 4411 /* The next 2 conditionals check C631. */ 4412 if (ts.type != BT_UNKNOWN) 4413 { 4414 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", 4415 &tmp->where, &old_locus); 4416 goto cleanup; 4417 } 4418 4419 if (head->next 4420 && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L" 4421 " with more than a single allocate object", 4422 &tmp->where)) 4423 goto cleanup; 4424 4425 source = tmp; 4426 tmp = NULL; 4427 saw_source = true; 4428 4429 if (gfc_match_char (',') == MATCH_YES) 4430 goto alloc_opt_list; 4431 } 4432 4433 m = gfc_match (" mold = %e", &tmp); 4434 if (m == MATCH_ERROR) 4435 goto cleanup; 4436 if (m == MATCH_YES) 4437 { 4438 if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where)) 4439 goto cleanup; 4440 4441 /* Check F08:C636. */ 4442 if (saw_mold) 4443 { 4444 gfc_error ("Redundant MOLD tag found at %L", &tmp->where); 4445 goto cleanup; 4446 } 4447 4448 /* Check F08:C637. */ 4449 if (ts.type != BT_UNKNOWN) 4450 { 4451 gfc_error ("MOLD tag at %L conflicts with the typespec at %L", 4452 &tmp->where, &old_locus); 4453 goto cleanup; 4454 } 4455 4456 mold = tmp; 4457 tmp = NULL; 4458 saw_mold = true; 4459 mold->mold = 1; 4460 4461 if (gfc_match_char (',') == MATCH_YES) 4462 goto alloc_opt_list; 4463 } 4464 4465 gfc_gobble_whitespace (); 4466 4467 if (gfc_peek_char () == ')') 4468 break; 4469 } 4470 4471 if (gfc_match (" )%t") != MATCH_YES) 4472 goto syntax; 4473 4474 /* Check F08:C637. */ 4475 if (source && mold) 4476 { 4477 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", 4478 &mold->where, &source->where); 4479 goto cleanup; 4480 } 4481 4482 /* Check F03:C623, */ 4483 if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold) 4484 { 4485 gfc_error ("Allocate-object at %L with a deferred type parameter " 4486 "requires either a type-spec or SOURCE tag or a MOLD tag", 4487 &deferred_locus); 4488 goto cleanup; 4489 } 4490 4491 /* Check F03:C625, */ 4492 if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold) 4493 { 4494 for (tail = head; tail; tail = tail->next) 4495 { 4496 if (UNLIMITED_POLY (tail->expr)) 4497 gfc_error ("Unlimited polymorphic allocate-object at %L " 4498 "requires either a type-spec or SOURCE tag " 4499 "or a MOLD tag", &tail->expr->where); 4500 } 4501 goto cleanup; 4502 } 4503 4504 new_st.op = EXEC_ALLOCATE; 4505 new_st.expr1 = stat; 4506 new_st.expr2 = errmsg; 4507 if (source) 4508 new_st.expr3 = source; 4509 else 4510 new_st.expr3 = mold; 4511 new_st.ext.alloc.list = head; 4512 new_st.ext.alloc.ts = ts; 4513 4514 if (type_param_spec_list) 4515 gfc_free_actual_arglist (type_param_spec_list); 4516 4517 return MATCH_YES; 4518 4519 syntax: 4520 gfc_syntax_error (ST_ALLOCATE); 4521 4522 cleanup: 4523 gfc_free_expr (errmsg); 4524 gfc_free_expr (source); 4525 gfc_free_expr (stat); 4526 gfc_free_expr (mold); 4527 if (tmp && tmp->expr_type) gfc_free_expr (tmp); 4528 gfc_free_alloc_list (head); 4529 if (type_param_spec_list) 4530 gfc_free_actual_arglist (type_param_spec_list); 4531 return MATCH_ERROR; 4532 } 4533 4534 4535 /* Match a NULLIFY statement. A NULLIFY statement is transformed into 4536 a set of pointer assignments to intrinsic NULL(). */ 4537 4538 match 4539 gfc_match_nullify (void) 4540 { 4541 gfc_code *tail; 4542 gfc_expr *e, *p; 4543 match m; 4544 4545 tail = NULL; 4546 4547 if (gfc_match_char ('(') != MATCH_YES) 4548 goto syntax; 4549 4550 for (;;) 4551 { 4552 m = gfc_match_variable (&p, 0); 4553 if (m == MATCH_ERROR) 4554 goto cleanup; 4555 if (m == MATCH_NO) 4556 goto syntax; 4557 4558 if (gfc_check_do_variable (p->symtree)) 4559 goto cleanup; 4560 4561 /* F2008, C1242. */ 4562 if (gfc_is_coindexed (p)) 4563 { 4564 gfc_error ("Pointer object at %C shall not be coindexed"); 4565 goto cleanup; 4566 } 4567 4568 /* build ' => NULL() '. */ 4569 e = gfc_get_null_expr (&gfc_current_locus); 4570 4571 /* Chain to list. */ 4572 if (tail == NULL) 4573 { 4574 tail = &new_st; 4575 tail->op = EXEC_POINTER_ASSIGN; 4576 } 4577 else 4578 { 4579 tail->next = gfc_get_code (EXEC_POINTER_ASSIGN); 4580 tail = tail->next; 4581 } 4582 4583 tail->expr1 = p; 4584 tail->expr2 = e; 4585 4586 if (gfc_match (" )%t") == MATCH_YES) 4587 break; 4588 if (gfc_match_char (',') != MATCH_YES) 4589 goto syntax; 4590 } 4591 4592 return MATCH_YES; 4593 4594 syntax: 4595 gfc_syntax_error (ST_NULLIFY); 4596 4597 cleanup: 4598 gfc_free_statements (new_st.next); 4599 new_st.next = NULL; 4600 gfc_free_expr (new_st.expr1); 4601 new_st.expr1 = NULL; 4602 gfc_free_expr (new_st.expr2); 4603 new_st.expr2 = NULL; 4604 return MATCH_ERROR; 4605 } 4606 4607 4608 /* Match a DEALLOCATE statement. */ 4609 4610 match 4611 gfc_match_deallocate (void) 4612 { 4613 gfc_alloc *head, *tail; 4614 gfc_expr *stat, *errmsg, *tmp; 4615 gfc_symbol *sym; 4616 match m; 4617 bool saw_stat, saw_errmsg, b1, b2; 4618 4619 head = tail = NULL; 4620 stat = errmsg = tmp = NULL; 4621 saw_stat = saw_errmsg = false; 4622 4623 if (gfc_match_char ('(') != MATCH_YES) 4624 goto syntax; 4625 4626 for (;;) 4627 { 4628 if (head == NULL) 4629 head = tail = gfc_get_alloc (); 4630 else 4631 { 4632 tail->next = gfc_get_alloc (); 4633 tail = tail->next; 4634 } 4635 4636 m = gfc_match_variable (&tail->expr, 0); 4637 if (m == MATCH_ERROR) 4638 goto cleanup; 4639 if (m == MATCH_NO) 4640 goto syntax; 4641 4642 if (tail->expr->expr_type == EXPR_CONSTANT) 4643 { 4644 gfc_error ("Unexpected constant at %C"); 4645 goto cleanup; 4646 } 4647 4648 if (gfc_check_do_variable (tail->expr->symtree)) 4649 goto cleanup; 4650 4651 sym = tail->expr->symtree->n.sym; 4652 4653 bool impure = gfc_impure_variable (sym); 4654 if (impure && gfc_pure (NULL)) 4655 { 4656 gfc_error ("Illegal allocate-object at %C for a PURE procedure"); 4657 goto cleanup; 4658 } 4659 4660 if (impure) 4661 gfc_unset_implicit_pure (NULL); 4662 4663 if (gfc_is_coarray (tail->expr) 4664 && gfc_find_state (COMP_DO_CONCURRENT)) 4665 { 4666 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block"); 4667 goto cleanup; 4668 } 4669 4670 if (gfc_is_coarray (tail->expr) 4671 && gfc_find_state (COMP_CRITICAL)) 4672 { 4673 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block"); 4674 goto cleanup; 4675 } 4676 4677 /* FIXME: disable the checking on derived types. */ 4678 b1 = !(tail->expr->ref 4679 && (tail->expr->ref->type == REF_COMPONENT 4680 || tail->expr->ref->type == REF_ARRAY)); 4681 if (sym && sym->ts.type == BT_CLASS) 4682 b2 = !(CLASS_DATA (sym) && (CLASS_DATA (sym)->attr.allocatable 4683 || CLASS_DATA (sym)->attr.class_pointer)); 4684 else 4685 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer 4686 || sym->attr.proc_pointer); 4687 if (b1 && b2) 4688 { 4689 gfc_error ("Allocate-object at %C is not a nonprocedure pointer " 4690 "nor an allocatable variable"); 4691 goto cleanup; 4692 } 4693 4694 if (gfc_match_char (',') != MATCH_YES) 4695 break; 4696 4697 dealloc_opt_list: 4698 4699 m = gfc_match (" stat = %v", &tmp); 4700 if (m == MATCH_ERROR) 4701 goto cleanup; 4702 if (m == MATCH_YES) 4703 { 4704 if (saw_stat) 4705 { 4706 gfc_error ("Redundant STAT tag found at %L", &tmp->where); 4707 gfc_free_expr (tmp); 4708 goto cleanup; 4709 } 4710 4711 stat = tmp; 4712 saw_stat = true; 4713 4714 if (gfc_check_do_variable (stat->symtree)) 4715 goto cleanup; 4716 4717 if (gfc_match_char (',') == MATCH_YES) 4718 goto dealloc_opt_list; 4719 } 4720 4721 m = gfc_match (" errmsg = %v", &tmp); 4722 if (m == MATCH_ERROR) 4723 goto cleanup; 4724 if (m == MATCH_YES) 4725 { 4726 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where)) 4727 goto cleanup; 4728 4729 if (saw_errmsg) 4730 { 4731 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); 4732 gfc_free_expr (tmp); 4733 goto cleanup; 4734 } 4735 4736 errmsg = tmp; 4737 saw_errmsg = true; 4738 4739 if (gfc_match_char (',') == MATCH_YES) 4740 goto dealloc_opt_list; 4741 } 4742 4743 gfc_gobble_whitespace (); 4744 4745 if (gfc_peek_char () == ')') 4746 break; 4747 } 4748 4749 if (gfc_match (" )%t") != MATCH_YES) 4750 goto syntax; 4751 4752 new_st.op = EXEC_DEALLOCATE; 4753 new_st.expr1 = stat; 4754 new_st.expr2 = errmsg; 4755 new_st.ext.alloc.list = head; 4756 4757 return MATCH_YES; 4758 4759 syntax: 4760 gfc_syntax_error (ST_DEALLOCATE); 4761 4762 cleanup: 4763 gfc_free_expr (errmsg); 4764 gfc_free_expr (stat); 4765 gfc_free_alloc_list (head); 4766 return MATCH_ERROR; 4767 } 4768 4769 4770 /* Match a RETURN statement. */ 4771 4772 match 4773 gfc_match_return (void) 4774 { 4775 gfc_expr *e; 4776 match m; 4777 gfc_compile_state s; 4778 4779 e = NULL; 4780 4781 if (gfc_find_state (COMP_CRITICAL)) 4782 { 4783 gfc_error ("Image control statement RETURN at %C in CRITICAL block"); 4784 return MATCH_ERROR; 4785 } 4786 4787 if (gfc_find_state (COMP_DO_CONCURRENT)) 4788 { 4789 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block"); 4790 return MATCH_ERROR; 4791 } 4792 4793 if (gfc_match_eos () == MATCH_YES) 4794 goto done; 4795 4796 if (!gfc_find_state (COMP_SUBROUTINE)) 4797 { 4798 gfc_error ("Alternate RETURN statement at %C is only allowed within " 4799 "a SUBROUTINE"); 4800 goto cleanup; 4801 } 4802 4803 if (gfc_current_form == FORM_FREE) 4804 { 4805 /* The following are valid, so we can't require a blank after the 4806 RETURN keyword: 4807 return+1 4808 return(1) */ 4809 char c = gfc_peek_ascii_char (); 4810 if (ISALPHA (c) || ISDIGIT (c)) 4811 return MATCH_NO; 4812 } 4813 4814 m = gfc_match (" %e%t", &e); 4815 if (m == MATCH_YES) 4816 goto done; 4817 if (m == MATCH_ERROR) 4818 goto cleanup; 4819 4820 gfc_syntax_error (ST_RETURN); 4821 4822 cleanup: 4823 gfc_free_expr (e); 4824 return MATCH_ERROR; 4825 4826 done: 4827 gfc_enclosing_unit (&s); 4828 if (s == COMP_PROGRAM 4829 && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in " 4830 "main program at %C")) 4831 return MATCH_ERROR; 4832 4833 new_st.op = EXEC_RETURN; 4834 new_st.expr1 = e; 4835 4836 return MATCH_YES; 4837 } 4838 4839 4840 /* Match the call of a type-bound procedure, if CALL%var has already been 4841 matched and var found to be a derived-type variable. */ 4842 4843 static match 4844 match_typebound_call (gfc_symtree* varst) 4845 { 4846 gfc_expr* base; 4847 match m; 4848 4849 base = gfc_get_expr (); 4850 base->expr_type = EXPR_VARIABLE; 4851 base->symtree = varst; 4852 base->where = gfc_current_locus; 4853 gfc_set_sym_referenced (varst->n.sym); 4854 4855 m = gfc_match_varspec (base, 0, true, true); 4856 if (m == MATCH_NO) 4857 gfc_error ("Expected component reference at %C"); 4858 if (m != MATCH_YES) 4859 { 4860 gfc_free_expr (base); 4861 return MATCH_ERROR; 4862 } 4863 4864 if (gfc_match_eos () != MATCH_YES) 4865 { 4866 gfc_error ("Junk after CALL at %C"); 4867 gfc_free_expr (base); 4868 return MATCH_ERROR; 4869 } 4870 4871 if (base->expr_type == EXPR_COMPCALL) 4872 new_st.op = EXEC_COMPCALL; 4873 else if (base->expr_type == EXPR_PPC) 4874 new_st.op = EXEC_CALL_PPC; 4875 else 4876 { 4877 gfc_error ("Expected type-bound procedure or procedure pointer component " 4878 "at %C"); 4879 gfc_free_expr (base); 4880 return MATCH_ERROR; 4881 } 4882 new_st.expr1 = base; 4883 4884 return MATCH_YES; 4885 } 4886 4887 4888 /* Match a CALL statement. The tricky part here are possible 4889 alternate return specifiers. We handle these by having all 4890 "subroutines" actually return an integer via a register that gives 4891 the return number. If the call specifies alternate returns, we 4892 generate code for a SELECT statement whose case clauses contain 4893 GOTOs to the various labels. */ 4894 4895 match 4896 gfc_match_call (void) 4897 { 4898 char name[GFC_MAX_SYMBOL_LEN + 1]; 4899 gfc_actual_arglist *a, *arglist; 4900 gfc_case *new_case; 4901 gfc_symbol *sym; 4902 gfc_symtree *st; 4903 gfc_code *c; 4904 match m; 4905 int i; 4906 4907 arglist = NULL; 4908 4909 m = gfc_match ("% %n", name); 4910 if (m == MATCH_NO) 4911 goto syntax; 4912 if (m != MATCH_YES) 4913 return m; 4914 4915 if (gfc_get_ha_sym_tree (name, &st)) 4916 return MATCH_ERROR; 4917 4918 sym = st->n.sym; 4919 4920 /* If this is a variable of derived-type, it probably starts a type-bound 4921 procedure call. */ 4922 if ((sym->attr.flavor != FL_PROCEDURE 4923 || gfc_is_function_return_value (sym, gfc_current_ns)) 4924 && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) 4925 return match_typebound_call (st); 4926 4927 /* If it does not seem to be callable (include functions so that the 4928 right association is made. They are thrown out in resolution.) 4929 ... */ 4930 if (!sym->attr.generic 4931 && !sym->attr.subroutine 4932 && !sym->attr.function) 4933 { 4934 if (!(sym->attr.external && !sym->attr.referenced)) 4935 { 4936 /* ...create a symbol in this scope... */ 4937 if (sym->ns != gfc_current_ns 4938 && gfc_get_sym_tree (name, NULL, &st, false) == 1) 4939 return MATCH_ERROR; 4940 4941 if (sym != st->n.sym) 4942 sym = st->n.sym; 4943 } 4944 4945 /* ...and then to try to make the symbol into a subroutine. */ 4946 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) 4947 return MATCH_ERROR; 4948 } 4949 4950 gfc_set_sym_referenced (sym); 4951 4952 if (gfc_match_eos () != MATCH_YES) 4953 { 4954 m = gfc_match_actual_arglist (1, &arglist); 4955 if (m == MATCH_NO) 4956 goto syntax; 4957 if (m == MATCH_ERROR) 4958 goto cleanup; 4959 4960 if (gfc_match_eos () != MATCH_YES) 4961 goto syntax; 4962 } 4963 4964 /* If any alternate return labels were found, construct a SELECT 4965 statement that will jump to the right place. */ 4966 4967 i = 0; 4968 for (a = arglist; a; a = a->next) 4969 if (a->expr == NULL) 4970 { 4971 i = 1; 4972 break; 4973 } 4974 4975 if (i) 4976 { 4977 gfc_symtree *select_st; 4978 gfc_symbol *select_sym; 4979 char name[GFC_MAX_SYMBOL_LEN + 1]; 4980 4981 new_st.next = c = gfc_get_code (EXEC_SELECT); 4982 sprintf (name, "_result_%s", sym->name); 4983 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */ 4984 4985 select_sym = select_st->n.sym; 4986 select_sym->ts.type = BT_INTEGER; 4987 select_sym->ts.kind = gfc_default_integer_kind; 4988 gfc_set_sym_referenced (select_sym); 4989 c->expr1 = gfc_get_expr (); 4990 c->expr1->expr_type = EXPR_VARIABLE; 4991 c->expr1->symtree = select_st; 4992 c->expr1->ts = select_sym->ts; 4993 c->expr1->where = gfc_current_locus; 4994 4995 i = 0; 4996 for (a = arglist; a; a = a->next) 4997 { 4998 if (a->expr != NULL) 4999 continue; 5000 5001 if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET)) 5002 continue; 5003 5004 i++; 5005 5006 c->block = gfc_get_code (EXEC_SELECT); 5007 c = c->block; 5008 5009 new_case = gfc_get_case (); 5010 new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); 5011 new_case->low = new_case->high; 5012 c->ext.block.case_list = new_case; 5013 5014 c->next = gfc_get_code (EXEC_GOTO); 5015 c->next->label1 = a->label; 5016 } 5017 } 5018 5019 new_st.op = EXEC_CALL; 5020 new_st.symtree = st; 5021 new_st.ext.actual = arglist; 5022 5023 return MATCH_YES; 5024 5025 syntax: 5026 gfc_syntax_error (ST_CALL); 5027 5028 cleanup: 5029 gfc_free_actual_arglist (arglist); 5030 return MATCH_ERROR; 5031 } 5032 5033 5034 /* Given a name, return a pointer to the common head structure, 5035 creating it if it does not exist. If FROM_MODULE is nonzero, we 5036 mangle the name so that it doesn't interfere with commons defined 5037 in the using namespace. 5038 TODO: Add to global symbol tree. */ 5039 5040 gfc_common_head * 5041 gfc_get_common (const char *name, int from_module) 5042 { 5043 gfc_symtree *st; 5044 static int serial = 0; 5045 char mangled_name[GFC_MAX_SYMBOL_LEN + 1]; 5046 5047 if (from_module) 5048 { 5049 /* A use associated common block is only needed to correctly layout 5050 the variables it contains. */ 5051 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); 5052 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); 5053 } 5054 else 5055 { 5056 st = gfc_find_symtree (gfc_current_ns->common_root, name); 5057 5058 if (st == NULL) 5059 st = gfc_new_symtree (&gfc_current_ns->common_root, name); 5060 } 5061 5062 if (st->n.common == NULL) 5063 { 5064 st->n.common = gfc_get_common_head (); 5065 st->n.common->where = gfc_current_locus; 5066 strcpy (st->n.common->name, name); 5067 } 5068 5069 return st->n.common; 5070 } 5071 5072 5073 /* Match a common block name. */ 5074 5075 match match_common_name (char *name) 5076 { 5077 match m; 5078 5079 if (gfc_match_char ('/') == MATCH_NO) 5080 { 5081 name[0] = '\0'; 5082 return MATCH_YES; 5083 } 5084 5085 if (gfc_match_char ('/') == MATCH_YES) 5086 { 5087 name[0] = '\0'; 5088 return MATCH_YES; 5089 } 5090 5091 m = gfc_match_name (name); 5092 5093 if (m == MATCH_ERROR) 5094 return MATCH_ERROR; 5095 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) 5096 return MATCH_YES; 5097 5098 gfc_error ("Syntax error in common block name at %C"); 5099 return MATCH_ERROR; 5100 } 5101 5102 5103 /* Match a COMMON statement. */ 5104 5105 match 5106 gfc_match_common (void) 5107 { 5108 gfc_symbol *sym, **head, *tail, *other; 5109 char name[GFC_MAX_SYMBOL_LEN + 1]; 5110 gfc_common_head *t; 5111 gfc_array_spec *as; 5112 gfc_equiv *e1, *e2; 5113 match m; 5114 5115 as = NULL; 5116 5117 for (;;) 5118 { 5119 m = match_common_name (name); 5120 if (m == MATCH_ERROR) 5121 goto cleanup; 5122 5123 if (name[0] == '\0') 5124 { 5125 t = &gfc_current_ns->blank_common; 5126 if (t->head == NULL) 5127 t->where = gfc_current_locus; 5128 } 5129 else 5130 { 5131 t = gfc_get_common (name, 0); 5132 } 5133 head = &t->head; 5134 5135 if (*head == NULL) 5136 tail = NULL; 5137 else 5138 { 5139 tail = *head; 5140 while (tail->common_next) 5141 tail = tail->common_next; 5142 } 5143 5144 /* Grab the list of symbols. */ 5145 for (;;) 5146 { 5147 m = gfc_match_symbol (&sym, 0); 5148 if (m == MATCH_ERROR) 5149 goto cleanup; 5150 if (m == MATCH_NO) 5151 goto syntax; 5152 5153 /* See if we know the current common block is bind(c), and if 5154 so, then see if we can check if the symbol is (which it'll 5155 need to be). This can happen if the bind(c) attr stmt was 5156 applied to the common block, and the variable(s) already 5157 defined, before declaring the common block. */ 5158 if (t->is_bind_c == 1) 5159 { 5160 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) 5161 { 5162 /* If we find an error, just print it and continue, 5163 cause it's just semantic, and we can see if there 5164 are more errors. */ 5165 gfc_error_now ("Variable %qs at %L in common block %qs " 5166 "at %C must be declared with a C " 5167 "interoperable kind since common block " 5168 "%qs is bind(c)", 5169 sym->name, &(sym->declared_at), t->name, 5170 t->name); 5171 } 5172 5173 if (sym->attr.is_bind_c == 1) 5174 gfc_error_now ("Variable %qs in common block %qs at %C cannot " 5175 "be bind(c) since it is not global", sym->name, 5176 t->name); 5177 } 5178 5179 if (sym->attr.in_common) 5180 { 5181 gfc_error ("Symbol %qs at %C is already in a COMMON block", 5182 sym->name); 5183 goto cleanup; 5184 } 5185 5186 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) 5187 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) 5188 { 5189 if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at " 5190 "%C can only be COMMON in BLOCK DATA", 5191 sym->name)) 5192 goto cleanup; 5193 } 5194 5195 /* Deal with an optional array specification after the 5196 symbol name. */ 5197 m = gfc_match_array_spec (&as, true, true); 5198 if (m == MATCH_ERROR) 5199 goto cleanup; 5200 5201 if (m == MATCH_YES) 5202 { 5203 if (as->type != AS_EXPLICIT) 5204 { 5205 gfc_error ("Array specification for symbol %qs in COMMON " 5206 "at %C must be explicit", sym->name); 5207 goto cleanup; 5208 } 5209 5210 if (!gfc_add_dimension (&sym->attr, sym->name, NULL)) 5211 goto cleanup; 5212 5213 if (sym->attr.pointer) 5214 { 5215 gfc_error ("Symbol %qs in COMMON at %C cannot be a " 5216 "POINTER array", sym->name); 5217 goto cleanup; 5218 } 5219 5220 sym->as = as; 5221 as = NULL; 5222 5223 } 5224 5225 /* Add the in_common attribute, but ignore the reported errors 5226 if any, and continue matching. */ 5227 gfc_add_in_common (&sym->attr, sym->name, NULL); 5228 5229 sym->common_block = t; 5230 sym->common_block->refs++; 5231 5232 if (tail != NULL) 5233 tail->common_next = sym; 5234 else 5235 *head = sym; 5236 5237 tail = sym; 5238 5239 sym->common_head = t; 5240 5241 /* Check to see if the symbol is already in an equivalence group. 5242 If it is, set the other members as being in common. */ 5243 if (sym->attr.in_equivalence) 5244 { 5245 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) 5246 { 5247 for (e2 = e1; e2; e2 = e2->eq) 5248 if (e2->expr->symtree->n.sym == sym) 5249 goto equiv_found; 5250 5251 continue; 5252 5253 equiv_found: 5254 5255 for (e2 = e1; e2; e2 = e2->eq) 5256 { 5257 other = e2->expr->symtree->n.sym; 5258 if (other->common_head 5259 && other->common_head != sym->common_head) 5260 { 5261 gfc_error ("Symbol %qs, in COMMON block %qs at " 5262 "%C is being indirectly equivalenced to " 5263 "another COMMON block %qs", 5264 sym->name, sym->common_head->name, 5265 other->common_head->name); 5266 goto cleanup; 5267 } 5268 other->attr.in_common = 1; 5269 other->common_head = t; 5270 } 5271 } 5272 } 5273 5274 5275 gfc_gobble_whitespace (); 5276 if (gfc_match_eos () == MATCH_YES) 5277 goto done; 5278 if (gfc_peek_ascii_char () == '/') 5279 break; 5280 if (gfc_match_char (',') != MATCH_YES) 5281 goto syntax; 5282 gfc_gobble_whitespace (); 5283 if (gfc_peek_ascii_char () == '/') 5284 break; 5285 } 5286 } 5287 5288 done: 5289 return MATCH_YES; 5290 5291 syntax: 5292 gfc_syntax_error (ST_COMMON); 5293 5294 cleanup: 5295 gfc_free_array_spec (as); 5296 return MATCH_ERROR; 5297 } 5298 5299 5300 /* Match a BLOCK DATA program unit. */ 5301 5302 match 5303 gfc_match_block_data (void) 5304 { 5305 char name[GFC_MAX_SYMBOL_LEN + 1]; 5306 gfc_symbol *sym; 5307 match m; 5308 5309 if (!gfc_notify_std (GFC_STD_F2018_OBS, "BLOCK DATA construct at %L", 5310 &gfc_current_locus)) 5311 return MATCH_ERROR; 5312 5313 if (gfc_match_eos () == MATCH_YES) 5314 { 5315 gfc_new_block = NULL; 5316 return MATCH_YES; 5317 } 5318 5319 m = gfc_match ("% %n%t", name); 5320 if (m != MATCH_YES) 5321 return MATCH_ERROR; 5322 5323 if (gfc_get_symbol (name, NULL, &sym)) 5324 return MATCH_ERROR; 5325 5326 if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL)) 5327 return MATCH_ERROR; 5328 5329 gfc_new_block = sym; 5330 5331 return MATCH_YES; 5332 } 5333 5334 5335 /* Free a namelist structure. */ 5336 5337 void 5338 gfc_free_namelist (gfc_namelist *name) 5339 { 5340 gfc_namelist *n; 5341 5342 for (; name; name = n) 5343 { 5344 n = name->next; 5345 free (name); 5346 } 5347 } 5348 5349 5350 /* Free an OpenMP namelist structure. */ 5351 5352 void 5353 gfc_free_omp_namelist (gfc_omp_namelist *name) 5354 { 5355 gfc_omp_namelist *n; 5356 5357 for (; name; name = n) 5358 { 5359 gfc_free_expr (name->expr); 5360 if (name->udr) 5361 { 5362 if (name->udr->combiner) 5363 gfc_free_statement (name->udr->combiner); 5364 if (name->udr->initializer) 5365 gfc_free_statement (name->udr->initializer); 5366 free (name->udr); 5367 } 5368 n = name->next; 5369 free (name); 5370 } 5371 } 5372 5373 5374 /* Match a NAMELIST statement. */ 5375 5376 match 5377 gfc_match_namelist (void) 5378 { 5379 gfc_symbol *group_name, *sym; 5380 gfc_namelist *nl; 5381 match m, m2; 5382 5383 m = gfc_match (" / %s /", &group_name); 5384 if (m == MATCH_NO) 5385 goto syntax; 5386 if (m == MATCH_ERROR) 5387 goto error; 5388 5389 for (;;) 5390 { 5391 if (group_name->ts.type != BT_UNKNOWN) 5392 { 5393 gfc_error ("Namelist group name %qs at %C already has a basic " 5394 "type of %s", group_name->name, 5395 gfc_typename (&group_name->ts)); 5396 return MATCH_ERROR; 5397 } 5398 5399 if (group_name->attr.flavor == FL_NAMELIST 5400 && group_name->attr.use_assoc 5401 && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs " 5402 "at %C already is USE associated and can" 5403 "not be respecified.", group_name->name)) 5404 return MATCH_ERROR; 5405 5406 if (group_name->attr.flavor != FL_NAMELIST 5407 && !gfc_add_flavor (&group_name->attr, FL_NAMELIST, 5408 group_name->name, NULL)) 5409 return MATCH_ERROR; 5410 5411 for (;;) 5412 { 5413 m = gfc_match_symbol (&sym, 1); 5414 if (m == MATCH_NO) 5415 goto syntax; 5416 if (m == MATCH_ERROR) 5417 goto error; 5418 5419 if (sym->attr.in_namelist == 0 5420 && !gfc_add_in_namelist (&sym->attr, sym->name, NULL)) 5421 goto error; 5422 5423 /* Use gfc_error_check here, rather than goto error, so that 5424 these are the only errors for the next two lines. */ 5425 if (sym->as && sym->as->type == AS_ASSUMED_SIZE) 5426 { 5427 gfc_error ("Assumed size array %qs in namelist %qs at " 5428 "%C is not allowed", sym->name, group_name->name); 5429 gfc_error_check (); 5430 } 5431 5432 nl = gfc_get_namelist (); 5433 nl->sym = sym; 5434 sym->refs++; 5435 5436 if (group_name->namelist == NULL) 5437 group_name->namelist = group_name->namelist_tail = nl; 5438 else 5439 { 5440 group_name->namelist_tail->next = nl; 5441 group_name->namelist_tail = nl; 5442 } 5443 5444 if (gfc_match_eos () == MATCH_YES) 5445 goto done; 5446 5447 m = gfc_match_char (','); 5448 5449 if (gfc_match_char ('/') == MATCH_YES) 5450 { 5451 m2 = gfc_match (" %s /", &group_name); 5452 if (m2 == MATCH_YES) 5453 break; 5454 if (m2 == MATCH_ERROR) 5455 goto error; 5456 goto syntax; 5457 } 5458 5459 if (m != MATCH_YES) 5460 goto syntax; 5461 } 5462 } 5463 5464 done: 5465 return MATCH_YES; 5466 5467 syntax: 5468 gfc_syntax_error (ST_NAMELIST); 5469 5470 error: 5471 return MATCH_ERROR; 5472 } 5473 5474 5475 /* Match a MODULE statement. */ 5476 5477 match 5478 gfc_match_module (void) 5479 { 5480 match m; 5481 5482 m = gfc_match (" %s%t", &gfc_new_block); 5483 if (m != MATCH_YES) 5484 return m; 5485 5486 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, 5487 gfc_new_block->name, NULL)) 5488 return MATCH_ERROR; 5489 5490 return MATCH_YES; 5491 } 5492 5493 5494 /* Free equivalence sets and lists. Recursively is the easiest way to 5495 do this. */ 5496 5497 void 5498 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) 5499 { 5500 if (eq == stop) 5501 return; 5502 5503 gfc_free_equiv (eq->eq); 5504 gfc_free_equiv_until (eq->next, stop); 5505 gfc_free_expr (eq->expr); 5506 free (eq); 5507 } 5508 5509 5510 void 5511 gfc_free_equiv (gfc_equiv *eq) 5512 { 5513 gfc_free_equiv_until (eq, NULL); 5514 } 5515 5516 5517 /* Match an EQUIVALENCE statement. */ 5518 5519 match 5520 gfc_match_equivalence (void) 5521 { 5522 gfc_equiv *eq, *set, *tail; 5523 gfc_ref *ref; 5524 gfc_symbol *sym; 5525 match m; 5526 gfc_common_head *common_head = NULL; 5527 bool common_flag; 5528 int cnt; 5529 5530 tail = NULL; 5531 5532 for (;;) 5533 { 5534 eq = gfc_get_equiv (); 5535 if (tail == NULL) 5536 tail = eq; 5537 5538 eq->next = gfc_current_ns->equiv; 5539 gfc_current_ns->equiv = eq; 5540 5541 if (gfc_match_char ('(') != MATCH_YES) 5542 goto syntax; 5543 5544 set = eq; 5545 common_flag = FALSE; 5546 cnt = 0; 5547 5548 for (;;) 5549 { 5550 m = gfc_match_equiv_variable (&set->expr); 5551 if (m == MATCH_ERROR) 5552 goto cleanup; 5553 if (m == MATCH_NO) 5554 goto syntax; 5555 5556 /* count the number of objects. */ 5557 cnt++; 5558 5559 if (gfc_match_char ('%') == MATCH_YES) 5560 { 5561 gfc_error ("Derived type component %C is not a " 5562 "permitted EQUIVALENCE member"); 5563 goto cleanup; 5564 } 5565 5566 for (ref = set->expr->ref; ref; ref = ref->next) 5567 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 5568 { 5569 gfc_error ("Array reference in EQUIVALENCE at %C cannot " 5570 "be an array section"); 5571 goto cleanup; 5572 } 5573 5574 sym = set->expr->symtree->n.sym; 5575 5576 if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL)) 5577 goto cleanup; 5578 5579 if (sym->attr.in_common) 5580 { 5581 common_flag = TRUE; 5582 common_head = sym->common_head; 5583 } 5584 5585 if (gfc_match_char (')') == MATCH_YES) 5586 break; 5587 5588 if (gfc_match_char (',') != MATCH_YES) 5589 goto syntax; 5590 5591 set->eq = gfc_get_equiv (); 5592 set = set->eq; 5593 } 5594 5595 if (cnt < 2) 5596 { 5597 gfc_error ("EQUIVALENCE at %C requires two or more objects"); 5598 goto cleanup; 5599 } 5600 5601 /* If one of the members of an equivalence is in common, then 5602 mark them all as being in common. Before doing this, check 5603 that members of the equivalence group are not in different 5604 common blocks. */ 5605 if (common_flag) 5606 for (set = eq; set; set = set->eq) 5607 { 5608 sym = set->expr->symtree->n.sym; 5609 if (sym->common_head && sym->common_head != common_head) 5610 { 5611 gfc_error ("Attempt to indirectly overlap COMMON " 5612 "blocks %s and %s by EQUIVALENCE at %C", 5613 sym->common_head->name, common_head->name); 5614 goto cleanup; 5615 } 5616 sym->attr.in_common = 1; 5617 sym->common_head = common_head; 5618 } 5619 5620 if (gfc_match_eos () == MATCH_YES) 5621 break; 5622 if (gfc_match_char (',') != MATCH_YES) 5623 { 5624 gfc_error ("Expecting a comma in EQUIVALENCE at %C"); 5625 goto cleanup; 5626 } 5627 } 5628 5629 if (!gfc_notify_std (GFC_STD_F2018_OBS, "EQUIVALENCE statement at %C")) 5630 return MATCH_ERROR; 5631 5632 return MATCH_YES; 5633 5634 syntax: 5635 gfc_syntax_error (ST_EQUIVALENCE); 5636 5637 cleanup: 5638 eq = tail->next; 5639 tail->next = NULL; 5640 5641 gfc_free_equiv (gfc_current_ns->equiv); 5642 gfc_current_ns->equiv = eq; 5643 5644 return MATCH_ERROR; 5645 } 5646 5647 5648 /* Check that a statement function is not recursive. This is done by looking 5649 for the statement function symbol(sym) by looking recursively through its 5650 expression(e). If a reference to sym is found, true is returned. 5651 12.5.4 requires that any variable of function that is implicitly typed 5652 shall have that type confirmed by any subsequent type declaration. The 5653 implicit typing is conveniently done here. */ 5654 static bool 5655 recursive_stmt_fcn (gfc_expr *, gfc_symbol *); 5656 5657 static bool 5658 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) 5659 { 5660 5661 if (e == NULL) 5662 return false; 5663 5664 switch (e->expr_type) 5665 { 5666 case EXPR_FUNCTION: 5667 if (e->symtree == NULL) 5668 return false; 5669 5670 /* Check the name before testing for nested recursion! */ 5671 if (sym->name == e->symtree->n.sym->name) 5672 return true; 5673 5674 /* Catch recursion via other statement functions. */ 5675 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION 5676 && e->symtree->n.sym->value 5677 && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) 5678 return true; 5679 5680 if (e->symtree->n.sym->ts.type == BT_UNKNOWN) 5681 gfc_set_default_type (e->symtree->n.sym, 0, NULL); 5682 5683 break; 5684 5685 case EXPR_VARIABLE: 5686 if (e->symtree && sym->name == e->symtree->n.sym->name) 5687 return true; 5688 5689 if (e->symtree->n.sym->ts.type == BT_UNKNOWN) 5690 gfc_set_default_type (e->symtree->n.sym, 0, NULL); 5691 break; 5692 5693 default: 5694 break; 5695 } 5696 5697 return false; 5698 } 5699 5700 5701 static bool 5702 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) 5703 { 5704 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); 5705 } 5706 5707 5708 /* Match a statement function declaration. It is so easy to match 5709 non-statement function statements with a MATCH_ERROR as opposed to 5710 MATCH_NO that we suppress error message in most cases. */ 5711 5712 match 5713 gfc_match_st_function (void) 5714 { 5715 gfc_error_buffer old_error; 5716 gfc_symbol *sym; 5717 gfc_expr *expr; 5718 match m; 5719 char name[GFC_MAX_SYMBOL_LEN + 1]; 5720 locus old_locus; 5721 bool fcn; 5722 gfc_formal_arglist *ptr; 5723 5724 /* Read the possible statement function name, and then check to see if 5725 a symbol is already present in the namespace. Record if it is a 5726 function and whether it has been referenced. */ 5727 fcn = false; 5728 ptr = NULL; 5729 old_locus = gfc_current_locus; 5730 m = gfc_match_name (name); 5731 if (m == MATCH_YES) 5732 { 5733 gfc_find_symbol (name, NULL, 1, &sym); 5734 if (sym && sym->attr.function && !sym->attr.referenced) 5735 { 5736 fcn = true; 5737 ptr = sym->formal; 5738 } 5739 } 5740 5741 gfc_current_locus = old_locus; 5742 m = gfc_match_symbol (&sym, 0); 5743 if (m != MATCH_YES) 5744 return m; 5745 5746 gfc_push_error (&old_error); 5747 5748 if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL)) 5749 goto undo_error; 5750 5751 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) 5752 goto undo_error; 5753 5754 m = gfc_match (" = %e%t", &expr); 5755 if (m == MATCH_NO) 5756 goto undo_error; 5757 5758 gfc_free_error (&old_error); 5759 5760 if (m == MATCH_ERROR) 5761 return m; 5762 5763 if (recursive_stmt_fcn (expr, sym)) 5764 { 5765 gfc_error ("Statement function at %L is recursive", &expr->where); 5766 return MATCH_ERROR; 5767 } 5768 5769 if (fcn && ptr != sym->formal) 5770 { 5771 gfc_error ("Statement function %qs at %L conflicts with function name", 5772 sym->name, &expr->where); 5773 return MATCH_ERROR; 5774 } 5775 5776 sym->value = expr; 5777 5778 if ((gfc_current_state () == COMP_FUNCTION 5779 || gfc_current_state () == COMP_SUBROUTINE) 5780 && gfc_state_stack->previous->state == COMP_INTERFACE) 5781 { 5782 gfc_error ("Statement function at %L cannot appear within an INTERFACE", 5783 &expr->where); 5784 return MATCH_ERROR; 5785 } 5786 5787 if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C")) 5788 return MATCH_ERROR; 5789 5790 return MATCH_YES; 5791 5792 undo_error: 5793 gfc_pop_error (&old_error); 5794 return MATCH_NO; 5795 } 5796 5797 5798 /* Match an assignment to a pointer function (F2008). This could, in 5799 general be ambiguous with a statement function. In this implementation 5800 it remains so if it is the first statement after the specification 5801 block. */ 5802 5803 match 5804 gfc_match_ptr_fcn_assign (void) 5805 { 5806 gfc_error_buffer old_error; 5807 locus old_loc; 5808 gfc_symbol *sym; 5809 gfc_expr *expr; 5810 match m; 5811 char name[GFC_MAX_SYMBOL_LEN + 1]; 5812 5813 old_loc = gfc_current_locus; 5814 m = gfc_match_name (name); 5815 if (m != MATCH_YES) 5816 return m; 5817 5818 gfc_find_symbol (name, NULL, 1, &sym); 5819 if (sym && sym->attr.flavor != FL_PROCEDURE) 5820 return MATCH_NO; 5821 5822 gfc_push_error (&old_error); 5823 5824 if (sym && sym->attr.function) 5825 goto match_actual_arglist; 5826 5827 gfc_current_locus = old_loc; 5828 m = gfc_match_symbol (&sym, 0); 5829 if (m != MATCH_YES) 5830 return m; 5831 5832 if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL)) 5833 goto undo_error; 5834 5835 match_actual_arglist: 5836 gfc_current_locus = old_loc; 5837 m = gfc_match (" %e", &expr); 5838 if (m != MATCH_YES) 5839 goto undo_error; 5840 5841 new_st.op = EXEC_ASSIGN; 5842 new_st.expr1 = expr; 5843 expr = NULL; 5844 5845 m = gfc_match (" = %e%t", &expr); 5846 if (m != MATCH_YES) 5847 goto undo_error; 5848 5849 new_st.expr2 = expr; 5850 return MATCH_YES; 5851 5852 undo_error: 5853 gfc_pop_error (&old_error); 5854 return MATCH_NO; 5855 } 5856 5857 5858 /***************** SELECT CASE subroutines ******************/ 5859 5860 /* Free a single case structure. */ 5861 5862 static void 5863 free_case (gfc_case *p) 5864 { 5865 if (p->low == p->high) 5866 p->high = NULL; 5867 gfc_free_expr (p->low); 5868 gfc_free_expr (p->high); 5869 free (p); 5870 } 5871 5872 5873 /* Free a list of case structures. */ 5874 5875 void 5876 gfc_free_case_list (gfc_case *p) 5877 { 5878 gfc_case *q; 5879 5880 for (; p; p = q) 5881 { 5882 q = p->next; 5883 free_case (p); 5884 } 5885 } 5886 5887 5888 /* Match a single case selector. Combining the requirements of F08:C830 5889 and F08:C832 (R838) means that the case-value must have either CHARACTER, 5890 INTEGER, or LOGICAL type. */ 5891 5892 static match 5893 match_case_selector (gfc_case **cp) 5894 { 5895 gfc_case *c; 5896 match m; 5897 5898 c = gfc_get_case (); 5899 c->where = gfc_current_locus; 5900 5901 if (gfc_match_char (':') == MATCH_YES) 5902 { 5903 m = gfc_match_init_expr (&c->high); 5904 if (m == MATCH_NO) 5905 goto need_expr; 5906 if (m == MATCH_ERROR) 5907 goto cleanup; 5908 5909 if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER 5910 && c->high->ts.type != BT_CHARACTER) 5911 { 5912 gfc_error ("Expression in CASE selector at %L cannot be %s", 5913 &c->high->where, gfc_typename (&c->high->ts)); 5914 goto cleanup; 5915 } 5916 } 5917 else 5918 { 5919 m = gfc_match_init_expr (&c->low); 5920 if (m == MATCH_ERROR) 5921 goto cleanup; 5922 if (m == MATCH_NO) 5923 goto need_expr; 5924 5925 if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER 5926 && c->low->ts.type != BT_CHARACTER) 5927 { 5928 gfc_error ("Expression in CASE selector at %L cannot be %s", 5929 &c->low->where, gfc_typename (&c->low->ts)); 5930 goto cleanup; 5931 } 5932 5933 /* If we're not looking at a ':' now, make a range out of a single 5934 target. Else get the upper bound for the case range. */ 5935 if (gfc_match_char (':') != MATCH_YES) 5936 c->high = c->low; 5937 else 5938 { 5939 m = gfc_match_init_expr (&c->high); 5940 if (m == MATCH_ERROR) 5941 goto cleanup; 5942 /* MATCH_NO is fine. It's OK if nothing is there! */ 5943 } 5944 } 5945 5946 *cp = c; 5947 return MATCH_YES; 5948 5949 need_expr: 5950 gfc_error ("Expected initialization expression in CASE at %C"); 5951 5952 cleanup: 5953 free_case (c); 5954 return MATCH_ERROR; 5955 } 5956 5957 5958 /* Match the end of a case statement. */ 5959 5960 static match 5961 match_case_eos (void) 5962 { 5963 char name[GFC_MAX_SYMBOL_LEN + 1]; 5964 match m; 5965 5966 if (gfc_match_eos () == MATCH_YES) 5967 return MATCH_YES; 5968 5969 /* If the case construct doesn't have a case-construct-name, we 5970 should have matched the EOS. */ 5971 if (!gfc_current_block ()) 5972 return MATCH_NO; 5973 5974 gfc_gobble_whitespace (); 5975 5976 m = gfc_match_name (name); 5977 if (m != MATCH_YES) 5978 return m; 5979 5980 if (strcmp (name, gfc_current_block ()->name) != 0) 5981 { 5982 gfc_error ("Expected block name %qs of SELECT construct at %C", 5983 gfc_current_block ()->name); 5984 return MATCH_ERROR; 5985 } 5986 5987 return gfc_match_eos (); 5988 } 5989 5990 5991 /* Match a SELECT statement. */ 5992 5993 match 5994 gfc_match_select (void) 5995 { 5996 gfc_expr *expr; 5997 match m; 5998 5999 m = gfc_match_label (); 6000 if (m == MATCH_ERROR) 6001 return m; 6002 6003 m = gfc_match (" select case ( %e )%t", &expr); 6004 if (m != MATCH_YES) 6005 return m; 6006 6007 new_st.op = EXEC_SELECT; 6008 new_st.expr1 = expr; 6009 6010 return MATCH_YES; 6011 } 6012 6013 6014 /* Transfer the selector typespec to the associate name. */ 6015 6016 static void 6017 copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) 6018 { 6019 gfc_ref *ref; 6020 gfc_symbol *assoc_sym; 6021 int rank = 0; 6022 6023 assoc_sym = associate->symtree->n.sym; 6024 6025 /* At this stage the expression rank and arrayspec dimensions have 6026 not been completely sorted out. We must get the expr2->rank 6027 right here, so that the correct class container is obtained. */ 6028 ref = selector->ref; 6029 while (ref && ref->next) 6030 ref = ref->next; 6031 6032 if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as 6033 && ref && ref->type == REF_ARRAY) 6034 { 6035 /* Ensure that the array reference type is set. We cannot use 6036 gfc_resolve_expr at this point, so the usable parts of 6037 resolve.c(resolve_array_ref) are employed to do it. */ 6038 if (ref->u.ar.type == AR_UNKNOWN) 6039 { 6040 ref->u.ar.type = AR_ELEMENT; 6041 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) 6042 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE 6043 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR 6044 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN 6045 && ref->u.ar.start[i] && ref->u.ar.start[i]->rank)) 6046 { 6047 ref->u.ar.type = AR_SECTION; 6048 break; 6049 } 6050 } 6051 6052 if (ref->u.ar.type == AR_FULL) 6053 selector->rank = CLASS_DATA (selector)->as->rank; 6054 else if (ref->u.ar.type == AR_SECTION) 6055 selector->rank = ref->u.ar.dimen; 6056 else 6057 selector->rank = 0; 6058 6059 rank = selector->rank; 6060 } 6061 6062 if (rank) 6063 { 6064 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) 6065 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT 6066 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN 6067 && ref->u.ar.end[i] == NULL 6068 && ref->u.ar.stride[i] == NULL)) 6069 rank--; 6070 6071 if (rank) 6072 { 6073 assoc_sym->attr.dimension = 1; 6074 assoc_sym->as = gfc_get_array_spec (); 6075 assoc_sym->as->rank = rank; 6076 assoc_sym->as->type = AS_DEFERRED; 6077 } 6078 else 6079 assoc_sym->as = NULL; 6080 } 6081 else 6082 assoc_sym->as = NULL; 6083 6084 if (selector->ts.type == BT_CLASS) 6085 { 6086 /* The correct class container has to be available. */ 6087 assoc_sym->ts.type = BT_CLASS; 6088 assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; 6089 assoc_sym->attr.pointer = 1; 6090 gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as); 6091 } 6092 } 6093 6094 6095 /* Push the current selector onto the SELECT TYPE stack. */ 6096 6097 static void 6098 select_type_push (gfc_symbol *sel) 6099 { 6100 gfc_select_type_stack *top = gfc_get_select_type_stack (); 6101 top->selector = sel; 6102 top->tmp = NULL; 6103 top->prev = select_type_stack; 6104 6105 select_type_stack = top; 6106 } 6107 6108 6109 /* Set the temporary for the current intrinsic SELECT TYPE selector. */ 6110 6111 static gfc_symtree * 6112 select_intrinsic_set_tmp (gfc_typespec *ts) 6113 { 6114 char name[GFC_MAX_SYMBOL_LEN]; 6115 gfc_symtree *tmp; 6116 HOST_WIDE_INT charlen = 0; 6117 6118 if (ts->type == BT_CLASS || ts->type == BT_DERIVED) 6119 return NULL; 6120 6121 if (select_type_stack->selector->ts.type == BT_CLASS 6122 && !select_type_stack->selector->attr.class_ok) 6123 return NULL; 6124 6125 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length 6126 && ts->u.cl->length->expr_type == EXPR_CONSTANT) 6127 charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 6128 6129 if (ts->type != BT_CHARACTER) 6130 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), 6131 ts->kind); 6132 else 6133 snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", 6134 gfc_basic_typename (ts->type), charlen, ts->kind); 6135 6136 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); 6137 gfc_add_type (tmp->n.sym, ts, NULL); 6138 6139 /* Copy across the array spec to the selector. */ 6140 if (select_type_stack->selector->ts.type == BT_CLASS 6141 && (CLASS_DATA (select_type_stack->selector)->attr.dimension 6142 || CLASS_DATA (select_type_stack->selector)->attr.codimension)) 6143 { 6144 tmp->n.sym->attr.pointer = 1; 6145 tmp->n.sym->attr.dimension 6146 = CLASS_DATA (select_type_stack->selector)->attr.dimension; 6147 tmp->n.sym->attr.codimension 6148 = CLASS_DATA (select_type_stack->selector)->attr.codimension; 6149 tmp->n.sym->as 6150 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); 6151 } 6152 6153 gfc_set_sym_referenced (tmp->n.sym); 6154 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); 6155 tmp->n.sym->attr.select_type_temporary = 1; 6156 6157 return tmp; 6158 } 6159 6160 6161 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */ 6162 6163 static void 6164 select_type_set_tmp (gfc_typespec *ts) 6165 { 6166 char name[GFC_MAX_SYMBOL_LEN]; 6167 gfc_symtree *tmp = NULL; 6168 gfc_symbol *selector = select_type_stack->selector; 6169 6170 if (!ts) 6171 { 6172 select_type_stack->tmp = NULL; 6173 return; 6174 } 6175 6176 tmp = select_intrinsic_set_tmp (ts); 6177 6178 if (tmp == NULL) 6179 { 6180 if (!ts->u.derived) 6181 return; 6182 6183 if (ts->type == BT_CLASS) 6184 sprintf (name, "__tmp_class_%s", ts->u.derived->name); 6185 else 6186 sprintf (name, "__tmp_type_%s", ts->u.derived->name); 6187 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); 6188 gfc_add_type (tmp->n.sym, ts, NULL); 6189 6190 if (selector->ts.type == BT_CLASS && selector->attr.class_ok) 6191 { 6192 tmp->n.sym->attr.pointer = CLASS_DATA (selector)->attr.class_pointer; 6193 6194 /* Copy across the array spec to the selector. */ 6195 if (CLASS_DATA (selector)->attr.dimension 6196 || CLASS_DATA (selector)->attr.codimension) 6197 { 6198 tmp->n.sym->attr.dimension 6199 = CLASS_DATA (selector)->attr.dimension; 6200 tmp->n.sym->attr.codimension 6201 = CLASS_DATA (selector)->attr.codimension; 6202 if (CLASS_DATA (selector)->as->type != AS_EXPLICIT) 6203 tmp->n.sym->as 6204 = gfc_copy_array_spec (CLASS_DATA (selector)->as); 6205 else 6206 { 6207 tmp->n.sym->as = gfc_get_array_spec(); 6208 tmp->n.sym->as->rank = CLASS_DATA (selector)->as->rank; 6209 tmp->n.sym->as->type = AS_DEFERRED; 6210 } 6211 } 6212 } 6213 6214 gfc_set_sym_referenced (tmp->n.sym); 6215 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); 6216 tmp->n.sym->attr.select_type_temporary = 1; 6217 6218 if (ts->type == BT_CLASS) 6219 gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, 6220 &tmp->n.sym->as); 6221 } 6222 6223 /* Add an association for it, so the rest of the parser knows it is 6224 an associate-name. The target will be set during resolution. */ 6225 tmp->n.sym->assoc = gfc_get_association_list (); 6226 tmp->n.sym->assoc->dangling = 1; 6227 tmp->n.sym->assoc->st = tmp; 6228 6229 select_type_stack->tmp = tmp; 6230 } 6231 6232 6233 /* Match a SELECT TYPE statement. */ 6234 6235 match 6236 gfc_match_select_type (void) 6237 { 6238 gfc_expr *expr1, *expr2 = NULL; 6239 match m; 6240 char name[GFC_MAX_SYMBOL_LEN]; 6241 bool class_array; 6242 gfc_symbol *sym; 6243 gfc_namespace *ns = gfc_current_ns; 6244 6245 m = gfc_match_label (); 6246 if (m == MATCH_ERROR) 6247 return m; 6248 6249 m = gfc_match (" select type ( "); 6250 if (m != MATCH_YES) 6251 return m; 6252 6253 if (gfc_current_state() == COMP_MODULE 6254 || gfc_current_state() == COMP_SUBMODULE) 6255 { 6256 gfc_error ("SELECT TYPE at %C cannot appear in this scope"); 6257 return MATCH_ERROR; 6258 } 6259 6260 gfc_current_ns = gfc_build_block_ns (ns); 6261 m = gfc_match (" %n => %e", name, &expr2); 6262 if (m == MATCH_YES) 6263 { 6264 expr1 = gfc_get_expr (); 6265 expr1->expr_type = EXPR_VARIABLE; 6266 expr1->where = expr2->where; 6267 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) 6268 { 6269 m = MATCH_ERROR; 6270 goto cleanup; 6271 } 6272 6273 sym = expr1->symtree->n.sym; 6274 if (expr2->ts.type == BT_UNKNOWN) 6275 sym->attr.untyped = 1; 6276 else 6277 copy_ts_from_selector_to_associate (expr1, expr2); 6278 6279 sym->attr.flavor = FL_VARIABLE; 6280 sym->attr.referenced = 1; 6281 sym->attr.class_ok = 1; 6282 } 6283 else 6284 { 6285 m = gfc_match (" %e ", &expr1); 6286 if (m != MATCH_YES) 6287 { 6288 std::swap (ns, gfc_current_ns); 6289 gfc_free_namespace (ns); 6290 return m; 6291 } 6292 } 6293 6294 m = gfc_match (" )%t"); 6295 if (m != MATCH_YES) 6296 { 6297 gfc_error ("parse error in SELECT TYPE statement at %C"); 6298 goto cleanup; 6299 } 6300 6301 /* This ghastly expression seems to be needed to distinguish a CLASS 6302 array, which can have a reference, from other expressions that 6303 have references, such as derived type components, and are not 6304 allowed by the standard. 6305 TODO: see if it is sufficient to exclude component and substring 6306 references. */ 6307 class_array = (expr1->expr_type == EXPR_VARIABLE 6308 && expr1->ts.type == BT_CLASS 6309 && CLASS_DATA (expr1) 6310 && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) 6311 && (CLASS_DATA (expr1)->attr.dimension 6312 || CLASS_DATA (expr1)->attr.codimension) 6313 && expr1->ref 6314 && expr1->ref->type == REF_ARRAY 6315 && expr1->ref->u.ar.type == AR_FULL 6316 && expr1->ref->next == NULL); 6317 6318 /* Check for F03:C811 (F08:C835). */ 6319 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE 6320 || (!class_array && expr1->ref != NULL))) 6321 { 6322 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " 6323 "use associate-name=>"); 6324 m = MATCH_ERROR; 6325 goto cleanup; 6326 } 6327 6328 new_st.op = EXEC_SELECT_TYPE; 6329 new_st.expr1 = expr1; 6330 new_st.expr2 = expr2; 6331 new_st.ext.block.ns = gfc_current_ns; 6332 6333 select_type_push (expr1->symtree->n.sym); 6334 gfc_current_ns = ns; 6335 6336 return MATCH_YES; 6337 6338 cleanup: 6339 gfc_free_expr (expr1); 6340 gfc_free_expr (expr2); 6341 gfc_undo_symbols (); 6342 std::swap (ns, gfc_current_ns); 6343 gfc_free_namespace (ns); 6344 return m; 6345 } 6346 6347 6348 /* Match a CASE statement. */ 6349 6350 match 6351 gfc_match_case (void) 6352 { 6353 gfc_case *c, *head, *tail; 6354 match m; 6355 6356 head = tail = NULL; 6357 6358 if (gfc_current_state () != COMP_SELECT) 6359 { 6360 gfc_error ("Unexpected CASE statement at %C"); 6361 return MATCH_ERROR; 6362 } 6363 6364 if (gfc_match ("% default") == MATCH_YES) 6365 { 6366 m = match_case_eos (); 6367 if (m == MATCH_NO) 6368 goto syntax; 6369 if (m == MATCH_ERROR) 6370 goto cleanup; 6371 6372 new_st.op = EXEC_SELECT; 6373 c = gfc_get_case (); 6374 c->where = gfc_current_locus; 6375 new_st.ext.block.case_list = c; 6376 return MATCH_YES; 6377 } 6378 6379 if (gfc_match_char ('(') != MATCH_YES) 6380 goto syntax; 6381 6382 for (;;) 6383 { 6384 if (match_case_selector (&c) == MATCH_ERROR) 6385 goto cleanup; 6386 6387 if (head == NULL) 6388 head = c; 6389 else 6390 tail->next = c; 6391 6392 tail = c; 6393 6394 if (gfc_match_char (')') == MATCH_YES) 6395 break; 6396 if (gfc_match_char (',') != MATCH_YES) 6397 goto syntax; 6398 } 6399 6400 m = match_case_eos (); 6401 if (m == MATCH_NO) 6402 goto syntax; 6403 if (m == MATCH_ERROR) 6404 goto cleanup; 6405 6406 new_st.op = EXEC_SELECT; 6407 new_st.ext.block.case_list = head; 6408 6409 return MATCH_YES; 6410 6411 syntax: 6412 gfc_error ("Syntax error in CASE specification at %C"); 6413 6414 cleanup: 6415 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ 6416 return MATCH_ERROR; 6417 } 6418 6419 6420 /* Match a TYPE IS statement. */ 6421 6422 match 6423 gfc_match_type_is (void) 6424 { 6425 gfc_case *c = NULL; 6426 match m; 6427 6428 if (gfc_current_state () != COMP_SELECT_TYPE) 6429 { 6430 gfc_error ("Unexpected TYPE IS statement at %C"); 6431 return MATCH_ERROR; 6432 } 6433 6434 if (gfc_match_char ('(') != MATCH_YES) 6435 goto syntax; 6436 6437 c = gfc_get_case (); 6438 c->where = gfc_current_locus; 6439 6440 m = gfc_match_type_spec (&c->ts); 6441 if (m == MATCH_NO) 6442 goto syntax; 6443 if (m == MATCH_ERROR) 6444 goto cleanup; 6445 6446 if (gfc_match_char (')') != MATCH_YES) 6447 goto syntax; 6448 6449 m = match_case_eos (); 6450 if (m == MATCH_NO) 6451 goto syntax; 6452 if (m == MATCH_ERROR) 6453 goto cleanup; 6454 6455 new_st.op = EXEC_SELECT_TYPE; 6456 new_st.ext.block.case_list = c; 6457 6458 if (c->ts.type == BT_DERIVED && c->ts.u.derived 6459 && (c->ts.u.derived->attr.sequence 6460 || c->ts.u.derived->attr.is_bind_c)) 6461 { 6462 gfc_error ("The type-spec shall not specify a sequence derived " 6463 "type or a type with the BIND attribute in SELECT " 6464 "TYPE at %C [F2003:C815]"); 6465 return MATCH_ERROR; 6466 } 6467 6468 if (c->ts.type == BT_DERIVED 6469 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type 6470 && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived) 6471 != SPEC_ASSUMED) 6472 { 6473 gfc_error ("All the LEN type parameters in the TYPE IS statement " 6474 "at %C must be ASSUMED"); 6475 return MATCH_ERROR; 6476 } 6477 6478 /* Create temporary variable. */ 6479 select_type_set_tmp (&c->ts); 6480 6481 return MATCH_YES; 6482 6483 syntax: 6484 gfc_error ("Syntax error in TYPE IS specification at %C"); 6485 6486 cleanup: 6487 if (c != NULL) 6488 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ 6489 return MATCH_ERROR; 6490 } 6491 6492 6493 /* Match a CLASS IS or CLASS DEFAULT statement. */ 6494 6495 match 6496 gfc_match_class_is (void) 6497 { 6498 gfc_case *c = NULL; 6499 match m; 6500 6501 if (gfc_current_state () != COMP_SELECT_TYPE) 6502 return MATCH_NO; 6503 6504 if (gfc_match ("% default") == MATCH_YES) 6505 { 6506 m = match_case_eos (); 6507 if (m == MATCH_NO) 6508 goto syntax; 6509 if (m == MATCH_ERROR) 6510 goto cleanup; 6511 6512 new_st.op = EXEC_SELECT_TYPE; 6513 c = gfc_get_case (); 6514 c->where = gfc_current_locus; 6515 c->ts.type = BT_UNKNOWN; 6516 new_st.ext.block.case_list = c; 6517 select_type_set_tmp (NULL); 6518 return MATCH_YES; 6519 } 6520 6521 m = gfc_match ("% is"); 6522 if (m == MATCH_NO) 6523 goto syntax; 6524 if (m == MATCH_ERROR) 6525 goto cleanup; 6526 6527 if (gfc_match_char ('(') != MATCH_YES) 6528 goto syntax; 6529 6530 c = gfc_get_case (); 6531 c->where = gfc_current_locus; 6532 6533 m = match_derived_type_spec (&c->ts); 6534 if (m == MATCH_NO) 6535 goto syntax; 6536 if (m == MATCH_ERROR) 6537 goto cleanup; 6538 6539 if (c->ts.type == BT_DERIVED) 6540 c->ts.type = BT_CLASS; 6541 6542 if (gfc_match_char (')') != MATCH_YES) 6543 goto syntax; 6544 6545 m = match_case_eos (); 6546 if (m == MATCH_NO) 6547 goto syntax; 6548 if (m == MATCH_ERROR) 6549 goto cleanup; 6550 6551 new_st.op = EXEC_SELECT_TYPE; 6552 new_st.ext.block.case_list = c; 6553 6554 /* Create temporary variable. */ 6555 select_type_set_tmp (&c->ts); 6556 6557 return MATCH_YES; 6558 6559 syntax: 6560 gfc_error ("Syntax error in CLASS IS specification at %C"); 6561 6562 cleanup: 6563 if (c != NULL) 6564 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ 6565 return MATCH_ERROR; 6566 } 6567 6568 6569 /********************* WHERE subroutines ********************/ 6570 6571 /* Match the rest of a simple WHERE statement that follows an IF statement. 6572 */ 6573 6574 static match 6575 match_simple_where (void) 6576 { 6577 gfc_expr *expr; 6578 gfc_code *c; 6579 match m; 6580 6581 m = gfc_match (" ( %e )", &expr); 6582 if (m != MATCH_YES) 6583 return m; 6584 6585 m = gfc_match_assignment (); 6586 if (m == MATCH_NO) 6587 goto syntax; 6588 if (m == MATCH_ERROR) 6589 goto cleanup; 6590 6591 if (gfc_match_eos () != MATCH_YES) 6592 goto syntax; 6593 6594 c = gfc_get_code (EXEC_WHERE); 6595 c->expr1 = expr; 6596 6597 c->next = XCNEW (gfc_code); 6598 *c->next = new_st; 6599 c->next->loc = gfc_current_locus; 6600 gfc_clear_new_st (); 6601 6602 new_st.op = EXEC_WHERE; 6603 new_st.block = c; 6604 6605 return MATCH_YES; 6606 6607 syntax: 6608 gfc_syntax_error (ST_WHERE); 6609 6610 cleanup: 6611 gfc_free_expr (expr); 6612 return MATCH_ERROR; 6613 } 6614 6615 6616 /* Match a WHERE statement. */ 6617 6618 match 6619 gfc_match_where (gfc_statement *st) 6620 { 6621 gfc_expr *expr; 6622 match m0, m; 6623 gfc_code *c; 6624 6625 m0 = gfc_match_label (); 6626 if (m0 == MATCH_ERROR) 6627 return m0; 6628 6629 m = gfc_match (" where ( %e )", &expr); 6630 if (m != MATCH_YES) 6631 return m; 6632 6633 if (gfc_match_eos () == MATCH_YES) 6634 { 6635 *st = ST_WHERE_BLOCK; 6636 new_st.op = EXEC_WHERE; 6637 new_st.expr1 = expr; 6638 return MATCH_YES; 6639 } 6640 6641 m = gfc_match_assignment (); 6642 if (m == MATCH_NO) 6643 gfc_syntax_error (ST_WHERE); 6644 6645 if (m != MATCH_YES) 6646 { 6647 gfc_free_expr (expr); 6648 return MATCH_ERROR; 6649 } 6650 6651 /* We've got a simple WHERE statement. */ 6652 *st = ST_WHERE; 6653 c = gfc_get_code (EXEC_WHERE); 6654 c->expr1 = expr; 6655 6656 /* Put in the assignment. It will not be processed by add_statement, so we 6657 need to copy the location here. */ 6658 6659 c->next = XCNEW (gfc_code); 6660 *c->next = new_st; 6661 c->next->loc = gfc_current_locus; 6662 gfc_clear_new_st (); 6663 6664 new_st.op = EXEC_WHERE; 6665 new_st.block = c; 6666 6667 return MATCH_YES; 6668 } 6669 6670 6671 /* Match an ELSEWHERE statement. We leave behind a WHERE node in 6672 new_st if successful. */ 6673 6674 match 6675 gfc_match_elsewhere (void) 6676 { 6677 char name[GFC_MAX_SYMBOL_LEN + 1]; 6678 gfc_expr *expr; 6679 match m; 6680 6681 if (gfc_current_state () != COMP_WHERE) 6682 { 6683 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block"); 6684 return MATCH_ERROR; 6685 } 6686 6687 expr = NULL; 6688 6689 if (gfc_match_char ('(') == MATCH_YES) 6690 { 6691 m = gfc_match_expr (&expr); 6692 if (m == MATCH_NO) 6693 goto syntax; 6694 if (m == MATCH_ERROR) 6695 return MATCH_ERROR; 6696 6697 if (gfc_match_char (')') != MATCH_YES) 6698 goto syntax; 6699 } 6700 6701 if (gfc_match_eos () != MATCH_YES) 6702 { 6703 /* Only makes sense if we have a where-construct-name. */ 6704 if (!gfc_current_block ()) 6705 { 6706 m = MATCH_ERROR; 6707 goto cleanup; 6708 } 6709 /* Better be a name at this point. */ 6710 m = gfc_match_name (name); 6711 if (m == MATCH_NO) 6712 goto syntax; 6713 if (m == MATCH_ERROR) 6714 goto cleanup; 6715 6716 if (gfc_match_eos () != MATCH_YES) 6717 goto syntax; 6718 6719 if (strcmp (name, gfc_current_block ()->name) != 0) 6720 { 6721 gfc_error ("Label %qs at %C doesn't match WHERE label %qs", 6722 name, gfc_current_block ()->name); 6723 goto cleanup; 6724 } 6725 } 6726 6727 new_st.op = EXEC_WHERE; 6728 new_st.expr1 = expr; 6729 return MATCH_YES; 6730 6731 syntax: 6732 gfc_syntax_error (ST_ELSEWHERE); 6733 6734 cleanup: 6735 gfc_free_expr (expr); 6736 return MATCH_ERROR; 6737 } 6738