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 /* F2018:R874: common-block-object is variable-name [ (array-spec) ] 5301 F2018:C8121: A variable-name shall not be a name made accessible 5302 by use association. */ 5303 if (sym->attr.use_assoc) 5304 { 5305 gfc_error ("Symbol %qs at %C is USE associated from module %qs " 5306 "and cannot occur in COMMON", sym->name, sym->module); 5307 goto cleanup; 5308 } 5309 5310 /* Deal with an optional array specification after the 5311 symbol name. */ 5312 m = gfc_match_array_spec (&as, true, true); 5313 if (m == MATCH_ERROR) 5314 goto cleanup; 5315 5316 if (m == MATCH_YES) 5317 { 5318 if (as->type != AS_EXPLICIT) 5319 { 5320 gfc_error ("Array specification for symbol %qs in COMMON " 5321 "at %C must be explicit", sym->name); 5322 goto cleanup; 5323 } 5324 5325 if (!gfc_add_dimension (&sym->attr, sym->name, NULL)) 5326 goto cleanup; 5327 5328 if (sym->attr.pointer) 5329 { 5330 gfc_error ("Symbol %qs in COMMON at %C cannot be a " 5331 "POINTER array", sym->name); 5332 goto cleanup; 5333 } 5334 5335 sym->as = as; 5336 as = NULL; 5337 5338 } 5339 5340 /* Add the in_common attribute, but ignore the reported errors 5341 if any, and continue matching. */ 5342 gfc_add_in_common (&sym->attr, sym->name, NULL); 5343 5344 sym->common_block = t; 5345 sym->common_block->refs++; 5346 5347 if (tail != NULL) 5348 tail->common_next = sym; 5349 else 5350 *head = sym; 5351 5352 tail = sym; 5353 5354 sym->common_head = t; 5355 5356 /* Check to see if the symbol is already in an equivalence group. 5357 If it is, set the other members as being in common. */ 5358 if (sym->attr.in_equivalence) 5359 { 5360 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) 5361 { 5362 for (e2 = e1; e2; e2 = e2->eq) 5363 if (e2->expr->symtree->n.sym == sym) 5364 goto equiv_found; 5365 5366 continue; 5367 5368 equiv_found: 5369 5370 for (e2 = e1; e2; e2 = e2->eq) 5371 { 5372 other = e2->expr->symtree->n.sym; 5373 if (other->common_head 5374 && other->common_head != sym->common_head) 5375 { 5376 gfc_error ("Symbol %qs, in COMMON block %qs at " 5377 "%C is being indirectly equivalenced to " 5378 "another COMMON block %qs", 5379 sym->name, sym->common_head->name, 5380 other->common_head->name); 5381 goto cleanup; 5382 } 5383 other->attr.in_common = 1; 5384 other->common_head = t; 5385 } 5386 } 5387 } 5388 5389 5390 gfc_gobble_whitespace (); 5391 if (gfc_match_eos () == MATCH_YES) 5392 goto done; 5393 c = gfc_peek_ascii_char (); 5394 if (c == '/') 5395 break; 5396 if (c != ',') 5397 { 5398 /* In Fixed form source code, gfortran can end up here for an 5399 expression of the form COMMONI = RHS. This may not be an 5400 error, so return MATCH_NO. */ 5401 if (gfc_current_form == FORM_FIXED && c == '=') 5402 { 5403 gfc_free_array_spec (as); 5404 return MATCH_NO; 5405 } 5406 goto syntax; 5407 } 5408 else 5409 gfc_match_char (','); 5410 5411 gfc_gobble_whitespace (); 5412 if (gfc_peek_ascii_char () == '/') 5413 break; 5414 } 5415 } 5416 5417 done: 5418 return MATCH_YES; 5419 5420 syntax: 5421 gfc_syntax_error (ST_COMMON); 5422 5423 cleanup: 5424 gfc_free_array_spec (as); 5425 return MATCH_ERROR; 5426 } 5427 5428 5429 /* Match a BLOCK DATA program unit. */ 5430 5431 match 5432 gfc_match_block_data (void) 5433 { 5434 char name[GFC_MAX_SYMBOL_LEN + 1]; 5435 gfc_symbol *sym; 5436 match m; 5437 5438 if (!gfc_notify_std (GFC_STD_F2018_OBS, "BLOCK DATA construct at %L", 5439 &gfc_current_locus)) 5440 return MATCH_ERROR; 5441 5442 if (gfc_match_eos () == MATCH_YES) 5443 { 5444 gfc_new_block = NULL; 5445 return MATCH_YES; 5446 } 5447 5448 m = gfc_match ("% %n%t", name); 5449 if (m != MATCH_YES) 5450 return MATCH_ERROR; 5451 5452 if (gfc_get_symbol (name, NULL, &sym)) 5453 return MATCH_ERROR; 5454 5455 if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL)) 5456 return MATCH_ERROR; 5457 5458 gfc_new_block = sym; 5459 5460 return MATCH_YES; 5461 } 5462 5463 5464 /* Free a namelist structure. */ 5465 5466 void 5467 gfc_free_namelist (gfc_namelist *name) 5468 { 5469 gfc_namelist *n; 5470 5471 for (; name; name = n) 5472 { 5473 n = name->next; 5474 free (name); 5475 } 5476 } 5477 5478 5479 /* Free an OpenMP namelist structure. */ 5480 5481 void 5482 gfc_free_omp_namelist (gfc_omp_namelist *name) 5483 { 5484 gfc_omp_namelist *n; 5485 5486 for (; name; name = n) 5487 { 5488 gfc_free_expr (name->expr); 5489 if (name->udr) 5490 { 5491 if (name->udr->combiner) 5492 gfc_free_statement (name->udr->combiner); 5493 if (name->udr->initializer) 5494 gfc_free_statement (name->udr->initializer); 5495 free (name->udr); 5496 } 5497 n = name->next; 5498 free (name); 5499 } 5500 } 5501 5502 5503 /* Match a NAMELIST statement. */ 5504 5505 match 5506 gfc_match_namelist (void) 5507 { 5508 gfc_symbol *group_name, *sym; 5509 gfc_namelist *nl; 5510 match m, m2; 5511 5512 m = gfc_match (" / %s /", &group_name); 5513 if (m == MATCH_NO) 5514 goto syntax; 5515 if (m == MATCH_ERROR) 5516 goto error; 5517 5518 for (;;) 5519 { 5520 if (group_name->ts.type != BT_UNKNOWN) 5521 { 5522 gfc_error ("Namelist group name %qs at %C already has a basic " 5523 "type of %s", group_name->name, 5524 gfc_typename (&group_name->ts)); 5525 return MATCH_ERROR; 5526 } 5527 5528 if (group_name->attr.flavor == FL_NAMELIST 5529 && group_name->attr.use_assoc 5530 && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs " 5531 "at %C already is USE associated and can" 5532 "not be respecified.", group_name->name)) 5533 return MATCH_ERROR; 5534 5535 if (group_name->attr.flavor != FL_NAMELIST 5536 && !gfc_add_flavor (&group_name->attr, FL_NAMELIST, 5537 group_name->name, NULL)) 5538 return MATCH_ERROR; 5539 5540 for (;;) 5541 { 5542 m = gfc_match_symbol (&sym, 1); 5543 if (m == MATCH_NO) 5544 goto syntax; 5545 if (m == MATCH_ERROR) 5546 goto error; 5547 5548 if (sym->attr.in_namelist == 0 5549 && !gfc_add_in_namelist (&sym->attr, sym->name, NULL)) 5550 goto error; 5551 5552 /* Use gfc_error_check here, rather than goto error, so that 5553 these are the only errors for the next two lines. */ 5554 if (sym->as && sym->as->type == AS_ASSUMED_SIZE) 5555 { 5556 gfc_error ("Assumed size array %qs in namelist %qs at " 5557 "%C is not allowed", sym->name, group_name->name); 5558 gfc_error_check (); 5559 } 5560 5561 nl = gfc_get_namelist (); 5562 nl->sym = sym; 5563 sym->refs++; 5564 5565 if (group_name->namelist == NULL) 5566 group_name->namelist = group_name->namelist_tail = nl; 5567 else 5568 { 5569 group_name->namelist_tail->next = nl; 5570 group_name->namelist_tail = nl; 5571 } 5572 5573 if (gfc_match_eos () == MATCH_YES) 5574 goto done; 5575 5576 m = gfc_match_char (','); 5577 5578 if (gfc_match_char ('/') == MATCH_YES) 5579 { 5580 m2 = gfc_match (" %s /", &group_name); 5581 if (m2 == MATCH_YES) 5582 break; 5583 if (m2 == MATCH_ERROR) 5584 goto error; 5585 goto syntax; 5586 } 5587 5588 if (m != MATCH_YES) 5589 goto syntax; 5590 } 5591 } 5592 5593 done: 5594 return MATCH_YES; 5595 5596 syntax: 5597 gfc_syntax_error (ST_NAMELIST); 5598 5599 error: 5600 return MATCH_ERROR; 5601 } 5602 5603 5604 /* Match a MODULE statement. */ 5605 5606 match 5607 gfc_match_module (void) 5608 { 5609 match m; 5610 5611 m = gfc_match (" %s%t", &gfc_new_block); 5612 if (m != MATCH_YES) 5613 return m; 5614 5615 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, 5616 gfc_new_block->name, NULL)) 5617 return MATCH_ERROR; 5618 5619 return MATCH_YES; 5620 } 5621 5622 5623 /* Free equivalence sets and lists. Recursively is the easiest way to 5624 do this. */ 5625 5626 void 5627 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) 5628 { 5629 if (eq == stop) 5630 return; 5631 5632 gfc_free_equiv (eq->eq); 5633 gfc_free_equiv_until (eq->next, stop); 5634 gfc_free_expr (eq->expr); 5635 free (eq); 5636 } 5637 5638 5639 void 5640 gfc_free_equiv (gfc_equiv *eq) 5641 { 5642 gfc_free_equiv_until (eq, NULL); 5643 } 5644 5645 5646 /* Match an EQUIVALENCE statement. */ 5647 5648 match 5649 gfc_match_equivalence (void) 5650 { 5651 gfc_equiv *eq, *set, *tail; 5652 gfc_ref *ref; 5653 gfc_symbol *sym; 5654 match m; 5655 gfc_common_head *common_head = NULL; 5656 bool common_flag; 5657 int cnt; 5658 char c; 5659 5660 /* EQUIVALENCE has been matched. After gobbling any possible whitespace, 5661 the next character needs to be '('. Check that here, and return 5662 MATCH_NO for a variable of the form equivalencej. */ 5663 gfc_gobble_whitespace (); 5664 c = gfc_peek_ascii_char (); 5665 if (c != '(') 5666 return MATCH_NO; 5667 5668 tail = NULL; 5669 5670 for (;;) 5671 { 5672 eq = gfc_get_equiv (); 5673 if (tail == NULL) 5674 tail = eq; 5675 5676 eq->next = gfc_current_ns->equiv; 5677 gfc_current_ns->equiv = eq; 5678 5679 if (gfc_match_char ('(') != MATCH_YES) 5680 goto syntax; 5681 5682 set = eq; 5683 common_flag = FALSE; 5684 cnt = 0; 5685 5686 for (;;) 5687 { 5688 m = gfc_match_equiv_variable (&set->expr); 5689 if (m == MATCH_ERROR) 5690 goto cleanup; 5691 if (m == MATCH_NO) 5692 goto syntax; 5693 5694 /* count the number of objects. */ 5695 cnt++; 5696 5697 if (gfc_match_char ('%') == MATCH_YES) 5698 { 5699 gfc_error ("Derived type component %C is not a " 5700 "permitted EQUIVALENCE member"); 5701 goto cleanup; 5702 } 5703 5704 for (ref = set->expr->ref; ref; ref = ref->next) 5705 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 5706 { 5707 gfc_error ("Array reference in EQUIVALENCE at %C cannot " 5708 "be an array section"); 5709 goto cleanup; 5710 } 5711 5712 sym = set->expr->symtree->n.sym; 5713 5714 if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL)) 5715 goto cleanup; 5716 if (sym->ts.type == BT_CLASS 5717 && CLASS_DATA (sym) 5718 && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr, 5719 sym->name, NULL)) 5720 goto cleanup; 5721 5722 if (sym->attr.in_common) 5723 { 5724 common_flag = TRUE; 5725 common_head = sym->common_head; 5726 } 5727 5728 if (gfc_match_char (')') == MATCH_YES) 5729 break; 5730 5731 if (gfc_match_char (',') != MATCH_YES) 5732 goto syntax; 5733 5734 set->eq = gfc_get_equiv (); 5735 set = set->eq; 5736 } 5737 5738 if (cnt < 2) 5739 { 5740 gfc_error ("EQUIVALENCE at %C requires two or more objects"); 5741 goto cleanup; 5742 } 5743 5744 /* If one of the members of an equivalence is in common, then 5745 mark them all as being in common. Before doing this, check 5746 that members of the equivalence group are not in different 5747 common blocks. */ 5748 if (common_flag) 5749 for (set = eq; set; set = set->eq) 5750 { 5751 sym = set->expr->symtree->n.sym; 5752 if (sym->common_head && sym->common_head != common_head) 5753 { 5754 gfc_error ("Attempt to indirectly overlap COMMON " 5755 "blocks %s and %s by EQUIVALENCE at %C", 5756 sym->common_head->name, common_head->name); 5757 goto cleanup; 5758 } 5759 sym->attr.in_common = 1; 5760 sym->common_head = common_head; 5761 } 5762 5763 if (gfc_match_eos () == MATCH_YES) 5764 break; 5765 if (gfc_match_char (',') != MATCH_YES) 5766 { 5767 gfc_error ("Expecting a comma in EQUIVALENCE at %C"); 5768 goto cleanup; 5769 } 5770 } 5771 5772 if (!gfc_notify_std (GFC_STD_F2018_OBS, "EQUIVALENCE statement at %C")) 5773 return MATCH_ERROR; 5774 5775 return MATCH_YES; 5776 5777 syntax: 5778 gfc_syntax_error (ST_EQUIVALENCE); 5779 5780 cleanup: 5781 eq = tail->next; 5782 tail->next = NULL; 5783 5784 gfc_free_equiv (gfc_current_ns->equiv); 5785 gfc_current_ns->equiv = eq; 5786 5787 return MATCH_ERROR; 5788 } 5789 5790 5791 /* Check that a statement function is not recursive. This is done by looking 5792 for the statement function symbol(sym) by looking recursively through its 5793 expression(e). If a reference to sym is found, true is returned. 5794 12.5.4 requires that any variable of function that is implicitly typed 5795 shall have that type confirmed by any subsequent type declaration. The 5796 implicit typing is conveniently done here. */ 5797 static bool 5798 recursive_stmt_fcn (gfc_expr *, gfc_symbol *); 5799 5800 static bool 5801 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) 5802 { 5803 5804 if (e == NULL) 5805 return false; 5806 5807 switch (e->expr_type) 5808 { 5809 case EXPR_FUNCTION: 5810 if (e->symtree == NULL) 5811 return false; 5812 5813 /* Check the name before testing for nested recursion! */ 5814 if (sym->name == e->symtree->n.sym->name) 5815 return true; 5816 5817 /* Catch recursion via other statement functions. */ 5818 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION 5819 && e->symtree->n.sym->value 5820 && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) 5821 return true; 5822 5823 if (e->symtree->n.sym->ts.type == BT_UNKNOWN) 5824 gfc_set_default_type (e->symtree->n.sym, 0, NULL); 5825 5826 break; 5827 5828 case EXPR_VARIABLE: 5829 if (e->symtree && sym->name == e->symtree->n.sym->name) 5830 return true; 5831 5832 if (e->symtree->n.sym->ts.type == BT_UNKNOWN) 5833 gfc_set_default_type (e->symtree->n.sym, 0, NULL); 5834 break; 5835 5836 default: 5837 break; 5838 } 5839 5840 return false; 5841 } 5842 5843 5844 static bool 5845 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) 5846 { 5847 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); 5848 } 5849 5850 5851 /* Match a statement function declaration. It is so easy to match 5852 non-statement function statements with a MATCH_ERROR as opposed to 5853 MATCH_NO that we suppress error message in most cases. */ 5854 5855 match 5856 gfc_match_st_function (void) 5857 { 5858 gfc_error_buffer old_error; 5859 gfc_symbol *sym; 5860 gfc_expr *expr; 5861 match m; 5862 char name[GFC_MAX_SYMBOL_LEN + 1]; 5863 locus old_locus; 5864 bool fcn; 5865 gfc_formal_arglist *ptr; 5866 5867 /* Read the possible statement function name, and then check to see if 5868 a symbol is already present in the namespace. Record if it is a 5869 function and whether it has been referenced. */ 5870 fcn = false; 5871 ptr = NULL; 5872 old_locus = gfc_current_locus; 5873 m = gfc_match_name (name); 5874 if (m == MATCH_YES) 5875 { 5876 gfc_find_symbol (name, NULL, 1, &sym); 5877 if (sym && sym->attr.function && !sym->attr.referenced) 5878 { 5879 fcn = true; 5880 ptr = sym->formal; 5881 } 5882 } 5883 5884 gfc_current_locus = old_locus; 5885 m = gfc_match_symbol (&sym, 0); 5886 if (m != MATCH_YES) 5887 return m; 5888 5889 gfc_push_error (&old_error); 5890 5891 if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL)) 5892 goto undo_error; 5893 5894 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) 5895 goto undo_error; 5896 5897 m = gfc_match (" = %e%t", &expr); 5898 if (m == MATCH_NO) 5899 goto undo_error; 5900 5901 gfc_free_error (&old_error); 5902 5903 if (m == MATCH_ERROR) 5904 return m; 5905 5906 if (recursive_stmt_fcn (expr, sym)) 5907 { 5908 gfc_error ("Statement function at %L is recursive", &expr->where); 5909 return MATCH_ERROR; 5910 } 5911 5912 if (fcn && ptr != sym->formal) 5913 { 5914 gfc_error ("Statement function %qs at %L conflicts with function name", 5915 sym->name, &expr->where); 5916 return MATCH_ERROR; 5917 } 5918 5919 sym->value = expr; 5920 5921 if ((gfc_current_state () == COMP_FUNCTION 5922 || gfc_current_state () == COMP_SUBROUTINE) 5923 && gfc_state_stack->previous->state == COMP_INTERFACE) 5924 { 5925 gfc_error ("Statement function at %L cannot appear within an INTERFACE", 5926 &expr->where); 5927 return MATCH_ERROR; 5928 } 5929 5930 if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C")) 5931 return MATCH_ERROR; 5932 5933 return MATCH_YES; 5934 5935 undo_error: 5936 gfc_pop_error (&old_error); 5937 return MATCH_NO; 5938 } 5939 5940 5941 /* Match an assignment to a pointer function (F2008). This could, in 5942 general be ambiguous with a statement function. In this implementation 5943 it remains so if it is the first statement after the specification 5944 block. */ 5945 5946 match 5947 gfc_match_ptr_fcn_assign (void) 5948 { 5949 gfc_error_buffer old_error; 5950 locus old_loc; 5951 gfc_symbol *sym; 5952 gfc_expr *expr; 5953 match m; 5954 char name[GFC_MAX_SYMBOL_LEN + 1]; 5955 5956 old_loc = gfc_current_locus; 5957 m = gfc_match_name (name); 5958 if (m != MATCH_YES) 5959 return m; 5960 5961 gfc_find_symbol (name, NULL, 1, &sym); 5962 if (sym && sym->attr.flavor != FL_PROCEDURE) 5963 return MATCH_NO; 5964 5965 gfc_push_error (&old_error); 5966 5967 if (sym && sym->attr.function) 5968 goto match_actual_arglist; 5969 5970 gfc_current_locus = old_loc; 5971 m = gfc_match_symbol (&sym, 0); 5972 if (m != MATCH_YES) 5973 return m; 5974 5975 if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL)) 5976 goto undo_error; 5977 5978 match_actual_arglist: 5979 gfc_current_locus = old_loc; 5980 m = gfc_match (" %e", &expr); 5981 if (m != MATCH_YES) 5982 goto undo_error; 5983 5984 new_st.op = EXEC_ASSIGN; 5985 new_st.expr1 = expr; 5986 expr = NULL; 5987 5988 m = gfc_match (" = %e%t", &expr); 5989 if (m != MATCH_YES) 5990 goto undo_error; 5991 5992 new_st.expr2 = expr; 5993 return MATCH_YES; 5994 5995 undo_error: 5996 gfc_pop_error (&old_error); 5997 return MATCH_NO; 5998 } 5999 6000 6001 /***************** SELECT CASE subroutines ******************/ 6002 6003 /* Free a single case structure. */ 6004 6005 static void 6006 free_case (gfc_case *p) 6007 { 6008 if (p->low == p->high) 6009 p->high = NULL; 6010 gfc_free_expr (p->low); 6011 gfc_free_expr (p->high); 6012 free (p); 6013 } 6014 6015 6016 /* Free a list of case structures. */ 6017 6018 void 6019 gfc_free_case_list (gfc_case *p) 6020 { 6021 gfc_case *q; 6022 6023 for (; p; p = q) 6024 { 6025 q = p->next; 6026 free_case (p); 6027 } 6028 } 6029 6030 6031 /* Match a single case selector. Combining the requirements of F08:C830 6032 and F08:C832 (R838) means that the case-value must have either CHARACTER, 6033 INTEGER, or LOGICAL type. */ 6034 6035 static match 6036 match_case_selector (gfc_case **cp) 6037 { 6038 gfc_case *c; 6039 match m; 6040 6041 c = gfc_get_case (); 6042 c->where = gfc_current_locus; 6043 6044 if (gfc_match_char (':') == MATCH_YES) 6045 { 6046 m = gfc_match_init_expr (&c->high); 6047 if (m == MATCH_NO) 6048 goto need_expr; 6049 if (m == MATCH_ERROR) 6050 goto cleanup; 6051 6052 if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER 6053 && c->high->ts.type != BT_CHARACTER) 6054 { 6055 gfc_error ("Expression in CASE selector at %L cannot be %s", 6056 &c->high->where, gfc_typename (&c->high->ts)); 6057 goto cleanup; 6058 } 6059 } 6060 else 6061 { 6062 m = gfc_match_init_expr (&c->low); 6063 if (m == MATCH_ERROR) 6064 goto cleanup; 6065 if (m == MATCH_NO) 6066 goto need_expr; 6067 6068 if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER 6069 && c->low->ts.type != BT_CHARACTER) 6070 { 6071 gfc_error ("Expression in CASE selector at %L cannot be %s", 6072 &c->low->where, gfc_typename (&c->low->ts)); 6073 goto cleanup; 6074 } 6075 6076 /* If we're not looking at a ':' now, make a range out of a single 6077 target. Else get the upper bound for the case range. */ 6078 if (gfc_match_char (':') != MATCH_YES) 6079 c->high = c->low; 6080 else 6081 { 6082 m = gfc_match_init_expr (&c->high); 6083 if (m == MATCH_ERROR) 6084 goto cleanup; 6085 /* MATCH_NO is fine. It's OK if nothing is there! */ 6086 } 6087 } 6088 6089 *cp = c; 6090 return MATCH_YES; 6091 6092 need_expr: 6093 gfc_error ("Expected initialization expression in CASE at %C"); 6094 6095 cleanup: 6096 free_case (c); 6097 return MATCH_ERROR; 6098 } 6099 6100 6101 /* Match the end of a case statement. */ 6102 6103 static match 6104 match_case_eos (void) 6105 { 6106 char name[GFC_MAX_SYMBOL_LEN + 1]; 6107 match m; 6108 6109 if (gfc_match_eos () == MATCH_YES) 6110 return MATCH_YES; 6111 6112 /* If the case construct doesn't have a case-construct-name, we 6113 should have matched the EOS. */ 6114 if (!gfc_current_block ()) 6115 return MATCH_NO; 6116 6117 gfc_gobble_whitespace (); 6118 6119 m = gfc_match_name (name); 6120 if (m != MATCH_YES) 6121 return m; 6122 6123 if (strcmp (name, gfc_current_block ()->name) != 0) 6124 { 6125 gfc_error ("Expected block name %qs of SELECT construct at %C", 6126 gfc_current_block ()->name); 6127 return MATCH_ERROR; 6128 } 6129 6130 return gfc_match_eos (); 6131 } 6132 6133 6134 /* Match a SELECT statement. */ 6135 6136 match 6137 gfc_match_select (void) 6138 { 6139 gfc_expr *expr; 6140 match m; 6141 6142 m = gfc_match_label (); 6143 if (m == MATCH_ERROR) 6144 return m; 6145 6146 m = gfc_match (" select case ( %e )%t", &expr); 6147 if (m != MATCH_YES) 6148 return m; 6149 6150 new_st.op = EXEC_SELECT; 6151 new_st.expr1 = expr; 6152 6153 return MATCH_YES; 6154 } 6155 6156 6157 /* Transfer the selector typespec to the associate name. */ 6158 6159 static void 6160 copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) 6161 { 6162 gfc_ref *ref; 6163 gfc_symbol *assoc_sym; 6164 int rank = 0; 6165 6166 assoc_sym = associate->symtree->n.sym; 6167 6168 /* At this stage the expression rank and arrayspec dimensions have 6169 not been completely sorted out. We must get the expr2->rank 6170 right here, so that the correct class container is obtained. */ 6171 ref = selector->ref; 6172 while (ref && ref->next) 6173 ref = ref->next; 6174 6175 if (selector->ts.type == BT_CLASS 6176 && CLASS_DATA (selector) 6177 && CLASS_DATA (selector)->as 6178 && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK) 6179 { 6180 assoc_sym->attr.dimension = 1; 6181 assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); 6182 goto build_class_sym; 6183 } 6184 else if (selector->ts.type == BT_CLASS 6185 && CLASS_DATA (selector) 6186 && CLASS_DATA (selector)->as 6187 && ref && ref->type == REF_ARRAY) 6188 { 6189 /* Ensure that the array reference type is set. We cannot use 6190 gfc_resolve_expr at this point, so the usable parts of 6191 resolve.c(resolve_array_ref) are employed to do it. */ 6192 if (ref->u.ar.type == AR_UNKNOWN) 6193 { 6194 ref->u.ar.type = AR_ELEMENT; 6195 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) 6196 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE 6197 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR 6198 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN 6199 && ref->u.ar.start[i] && ref->u.ar.start[i]->rank)) 6200 { 6201 ref->u.ar.type = AR_SECTION; 6202 break; 6203 } 6204 } 6205 6206 if (ref->u.ar.type == AR_FULL) 6207 selector->rank = CLASS_DATA (selector)->as->rank; 6208 else if (ref->u.ar.type == AR_SECTION) 6209 selector->rank = ref->u.ar.dimen; 6210 else 6211 selector->rank = 0; 6212 6213 rank = selector->rank; 6214 } 6215 6216 if (rank) 6217 { 6218 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) 6219 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT 6220 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN 6221 && ref->u.ar.end[i] == NULL 6222 && ref->u.ar.stride[i] == NULL)) 6223 rank--; 6224 6225 if (rank) 6226 { 6227 assoc_sym->attr.dimension = 1; 6228 assoc_sym->as = gfc_get_array_spec (); 6229 assoc_sym->as->rank = rank; 6230 assoc_sym->as->type = AS_DEFERRED; 6231 } 6232 else 6233 assoc_sym->as = NULL; 6234 } 6235 else 6236 assoc_sym->as = NULL; 6237 6238 build_class_sym: 6239 if (selector->ts.type == BT_CLASS) 6240 { 6241 /* The correct class container has to be available. */ 6242 assoc_sym->ts.type = BT_CLASS; 6243 assoc_sym->ts.u.derived = CLASS_DATA (selector) 6244 ? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived; 6245 assoc_sym->attr.pointer = 1; 6246 gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as); 6247 } 6248 } 6249 6250 6251 /* Push the current selector onto the SELECT TYPE stack. */ 6252 6253 static void 6254 select_type_push (gfc_symbol *sel) 6255 { 6256 gfc_select_type_stack *top = gfc_get_select_type_stack (); 6257 top->selector = sel; 6258 top->tmp = NULL; 6259 top->prev = select_type_stack; 6260 6261 select_type_stack = top; 6262 } 6263 6264 6265 /* Set the temporary for the current intrinsic SELECT TYPE selector. */ 6266 6267 static gfc_symtree * 6268 select_intrinsic_set_tmp (gfc_typespec *ts) 6269 { 6270 char name[GFC_MAX_SYMBOL_LEN]; 6271 gfc_symtree *tmp; 6272 HOST_WIDE_INT charlen = 0; 6273 gfc_symbol *selector = select_type_stack->selector; 6274 gfc_symbol *sym; 6275 6276 if (ts->type == BT_CLASS || ts->type == BT_DERIVED) 6277 return NULL; 6278 6279 if (selector->ts.type == BT_CLASS && !selector->attr.class_ok) 6280 return NULL; 6281 6282 /* Case value == NULL corresponds to SELECT TYPE cases otherwise 6283 the values correspond to SELECT rank cases. */ 6284 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length 6285 && ts->u.cl->length->expr_type == EXPR_CONSTANT) 6286 charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 6287 6288 if (ts->type != BT_CHARACTER) 6289 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), 6290 ts->kind); 6291 else 6292 snprintf (name, sizeof (name), 6293 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", 6294 gfc_basic_typename (ts->type), charlen, ts->kind); 6295 6296 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); 6297 sym = tmp->n.sym; 6298 gfc_add_type (sym, ts, NULL); 6299 6300 /* Copy across the array spec to the selector. */ 6301 if (selector->ts.type == BT_CLASS 6302 && (CLASS_DATA (selector)->attr.dimension 6303 || CLASS_DATA (selector)->attr.codimension)) 6304 { 6305 sym->attr.pointer = 1; 6306 sym->attr.dimension = CLASS_DATA (selector)->attr.dimension; 6307 sym->attr.codimension = CLASS_DATA (selector)->attr.codimension; 6308 sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); 6309 } 6310 6311 gfc_set_sym_referenced (sym); 6312 gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); 6313 sym->attr.select_type_temporary = 1; 6314 6315 return tmp; 6316 } 6317 6318 6319 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */ 6320 6321 static void 6322 select_type_set_tmp (gfc_typespec *ts) 6323 { 6324 char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; 6325 gfc_symtree *tmp = NULL; 6326 gfc_symbol *selector = select_type_stack->selector; 6327 gfc_symbol *sym; 6328 6329 if (!ts) 6330 { 6331 select_type_stack->tmp = NULL; 6332 return; 6333 } 6334 6335 tmp = select_intrinsic_set_tmp (ts); 6336 6337 if (tmp == NULL) 6338 { 6339 if (!ts->u.derived) 6340 return; 6341 6342 if (ts->type == BT_CLASS) 6343 sprintf (name, "__tmp_class_%s", ts->u.derived->name); 6344 else 6345 sprintf (name, "__tmp_type_%s", ts->u.derived->name); 6346 6347 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); 6348 sym = tmp->n.sym; 6349 gfc_add_type (sym, ts, NULL); 6350 6351 if (selector->ts.type == BT_CLASS && selector->attr.class_ok 6352 && selector->ts.u.derived && CLASS_DATA (selector)) 6353 { 6354 sym->attr.pointer 6355 = CLASS_DATA (selector)->attr.class_pointer; 6356 6357 /* Copy across the array spec to the selector. */ 6358 if (CLASS_DATA (selector)->attr.dimension 6359 || CLASS_DATA (selector)->attr.codimension) 6360 { 6361 sym->attr.dimension 6362 = CLASS_DATA (selector)->attr.dimension; 6363 sym->attr.codimension 6364 = CLASS_DATA (selector)->attr.codimension; 6365 if (CLASS_DATA (selector)->as->type != AS_EXPLICIT) 6366 sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); 6367 else 6368 { 6369 sym->as = gfc_get_array_spec(); 6370 sym->as->rank = CLASS_DATA (selector)->as->rank; 6371 sym->as->type = AS_DEFERRED; 6372 } 6373 } 6374 } 6375 6376 gfc_set_sym_referenced (sym); 6377 gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); 6378 sym->attr.select_type_temporary = 1; 6379 6380 if (ts->type == BT_CLASS) 6381 gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); 6382 } 6383 else 6384 sym = tmp->n.sym; 6385 6386 6387 /* Add an association for it, so the rest of the parser knows it is 6388 an associate-name. The target will be set during resolution. */ 6389 sym->assoc = gfc_get_association_list (); 6390 sym->assoc->dangling = 1; 6391 sym->assoc->st = tmp; 6392 6393 select_type_stack->tmp = tmp; 6394 } 6395 6396 6397 /* Match a SELECT TYPE statement. */ 6398 6399 match 6400 gfc_match_select_type (void) 6401 { 6402 gfc_expr *expr1, *expr2 = NULL; 6403 match m; 6404 char name[GFC_MAX_SYMBOL_LEN + 1]; 6405 bool class_array; 6406 gfc_symbol *sym; 6407 gfc_namespace *ns = gfc_current_ns; 6408 6409 m = gfc_match_label (); 6410 if (m == MATCH_ERROR) 6411 return m; 6412 6413 m = gfc_match (" select type ( "); 6414 if (m != MATCH_YES) 6415 return m; 6416 6417 if (gfc_current_state() == COMP_MODULE 6418 || gfc_current_state() == COMP_SUBMODULE) 6419 { 6420 gfc_error ("SELECT TYPE at %C cannot appear in this scope"); 6421 return MATCH_ERROR; 6422 } 6423 6424 gfc_current_ns = gfc_build_block_ns (ns); 6425 m = gfc_match (" %n => %e", name, &expr2); 6426 if (m == MATCH_YES) 6427 { 6428 expr1 = gfc_get_expr (); 6429 expr1->expr_type = EXPR_VARIABLE; 6430 expr1->where = expr2->where; 6431 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) 6432 { 6433 m = MATCH_ERROR; 6434 goto cleanup; 6435 } 6436 6437 sym = expr1->symtree->n.sym; 6438 if (expr2->ts.type == BT_UNKNOWN) 6439 sym->attr.untyped = 1; 6440 else 6441 copy_ts_from_selector_to_associate (expr1, expr2); 6442 6443 sym->attr.flavor = FL_VARIABLE; 6444 sym->attr.referenced = 1; 6445 sym->attr.class_ok = 1; 6446 } 6447 else 6448 { 6449 m = gfc_match (" %e ", &expr1); 6450 if (m != MATCH_YES) 6451 { 6452 std::swap (ns, gfc_current_ns); 6453 gfc_free_namespace (ns); 6454 return m; 6455 } 6456 } 6457 6458 m = gfc_match (" )%t"); 6459 if (m != MATCH_YES) 6460 { 6461 gfc_error ("parse error in SELECT TYPE statement at %C"); 6462 goto cleanup; 6463 } 6464 6465 /* This ghastly expression seems to be needed to distinguish a CLASS 6466 array, which can have a reference, from other expressions that 6467 have references, such as derived type components, and are not 6468 allowed by the standard. 6469 TODO: see if it is sufficient to exclude component and substring 6470 references. */ 6471 class_array = (expr1->expr_type == EXPR_VARIABLE 6472 && expr1->ts.type == BT_CLASS 6473 && CLASS_DATA (expr1) 6474 && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) 6475 && (CLASS_DATA (expr1)->attr.dimension 6476 || CLASS_DATA (expr1)->attr.codimension) 6477 && expr1->ref 6478 && expr1->ref->type == REF_ARRAY 6479 && expr1->ref->u.ar.type == AR_FULL 6480 && expr1->ref->next == NULL); 6481 6482 /* Check for F03:C811 (F08:C835). */ 6483 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE 6484 || (!class_array && expr1->ref != NULL))) 6485 { 6486 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " 6487 "use associate-name=>"); 6488 m = MATCH_ERROR; 6489 goto cleanup; 6490 } 6491 6492 new_st.op = EXEC_SELECT_TYPE; 6493 new_st.expr1 = expr1; 6494 new_st.expr2 = expr2; 6495 new_st.ext.block.ns = gfc_current_ns; 6496 6497 select_type_push (expr1->symtree->n.sym); 6498 gfc_current_ns = ns; 6499 6500 return MATCH_YES; 6501 6502 cleanup: 6503 gfc_free_expr (expr1); 6504 gfc_free_expr (expr2); 6505 gfc_undo_symbols (); 6506 std::swap (ns, gfc_current_ns); 6507 gfc_free_namespace (ns); 6508 return m; 6509 } 6510 6511 6512 /* Set the temporary for the current intrinsic SELECT RANK selector. */ 6513 6514 static void 6515 select_rank_set_tmp (gfc_typespec *ts, int *case_value) 6516 { 6517 char name[2 * GFC_MAX_SYMBOL_LEN]; 6518 char tname[GFC_MAX_SYMBOL_LEN + 7]; 6519 gfc_symtree *tmp; 6520 gfc_symbol *selector = select_type_stack->selector; 6521 gfc_symbol *sym; 6522 gfc_symtree *st; 6523 HOST_WIDE_INT charlen = 0; 6524 6525 if (case_value == NULL) 6526 return; 6527 6528 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length 6529 && ts->u.cl->length->expr_type == EXPR_CONSTANT) 6530 charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 6531 6532 if (ts->type == BT_CLASS) 6533 sprintf (tname, "class_%s", ts->u.derived->name); 6534 else if (ts->type == BT_DERIVED) 6535 sprintf (tname, "type_%s", ts->u.derived->name); 6536 else if (ts->type != BT_CHARACTER) 6537 sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind); 6538 else 6539 sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", 6540 gfc_basic_typename (ts->type), charlen, ts->kind); 6541 6542 /* Case value == NULL corresponds to SELECT TYPE cases otherwise 6543 the values correspond to SELECT rank cases. */ 6544 if (*case_value >=0) 6545 sprintf (name, "__tmp_%s_rank_%d", tname, *case_value); 6546 else 6547 sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value); 6548 6549 gfc_find_sym_tree (name, gfc_current_ns, 0, &st); 6550 if (st) 6551 return; 6552 6553 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); 6554 sym = tmp->n.sym; 6555 gfc_add_type (sym, ts, NULL); 6556 6557 /* Copy across the array spec to the selector. */ 6558 if (selector->ts.type == BT_CLASS) 6559 { 6560 sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; 6561 sym->attr.pointer = CLASS_DATA (selector)->attr.pointer; 6562 sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable; 6563 sym->attr.target = CLASS_DATA (selector)->attr.target; 6564 sym->attr.class_ok = 0; 6565 if (case_value && *case_value != 0) 6566 { 6567 sym->attr.dimension = 1; 6568 sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); 6569 if (*case_value > 0) 6570 { 6571 sym->as->type = AS_DEFERRED; 6572 sym->as->rank = *case_value; 6573 } 6574 else if (*case_value == -1) 6575 { 6576 sym->as->type = AS_ASSUMED_SIZE; 6577 sym->as->rank = 1; 6578 } 6579 } 6580 } 6581 else 6582 { 6583 sym->attr.pointer = selector->attr.pointer; 6584 sym->attr.allocatable = selector->attr.allocatable; 6585 sym->attr.target = selector->attr.target; 6586 if (case_value && *case_value != 0) 6587 { 6588 sym->attr.dimension = 1; 6589 sym->as = gfc_copy_array_spec (selector->as); 6590 if (*case_value > 0) 6591 { 6592 sym->as->type = AS_DEFERRED; 6593 sym->as->rank = *case_value; 6594 } 6595 else if (*case_value == -1) 6596 { 6597 sym->as->type = AS_ASSUMED_SIZE; 6598 sym->as->rank = 1; 6599 } 6600 } 6601 } 6602 6603 gfc_set_sym_referenced (sym); 6604 gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); 6605 sym->attr.select_type_temporary = 1; 6606 if (case_value) 6607 sym->attr.select_rank_temporary = 1; 6608 6609 if (ts->type == BT_CLASS) 6610 gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); 6611 6612 /* Add an association for it, so the rest of the parser knows it is 6613 an associate-name. The target will be set during resolution. */ 6614 sym->assoc = gfc_get_association_list (); 6615 sym->assoc->dangling = 1; 6616 sym->assoc->st = tmp; 6617 6618 select_type_stack->tmp = tmp; 6619 } 6620 6621 6622 /* Match a SELECT RANK statement. */ 6623 6624 match 6625 gfc_match_select_rank (void) 6626 { 6627 gfc_expr *expr1, *expr2 = NULL; 6628 match m; 6629 char name[GFC_MAX_SYMBOL_LEN + 1]; 6630 gfc_symbol *sym, *sym2; 6631 gfc_namespace *ns = gfc_current_ns; 6632 gfc_array_spec *as = NULL; 6633 6634 m = gfc_match_label (); 6635 if (m == MATCH_ERROR) 6636 return m; 6637 6638 m = gfc_match (" select rank ( "); 6639 if (m != MATCH_YES) 6640 return m; 6641 6642 if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C")) 6643 return MATCH_NO; 6644 6645 gfc_current_ns = gfc_build_block_ns (ns); 6646 m = gfc_match (" %n => %e", name, &expr2); 6647 if (m == MATCH_YES) 6648 { 6649 expr1 = gfc_get_expr (); 6650 expr1->expr_type = EXPR_VARIABLE; 6651 expr1->where = expr2->where; 6652 expr1->ref = gfc_copy_ref (expr2->ref); 6653 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) 6654 { 6655 m = MATCH_ERROR; 6656 goto cleanup; 6657 } 6658 6659 sym = expr1->symtree->n.sym; 6660 6661 if (expr2->symtree) 6662 { 6663 sym2 = expr2->symtree->n.sym; 6664 as = (sym2->ts.type == BT_CLASS 6665 && CLASS_DATA (sym2)) ? CLASS_DATA (sym2)->as : sym2->as; 6666 } 6667 6668 if (expr2->expr_type != EXPR_VARIABLE 6669 || !(as && as->type == AS_ASSUMED_RANK)) 6670 { 6671 gfc_error ("The SELECT RANK selector at %C must be an assumed " 6672 "rank variable"); 6673 m = MATCH_ERROR; 6674 goto cleanup; 6675 } 6676 6677 if (expr2->ts.type == BT_CLASS && CLASS_DATA (sym2)) 6678 { 6679 copy_ts_from_selector_to_associate (expr1, expr2); 6680 6681 sym->attr.flavor = FL_VARIABLE; 6682 sym->attr.referenced = 1; 6683 sym->attr.class_ok = 1; 6684 CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable; 6685 CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer; 6686 CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target; 6687 sym->attr.pointer = 1; 6688 } 6689 else 6690 { 6691 sym->ts = sym2->ts; 6692 sym->as = gfc_copy_array_spec (sym2->as); 6693 sym->attr.dimension = 1; 6694 6695 sym->attr.flavor = FL_VARIABLE; 6696 sym->attr.referenced = 1; 6697 sym->attr.class_ok = sym2->attr.class_ok; 6698 sym->attr.allocatable = sym2->attr.allocatable; 6699 sym->attr.pointer = sym2->attr.pointer; 6700 sym->attr.target = sym2->attr.target; 6701 } 6702 } 6703 else 6704 { 6705 m = gfc_match (" %e ", &expr1); 6706 6707 if (m != MATCH_YES) 6708 { 6709 gfc_undo_symbols (); 6710 std::swap (ns, gfc_current_ns); 6711 gfc_free_namespace (ns); 6712 return m; 6713 } 6714 6715 if (expr1->symtree) 6716 { 6717 sym = expr1->symtree->n.sym; 6718 as = (sym->ts.type == BT_CLASS 6719 && CLASS_DATA (sym)) ? CLASS_DATA (sym)->as : sym->as; 6720 } 6721 6722 if (expr1->expr_type != EXPR_VARIABLE 6723 || !(as && as->type == AS_ASSUMED_RANK)) 6724 { 6725 gfc_error("The SELECT RANK selector at %C must be an assumed " 6726 "rank variable"); 6727 m = MATCH_ERROR; 6728 goto cleanup; 6729 } 6730 } 6731 6732 m = gfc_match (" )%t"); 6733 if (m != MATCH_YES) 6734 { 6735 gfc_error ("parse error in SELECT RANK statement at %C"); 6736 goto cleanup; 6737 } 6738 6739 new_st.op = EXEC_SELECT_RANK; 6740 new_st.expr1 = expr1; 6741 new_st.expr2 = expr2; 6742 new_st.ext.block.ns = gfc_current_ns; 6743 6744 select_type_push (expr1->symtree->n.sym); 6745 gfc_current_ns = ns; 6746 6747 return MATCH_YES; 6748 6749 cleanup: 6750 gfc_free_expr (expr1); 6751 gfc_free_expr (expr2); 6752 gfc_undo_symbols (); 6753 std::swap (ns, gfc_current_ns); 6754 gfc_free_namespace (ns); 6755 return m; 6756 } 6757 6758 6759 /* Match a CASE statement. */ 6760 6761 match 6762 gfc_match_case (void) 6763 { 6764 gfc_case *c, *head, *tail; 6765 match m; 6766 6767 head = tail = NULL; 6768 6769 if (gfc_current_state () != COMP_SELECT) 6770 { 6771 gfc_error ("Unexpected CASE statement at %C"); 6772 return MATCH_ERROR; 6773 } 6774 6775 if (gfc_match ("% default") == MATCH_YES) 6776 { 6777 m = match_case_eos (); 6778 if (m == MATCH_NO) 6779 goto syntax; 6780 if (m == MATCH_ERROR) 6781 goto cleanup; 6782 6783 new_st.op = EXEC_SELECT; 6784 c = gfc_get_case (); 6785 c->where = gfc_current_locus; 6786 new_st.ext.block.case_list = c; 6787 return MATCH_YES; 6788 } 6789 6790 if (gfc_match_char ('(') != MATCH_YES) 6791 goto syntax; 6792 6793 for (;;) 6794 { 6795 if (match_case_selector (&c) == MATCH_ERROR) 6796 goto cleanup; 6797 6798 if (head == NULL) 6799 head = c; 6800 else 6801 tail->next = c; 6802 6803 tail = c; 6804 6805 if (gfc_match_char (')') == MATCH_YES) 6806 break; 6807 if (gfc_match_char (',') != MATCH_YES) 6808 goto syntax; 6809 } 6810 6811 m = match_case_eos (); 6812 if (m == MATCH_NO) 6813 goto syntax; 6814 if (m == MATCH_ERROR) 6815 goto cleanup; 6816 6817 new_st.op = EXEC_SELECT; 6818 new_st.ext.block.case_list = head; 6819 6820 return MATCH_YES; 6821 6822 syntax: 6823 gfc_error ("Syntax error in CASE specification at %C"); 6824 6825 cleanup: 6826 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ 6827 return MATCH_ERROR; 6828 } 6829 6830 6831 /* Match a TYPE IS statement. */ 6832 6833 match 6834 gfc_match_type_is (void) 6835 { 6836 gfc_case *c = NULL; 6837 match m; 6838 6839 if (gfc_current_state () != COMP_SELECT_TYPE) 6840 { 6841 gfc_error ("Unexpected TYPE IS statement at %C"); 6842 return MATCH_ERROR; 6843 } 6844 6845 if (gfc_match_char ('(') != MATCH_YES) 6846 goto syntax; 6847 6848 c = gfc_get_case (); 6849 c->where = gfc_current_locus; 6850 6851 m = gfc_match_type_spec (&c->ts); 6852 if (m == MATCH_NO) 6853 goto syntax; 6854 if (m == MATCH_ERROR) 6855 goto cleanup; 6856 6857 if (gfc_match_char (')') != MATCH_YES) 6858 goto syntax; 6859 6860 m = match_case_eos (); 6861 if (m == MATCH_NO) 6862 goto syntax; 6863 if (m == MATCH_ERROR) 6864 goto cleanup; 6865 6866 new_st.op = EXEC_SELECT_TYPE; 6867 new_st.ext.block.case_list = c; 6868 6869 if (c->ts.type == BT_DERIVED && c->ts.u.derived 6870 && (c->ts.u.derived->attr.sequence 6871 || c->ts.u.derived->attr.is_bind_c)) 6872 { 6873 gfc_error ("The type-spec shall not specify a sequence derived " 6874 "type or a type with the BIND attribute in SELECT " 6875 "TYPE at %C [F2003:C815]"); 6876 return MATCH_ERROR; 6877 } 6878 6879 if (c->ts.type == BT_DERIVED 6880 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type 6881 && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived) 6882 != SPEC_ASSUMED) 6883 { 6884 gfc_error ("All the LEN type parameters in the TYPE IS statement " 6885 "at %C must be ASSUMED"); 6886 return MATCH_ERROR; 6887 } 6888 6889 /* Create temporary variable. */ 6890 select_type_set_tmp (&c->ts); 6891 6892 return MATCH_YES; 6893 6894 syntax: 6895 gfc_error ("Syntax error in TYPE IS specification at %C"); 6896 6897 cleanup: 6898 if (c != NULL) 6899 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ 6900 return MATCH_ERROR; 6901 } 6902 6903 6904 /* Match a CLASS IS or CLASS DEFAULT statement. */ 6905 6906 match 6907 gfc_match_class_is (void) 6908 { 6909 gfc_case *c = NULL; 6910 match m; 6911 6912 if (gfc_current_state () != COMP_SELECT_TYPE) 6913 return MATCH_NO; 6914 6915 if (gfc_match ("% default") == MATCH_YES) 6916 { 6917 m = match_case_eos (); 6918 if (m == MATCH_NO) 6919 goto syntax; 6920 if (m == MATCH_ERROR) 6921 goto cleanup; 6922 6923 new_st.op = EXEC_SELECT_TYPE; 6924 c = gfc_get_case (); 6925 c->where = gfc_current_locus; 6926 c->ts.type = BT_UNKNOWN; 6927 new_st.ext.block.case_list = c; 6928 select_type_set_tmp (NULL); 6929 return MATCH_YES; 6930 } 6931 6932 m = gfc_match ("% is"); 6933 if (m == MATCH_NO) 6934 goto syntax; 6935 if (m == MATCH_ERROR) 6936 goto cleanup; 6937 6938 if (gfc_match_char ('(') != MATCH_YES) 6939 goto syntax; 6940 6941 c = gfc_get_case (); 6942 c->where = gfc_current_locus; 6943 6944 m = match_derived_type_spec (&c->ts); 6945 if (m == MATCH_NO) 6946 goto syntax; 6947 if (m == MATCH_ERROR) 6948 goto cleanup; 6949 6950 if (c->ts.type == BT_DERIVED) 6951 c->ts.type = BT_CLASS; 6952 6953 if (gfc_match_char (')') != MATCH_YES) 6954 goto syntax; 6955 6956 m = match_case_eos (); 6957 if (m == MATCH_NO) 6958 goto syntax; 6959 if (m == MATCH_ERROR) 6960 goto cleanup; 6961 6962 new_st.op = EXEC_SELECT_TYPE; 6963 new_st.ext.block.case_list = c; 6964 6965 /* Create temporary variable. */ 6966 select_type_set_tmp (&c->ts); 6967 6968 return MATCH_YES; 6969 6970 syntax: 6971 gfc_error ("Syntax error in CLASS IS specification at %C"); 6972 6973 cleanup: 6974 if (c != NULL) 6975 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ 6976 return MATCH_ERROR; 6977 } 6978 6979 6980 /* Match a RANK statement. */ 6981 6982 match 6983 gfc_match_rank_is (void) 6984 { 6985 gfc_case *c = NULL; 6986 match m; 6987 int case_value; 6988 6989 if (gfc_current_state () != COMP_SELECT_RANK) 6990 { 6991 gfc_error ("Unexpected RANK statement at %C"); 6992 return MATCH_ERROR; 6993 } 6994 6995 if (gfc_match ("% default") == MATCH_YES) 6996 { 6997 m = match_case_eos (); 6998 if (m == MATCH_NO) 6999 goto syntax; 7000 if (m == MATCH_ERROR) 7001 goto cleanup; 7002 7003 new_st.op = EXEC_SELECT_RANK; 7004 c = gfc_get_case (); 7005 c->ts.type = BT_UNKNOWN; 7006 c->where = gfc_current_locus; 7007 new_st.ext.block.case_list = c; 7008 select_type_stack->tmp = NULL; 7009 return MATCH_YES; 7010 } 7011 7012 if (gfc_match_char ('(') != MATCH_YES) 7013 goto syntax; 7014 7015 c = gfc_get_case (); 7016 c->where = gfc_current_locus; 7017 c->ts = select_type_stack->selector->ts; 7018 7019 m = gfc_match_expr (&c->low); 7020 if (m == MATCH_NO) 7021 { 7022 if (gfc_match_char ('*') == MATCH_YES) 7023 c->low = gfc_get_int_expr (gfc_default_integer_kind, 7024 NULL, -1); 7025 else 7026 goto syntax; 7027 7028 case_value = -1; 7029 } 7030 else if (m == MATCH_YES) 7031 { 7032 /* F2018: R1150 */ 7033 if (c->low->expr_type != EXPR_CONSTANT 7034 || c->low->ts.type != BT_INTEGER 7035 || c->low->rank) 7036 { 7037 gfc_error ("The SELECT RANK CASE expression at %C must be a " 7038 "scalar, integer constant"); 7039 goto cleanup; 7040 } 7041 7042 case_value = (int) mpz_get_si (c->low->value.integer); 7043 /* F2018: C1151 */ 7044 if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS)) 7045 { 7046 gfc_error ("The value of the SELECT RANK CASE expression at " 7047 "%C must not be less than zero or greater than %d", 7048 GFC_MAX_DIMENSIONS); 7049 goto cleanup; 7050 } 7051 } 7052 else 7053 goto cleanup; 7054 7055 if (gfc_match_char (')') != MATCH_YES) 7056 goto syntax; 7057 7058 m = match_case_eos (); 7059 if (m == MATCH_NO) 7060 goto syntax; 7061 if (m == MATCH_ERROR) 7062 goto cleanup; 7063 7064 new_st.op = EXEC_SELECT_RANK; 7065 new_st.ext.block.case_list = c; 7066 7067 /* Create temporary variable. Recycle the select type code. */ 7068 select_rank_set_tmp (&c->ts, &case_value); 7069 7070 return MATCH_YES; 7071 7072 syntax: 7073 gfc_error ("Syntax error in RANK specification at %C"); 7074 7075 cleanup: 7076 if (c != NULL) 7077 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ 7078 return MATCH_ERROR; 7079 } 7080 7081 /********************* WHERE subroutines ********************/ 7082 7083 /* Match the rest of a simple WHERE statement that follows an IF statement. 7084 */ 7085 7086 static match 7087 match_simple_where (void) 7088 { 7089 gfc_expr *expr; 7090 gfc_code *c; 7091 match m; 7092 7093 m = gfc_match (" ( %e )", &expr); 7094 if (m != MATCH_YES) 7095 return m; 7096 7097 m = gfc_match_assignment (); 7098 if (m == MATCH_NO) 7099 goto syntax; 7100 if (m == MATCH_ERROR) 7101 goto cleanup; 7102 7103 if (gfc_match_eos () != MATCH_YES) 7104 goto syntax; 7105 7106 c = gfc_get_code (EXEC_WHERE); 7107 c->expr1 = expr; 7108 7109 c->next = XCNEW (gfc_code); 7110 *c->next = new_st; 7111 c->next->loc = gfc_current_locus; 7112 gfc_clear_new_st (); 7113 7114 new_st.op = EXEC_WHERE; 7115 new_st.block = c; 7116 7117 return MATCH_YES; 7118 7119 syntax: 7120 gfc_syntax_error (ST_WHERE); 7121 7122 cleanup: 7123 gfc_free_expr (expr); 7124 return MATCH_ERROR; 7125 } 7126 7127 7128 /* Match a WHERE statement. */ 7129 7130 match 7131 gfc_match_where (gfc_statement *st) 7132 { 7133 gfc_expr *expr; 7134 match m0, m; 7135 gfc_code *c; 7136 7137 m0 = gfc_match_label (); 7138 if (m0 == MATCH_ERROR) 7139 return m0; 7140 7141 m = gfc_match (" where ( %e )", &expr); 7142 if (m != MATCH_YES) 7143 return m; 7144 7145 if (gfc_match_eos () == MATCH_YES) 7146 { 7147 *st = ST_WHERE_BLOCK; 7148 new_st.op = EXEC_WHERE; 7149 new_st.expr1 = expr; 7150 return MATCH_YES; 7151 } 7152 7153 m = gfc_match_assignment (); 7154 if (m == MATCH_NO) 7155 gfc_syntax_error (ST_WHERE); 7156 7157 if (m != MATCH_YES) 7158 { 7159 gfc_free_expr (expr); 7160 return MATCH_ERROR; 7161 } 7162 7163 /* We've got a simple WHERE statement. */ 7164 *st = ST_WHERE; 7165 c = gfc_get_code (EXEC_WHERE); 7166 c->expr1 = expr; 7167 7168 /* Put in the assignment. It will not be processed by add_statement, so we 7169 need to copy the location here. */ 7170 7171 c->next = XCNEW (gfc_code); 7172 *c->next = new_st; 7173 c->next->loc = gfc_current_locus; 7174 gfc_clear_new_st (); 7175 7176 new_st.op = EXEC_WHERE; 7177 new_st.block = c; 7178 7179 return MATCH_YES; 7180 } 7181 7182 7183 /* Match an ELSEWHERE statement. We leave behind a WHERE node in 7184 new_st if successful. */ 7185 7186 match 7187 gfc_match_elsewhere (void) 7188 { 7189 char name[GFC_MAX_SYMBOL_LEN + 1]; 7190 gfc_expr *expr; 7191 match m; 7192 7193 if (gfc_current_state () != COMP_WHERE) 7194 { 7195 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block"); 7196 return MATCH_ERROR; 7197 } 7198 7199 expr = NULL; 7200 7201 if (gfc_match_char ('(') == MATCH_YES) 7202 { 7203 m = gfc_match_expr (&expr); 7204 if (m == MATCH_NO) 7205 goto syntax; 7206 if (m == MATCH_ERROR) 7207 return MATCH_ERROR; 7208 7209 if (gfc_match_char (')') != MATCH_YES) 7210 goto syntax; 7211 } 7212 7213 if (gfc_match_eos () != MATCH_YES) 7214 { 7215 /* Only makes sense if we have a where-construct-name. */ 7216 if (!gfc_current_block ()) 7217 { 7218 m = MATCH_ERROR; 7219 goto cleanup; 7220 } 7221 /* Better be a name at this point. */ 7222 m = gfc_match_name (name); 7223 if (m == MATCH_NO) 7224 goto syntax; 7225 if (m == MATCH_ERROR) 7226 goto cleanup; 7227 7228 if (gfc_match_eos () != MATCH_YES) 7229 goto syntax; 7230 7231 if (strcmp (name, gfc_current_block ()->name) != 0) 7232 { 7233 gfc_error ("Label %qs at %C doesn't match WHERE label %qs", 7234 name, gfc_current_block ()->name); 7235 goto cleanup; 7236 } 7237 } 7238 7239 new_st.op = EXEC_WHERE; 7240 new_st.expr1 = expr; 7241 return MATCH_YES; 7242 7243 syntax: 7244 gfc_syntax_error (ST_ELSEWHERE); 7245 7246 cleanup: 7247 gfc_free_expr (expr); 7248 return MATCH_ERROR; 7249 } 7250