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