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