| /* Matching subroutines in all sizes, shapes and colors. |
| Copyright (C) 2000-2022 Free Software Foundation, Inc. |
| Contributed by Andy Vaught |
| |
| This file is part of GCC. |
| |
| GCC is free software; you can redistribute it and/or modify it under |
| the terms of the GNU General Public License as published by the Free |
| Software Foundation; either version 3, or (at your option) any later |
| version. |
| |
| GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GCC; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "options.h" |
| #include "gfortran.h" |
| #include "match.h" |
| #include "parse.h" |
| |
| int gfc_matching_ptr_assignment = 0; |
| int gfc_matching_procptr_assignment = 0; |
| bool gfc_matching_prefix = false; |
| |
| /* Stack of SELECT TYPE statements. */ |
| gfc_select_type_stack *select_type_stack = NULL; |
| |
| /* List of type parameter expressions. */ |
| gfc_actual_arglist *type_param_spec_list; |
| |
| /* For debugging and diagnostic purposes. Return the textual representation |
| of the intrinsic operator OP. */ |
| const char * |
| gfc_op2string (gfc_intrinsic_op op) |
| { |
| switch (op) |
| { |
| case INTRINSIC_UPLUS: |
| case INTRINSIC_PLUS: |
| return "+"; |
| |
| case INTRINSIC_UMINUS: |
| case INTRINSIC_MINUS: |
| return "-"; |
| |
| case INTRINSIC_POWER: |
| return "**"; |
| case INTRINSIC_CONCAT: |
| return "//"; |
| case INTRINSIC_TIMES: |
| return "*"; |
| case INTRINSIC_DIVIDE: |
| return "/"; |
| |
| case INTRINSIC_AND: |
| return ".and."; |
| case INTRINSIC_OR: |
| return ".or."; |
| case INTRINSIC_EQV: |
| return ".eqv."; |
| case INTRINSIC_NEQV: |
| return ".neqv."; |
| |
| case INTRINSIC_EQ_OS: |
| return ".eq."; |
| case INTRINSIC_EQ: |
| return "=="; |
| case INTRINSIC_NE_OS: |
| return ".ne."; |
| case INTRINSIC_NE: |
| return "/="; |
| case INTRINSIC_GE_OS: |
| return ".ge."; |
| case INTRINSIC_GE: |
| return ">="; |
| case INTRINSIC_LE_OS: |
| return ".le."; |
| case INTRINSIC_LE: |
| return "<="; |
| case INTRINSIC_LT_OS: |
| return ".lt."; |
| case INTRINSIC_LT: |
| return "<"; |
| case INTRINSIC_GT_OS: |
| return ".gt."; |
| case INTRINSIC_GT: |
| return ">"; |
| case INTRINSIC_NOT: |
| return ".not."; |
| |
| case INTRINSIC_ASSIGN: |
| return "="; |
| |
| case INTRINSIC_PARENTHESES: |
| return "parens"; |
| |
| case INTRINSIC_NONE: |
| return "none"; |
| |
| /* DTIO */ |
| case INTRINSIC_FORMATTED: |
| return "formatted"; |
| case INTRINSIC_UNFORMATTED: |
| return "unformatted"; |
| |
| default: |
| break; |
| } |
| |
| gfc_internal_error ("gfc_op2string(): Bad code"); |
| /* Not reached. */ |
| } |
| |
| |
| /******************** Generic matching subroutines ************************/ |
| |
| /* Matches a member separator. With standard FORTRAN this is '%', but with |
| DEC structures we must carefully match dot ('.'). |
| Because operators are spelled ".op.", a dotted string such as "x.y.z..." |
| can be either a component reference chain or a combination of binary |
| operations. |
| There is no real way to win because the string may be grammatically |
| ambiguous. The following rules help avoid ambiguities - they match |
| some behavior of other (older) compilers. If the rules here are changed |
| the test cases should be updated. If the user has problems with these rules |
| they probably deserve the consequences. Consider "x.y.z": |
| (1) If any user defined operator ".y." exists, this is always y(x,z) |
| (even if ".y." is the wrong type and/or x has a member y). |
| (2) Otherwise if x has a member y, and y is itself a derived type, |
| this is (x->y)->z, even if an intrinsic operator exists which |
| can handle (x,z). |
| (3) If x has no member y or (x->y) is not a derived type but ".y." |
| is an intrinsic operator (such as ".eq."), this is y(x,z). |
| (4) Lastly if there is no operator ".y." and x has no member "y", it is an |
| error. |
| It is worth noting that the logic here does not support mixed use of member |
| accessors within a single string. That is, even if x has component y and y |
| has component z, the following are all syntax errors: |
| "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z" |
| */ |
| |
| match |
| gfc_match_member_sep(gfc_symbol *sym) |
| { |
| char name[GFC_MAX_SYMBOL_LEN + 1]; |
| locus dot_loc, start_loc; |
| gfc_intrinsic_op iop; |
| match m; |
| gfc_symbol *tsym; |
| gfc_component *c = NULL; |
| |
| /* What a relief: '%' is an unambiguous member separator. */ |
| if (gfc_match_char ('%') == MATCH_YES) |
| return MATCH_YES; |
| |
| /* Beware ye who enter here. */ |
| if (!flag_dec_structure || !sym) |
| return MATCH_NO; |
| |
| tsym = NULL; |
| |
| /* We may be given either a derived type variable or the derived type |
| declaration itself (which actually contains the components); |
| we need the latter to search for components. */ |
| if (gfc_fl_struct (sym->attr.flavor)) |
| tsym = sym; |
| else if (gfc_bt_struct (sym->ts.type)) |
| tsym = sym->ts.u.derived; |
| |
| iop = INTRINSIC_NONE; |
| name[0] = '\0'; |
| m = MATCH_NO; |
| |
| /* If we have to reject come back here later. */ |
| start_loc = gfc_current_locus; |
| |
| /* Look for a component access next. */ |
| if (gfc_match_char ('.') != MATCH_YES) |
| return MATCH_NO; |
| |
| /* If we accept, come back here. */ |
| dot_loc = gfc_current_locus; |
| |
| /* Try to match a symbol name following the dot. */ |
| if (gfc_match_name (name) != MATCH_YES) |
| { |
| gfc_error ("Expected structure component or operator name " |
| "after '.' at %C"); |
| goto error; |
| } |
| |
| /* If no dot follows we have "x.y" which should be a component access. */ |
| if (gfc_match_char ('.') != MATCH_YES) |
| goto yes; |
| |
| /* Now we have a string "x.y.z" which could be a nested member access |
| (x->y)->z or a binary operation y on x and z. */ |
| |
| /* First use any user-defined operators ".y." */ |
| if (gfc_find_uop (name, sym->ns) != NULL) |
| goto no; |
| |
| /* Match accesses to existing derived-type components for |
| derived-type vars: "x.y.z" = (x->y)->z */ |
| c = gfc_find_component(tsym, name, false, true, NULL); |
| if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS)) |
| goto yes; |
| |
| /* If y is not a component or has no members, try intrinsic operators. */ |
| gfc_current_locus = start_loc; |
| if (gfc_match_intrinsic_op (&iop) != MATCH_YES) |
| { |
| /* If ".y." is not an intrinsic operator but y was a valid non- |
| structure component, match and leave the trailing dot to be |
| dealt with later. */ |
| if (c) |
| goto yes; |
| |
| gfc_error ("%qs is neither a defined operator nor a " |
| "structure component in dotted string at %C", name); |
| goto error; |
| } |
| |
| /* .y. is an intrinsic operator, overriding any possible member access. */ |
| goto no; |
| |
| /* Return keeping the current locus consistent with the match result. */ |
| error: |
| m = MATCH_ERROR; |
| no: |
| gfc_current_locus = start_loc; |
| return m; |
| yes: |
| gfc_current_locus = dot_loc; |
| return MATCH_YES; |
| } |
| |
| |
| /* This function scans the current statement counting the opened and closed |
| parenthesis to make sure they are balanced. */ |
| |
| match |
| gfc_match_parens (void) |
| { |
| locus old_loc, where; |
| int count; |
| gfc_instring instring; |
| gfc_char_t c, quote; |
| |
| old_loc = gfc_current_locus; |
| count = 0; |
| instring = NONSTRING; |
| quote = ' '; |
| |
| for (;;) |
| { |
| if (count > 0) |
| where = gfc_current_locus; |
| c = gfc_next_char_literal (instring); |
| if (c == '\n') |
| break; |
| if (quote == ' ' && ((c == '\'') || (c == '"'))) |
| { |
| quote = c; |
| instring = INSTRING_WARN; |
| continue; |
| } |
| if (quote != ' ' && c == quote) |
| { |
| quote = ' '; |
| instring = NONSTRING; |
| continue; |
| } |
| |
| if (c == '(' && quote == ' ') |
| { |
| count++; |
| } |
| if (c == ')' && quote == ' ') |
| { |
| count--; |
| where = gfc_current_locus; |
| } |
| } |
| |
| gfc_current_locus = old_loc; |
| |
| if (count != 0) |
| { |
| gfc_error ("Missing %qs in statement at or before %L", |
| count > 0? ")":"(", &where); |
| return MATCH_ERROR; |
| } |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* See if the next character is a special character that has |
| escaped by a \ via the -fbackslash option. */ |
| |
| match |
| gfc_match_special_char (gfc_char_t *res) |
| { |
| int len, i; |
| gfc_char_t c, n; |
| match m; |
| |
| m = MATCH_YES; |
| |
| switch ((c = gfc_next_char_literal (INSTRING_WARN))) |
| { |
| case 'a': |
| *res = '\a'; |
| break; |
| case 'b': |
| *res = '\b'; |
| break; |
| case 't': |
| *res = '\t'; |
| break; |
| case 'f': |
| *res = '\f'; |
| break; |
| case 'n': |
| *res = '\n'; |
| break; |
| case 'r': |
| *res = '\r'; |
| break; |
| case 'v': |
| *res = '\v'; |
| break; |
| case '\\': |
| *res = '\\'; |
| break; |
| case '0': |
| *res = '\0'; |
| break; |
| |
| case 'x': |
| case 'u': |
| case 'U': |
| /* Hexadecimal form of wide characters. */ |
| len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8)); |
| n = 0; |
| for (i = 0; i < len; i++) |
| { |
| char buf[2] = { '\0', '\0' }; |
| |
| c = gfc_next_char_literal (INSTRING_WARN); |
| if (!gfc_wide_fits_in_byte (c) |
| || !gfc_check_digit ((unsigned char) c, 16)) |
| return MATCH_NO; |
| |
| buf[0] = (unsigned char) c; |
| n = n << 4; |
| n += strtol (buf, NULL, 16); |
| } |
| *res = n; |
| break; |
| |
| default: |
| /* Unknown backslash codes are simply not expanded. */ |
| m = MATCH_NO; |
| break; |
| } |
| |
| return m; |
| } |
| |
| |
| /* In free form, match at least one space. Always matches in fixed |
| form. */ |
| |
| match |
| gfc_match_space (void) |
| { |
| locus old_loc; |
| char c; |
| |
| if (gfc_current_form == FORM_FIXED) |
| return MATCH_YES; |
| |
| old_loc = gfc_current_locus; |
| |
| c = gfc_next_ascii_char (); |
| if (!gfc_is_whitespace (c)) |
| { |
| gfc_current_locus = old_loc; |
| return MATCH_NO; |
| } |
| |
| gfc_gobble_whitespace (); |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Match an end of statement. End of statement is optional |
| whitespace, followed by a ';' or '\n' or comment '!'. If a |
| semicolon is found, we continue to eat whitespace and semicolons. */ |
| |
| match |
| gfc_match_eos (void) |
| { |
| locus old_loc; |
| int flag; |
| char c; |
| |
| flag = 0; |
| |
| for (;;) |
| { |
| old_loc = gfc_current_locus; |
| gfc_gobble_whitespace (); |
| |
| c = gfc_next_ascii_char (); |
| switch (c) |
| { |
| case '!': |
| do |
| { |
| c = gfc_next_ascii_char (); |
| } |
| while (c != '\n'); |
| |
| /* Fall through. */ |
| |
| case '\n': |
| return MATCH_YES; |
| |
| case ';': |
| flag = 1; |
| continue; |
| } |
| |
| break; |
| } |
| |
| gfc_current_locus = old_loc; |
| return (flag) ? MATCH_YES : MATCH_NO; |
| } |
| |
| |
| /* Match a literal integer on the input, setting the value on |
| MATCH_YES. Literal ints occur in kind-parameters as well as |
| old-style character length specifications. If cnt is non-NULL it |
| will be set to the number of digits. */ |
| |
| match |
| gfc_match_small_literal_int (int *value, int *cnt) |
| { |
| locus old_loc; |
| char c; |
| int i, j; |
| |
| old_loc = gfc_current_locus; |
| |
| *value = -1; |
| gfc_gobble_whitespace (); |
| c = gfc_next_ascii_char (); |
| if (cnt) |
| *cnt = 0; |
| |
| if (!ISDIGIT (c)) |
| { |
| gfc_current_locus = old_loc; |
| return MATCH_NO; |
| } |
| |
| i = c - '0'; |
| j = 1; |
| |
| for (;;) |
| { |
| old_loc = gfc_current_locus; |
| c = gfc_next_ascii_char (); |
| |
| if (!ISDIGIT (c)) |
| break; |
| |
| i = 10 * i + c - '0'; |
| j++; |
| |
| if (i > 99999999) |
| { |
| gfc_error ("Integer too large at %C"); |
| return MATCH_ERROR; |
| } |
| } |
| |
| gfc_current_locus = old_loc; |
| |
| *value = i; |
| if (cnt) |
| *cnt = j; |
| return MATCH_YES; |
| } |
| |
| |
| /* Match a small, constant integer expression, like in a kind |
| statement. On MATCH_YES, 'value' is set. */ |
| |
| match |
| gfc_match_small_int (int *value) |
| { |
| gfc_expr *expr; |
| match m; |
| int i; |
| |
| m = gfc_match_expr (&expr); |
| if (m != MATCH_YES) |
| return m; |
| |
| if (gfc_extract_int (expr, &i, 1)) |
| m = MATCH_ERROR; |
| gfc_free_expr (expr); |
| |
| *value = i; |
| return m; |
| } |
| |
| |
| /* Matches a statement label. Uses gfc_match_small_literal_int() to |
| do most of the work. */ |
| |
| match |
| gfc_match_st_label (gfc_st_label **label) |
| { |
| locus old_loc; |
| match m; |
| int i, cnt; |
| |
| old_loc = gfc_current_locus; |
| |
| m = gfc_match_small_literal_int (&i, &cnt); |
| if (m != MATCH_YES) |
| return m; |
| |
| if (cnt > 5) |
| { |
| gfc_error ("Too many digits in statement label at %C"); |
| goto cleanup; |
| } |
| |
| if (i == 0) |
| { |
| gfc_error ("Statement label at %C is zero"); |
| goto cleanup; |
| } |
| |
| *label = gfc_get_st_label (i); |
| return MATCH_YES; |
| |
| cleanup: |
| |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| |
| |
| /* Match and validate a label associated with a named IF, DO or SELECT |
| statement. If the symbol does not have the label attribute, we add |
| it. We also make sure the symbol does not refer to another |
| (active) block. A matched label is pointed to by gfc_new_block. */ |
| |
| static match |
| gfc_match_label (void) |
| { |
| char name[GFC_MAX_SYMBOL_LEN + 1]; |
| match m; |
| |
| gfc_new_block = NULL; |
| |
| m = gfc_match (" %n :", name); |
| if (m != MATCH_YES) |
| return m; |
| |
| if (gfc_get_symbol (name, NULL, &gfc_new_block)) |
| { |
| gfc_error ("Label name %qs at %C is ambiguous", name); |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_new_block->attr.flavor == FL_LABEL) |
| { |
| gfc_error ("Duplicate construct label %qs at %C", name); |
| return MATCH_ERROR; |
| } |
| |
| if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, |
| gfc_new_block->name, NULL)) |
| return MATCH_ERROR; |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* See if the current input looks like a name of some sort. Modifies |
| the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. |
| Note that options.cc restricts max_identifier_length to not more |
| than GFC_MAX_SYMBOL_LEN. */ |
| |
| match |
| gfc_match_name (char *buffer) |
| { |
| locus old_loc; |
| int i; |
| char c; |
| |
| old_loc = gfc_current_locus; |
| gfc_gobble_whitespace (); |
| |
| c = gfc_next_ascii_char (); |
| if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore))) |
| { |
| /* Special cases for unary minus and plus, which allows for a sensible |
| error message for code of the form 'c = exp(-a*b) )' where an |
| extra ')' appears at the end of statement. */ |
| if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+') |
| gfc_error ("Invalid character in name at %C"); |
| gfc_current_locus = old_loc; |
| return MATCH_NO; |
| } |
| |
| i = 0; |
| |
| do |
| { |
| buffer[i++] = c; |
| |
| if (i > gfc_option.max_identifier_length) |
| { |
| gfc_error ("Name at %C is too long"); |
| return MATCH_ERROR; |
| } |
| |
| old_loc = gfc_current_locus; |
| c = gfc_next_ascii_char (); |
| } |
| while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$')); |
| |
| if (c == '$' && !flag_dollar_ok) |
| { |
| gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to " |
| "allow it as an extension", &old_loc); |
| return MATCH_ERROR; |
| } |
| |
| buffer[i] = '\0'; |
| gfc_current_locus = old_loc; |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Match a symbol on the input. Modifies the pointer to the symbol |
| pointer if successful. */ |
| |
| match |
| gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) |
| { |
| char buffer[GFC_MAX_SYMBOL_LEN + 1]; |
| match m; |
| |
| m = gfc_match_name (buffer); |
| if (m != MATCH_YES) |
| return m; |
| |
| if (host_assoc) |
| return (gfc_get_ha_sym_tree (buffer, matched_symbol)) |
| ? MATCH_ERROR : MATCH_YES; |
| |
| if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false)) |
| return MATCH_ERROR; |
| |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) |
| { |
| gfc_symtree *st; |
| match m; |
| |
| m = gfc_match_sym_tree (&st, host_assoc); |
| |
| if (m == MATCH_YES) |
| { |
| if (st) |
| *matched_symbol = st->n.sym; |
| else |
| *matched_symbol = NULL; |
| } |
| else |
| *matched_symbol = NULL; |
| return m; |
| } |
| |
| |
| /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, |
| we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this |
| in matchexp.cc. */ |
| |
| match |
| gfc_match_intrinsic_op (gfc_intrinsic_op *result) |
| { |
| locus orig_loc = gfc_current_locus; |
| char ch; |
| |
| gfc_gobble_whitespace (); |
| ch = gfc_next_ascii_char (); |
| switch (ch) |
| { |
| case '+': |
| /* Matched "+". */ |
| *result = INTRINSIC_PLUS; |
| return MATCH_YES; |
| |
| case '-': |
| /* Matched "-". */ |
| *result = INTRINSIC_MINUS; |
| return MATCH_YES; |
| |
| case '=': |
| if (gfc_next_ascii_char () == '=') |
| { |
| /* Matched "==". */ |
| *result = INTRINSIC_EQ; |
| return MATCH_YES; |
| } |
| break; |
| |
| case '<': |
| if (gfc_peek_ascii_char () == '=') |
| { |
| /* Matched "<=". */ |
| gfc_next_ascii_char (); |
| *result = INTRINSIC_LE; |
| return MATCH_YES; |
| } |
| /* Matched "<". */ |
| *result = INTRINSIC_LT; |
| return MATCH_YES; |
| |
| case '>': |
| if (gfc_peek_ascii_char () == '=') |
| { |
| /* Matched ">=". */ |
| gfc_next_ascii_char (); |
| *result = INTRINSIC_GE; |
| return MATCH_YES; |
| } |
| /* Matched ">". */ |
| *result = INTRINSIC_GT; |
| return MATCH_YES; |
| |
| case '*': |
| if (gfc_peek_ascii_char () == '*') |
| { |
| /* Matched "**". */ |
| gfc_next_ascii_char (); |
| *result = INTRINSIC_POWER; |
| return MATCH_YES; |
| } |
| /* Matched "*". */ |
| *result = INTRINSIC_TIMES; |
| return MATCH_YES; |
| |
| case '/': |
| ch = gfc_peek_ascii_char (); |
| if (ch == '=') |
| { |
| /* Matched "/=". */ |
| gfc_next_ascii_char (); |
| *result = INTRINSIC_NE; |
| return MATCH_YES; |
| } |
| else if (ch == '/') |
| { |
| /* Matched "//". */ |
| gfc_next_ascii_char (); |
| *result = INTRINSIC_CONCAT; |
| return MATCH_YES; |
| } |
| /* Matched "/". */ |
| *result = INTRINSIC_DIVIDE; |
| return MATCH_YES; |
| |
| case '.': |
| ch = gfc_next_ascii_char (); |
| switch (ch) |
| { |
| case 'a': |
| if (gfc_next_ascii_char () == 'n' |
| && gfc_next_ascii_char () == 'd' |
| && gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".and.". */ |
| *result = INTRINSIC_AND; |
| return MATCH_YES; |
| } |
| break; |
| |
| case 'e': |
| if (gfc_next_ascii_char () == 'q') |
| { |
| ch = gfc_next_ascii_char (); |
| if (ch == '.') |
| { |
| /* Matched ".eq.". */ |
| *result = INTRINSIC_EQ_OS; |
| return MATCH_YES; |
| } |
| else if (ch == 'v') |
| { |
| if (gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".eqv.". */ |
| *result = INTRINSIC_EQV; |
| return MATCH_YES; |
| } |
| } |
| } |
| break; |
| |
| case 'g': |
| ch = gfc_next_ascii_char (); |
| if (ch == 'e') |
| { |
| if (gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".ge.". */ |
| *result = INTRINSIC_GE_OS; |
| return MATCH_YES; |
| } |
| } |
| else if (ch == 't') |
| { |
| if (gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".gt.". */ |
| *result = INTRINSIC_GT_OS; |
| return MATCH_YES; |
| } |
| } |
| break; |
| |
| case 'l': |
| ch = gfc_next_ascii_char (); |
| if (ch == 'e') |
| { |
| if (gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".le.". */ |
| *result = INTRINSIC_LE_OS; |
| return MATCH_YES; |
| } |
| } |
| else if (ch == 't') |
| { |
| if (gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".lt.". */ |
| *result = INTRINSIC_LT_OS; |
| return MATCH_YES; |
| } |
| } |
| break; |
| |
| case 'n': |
| ch = gfc_next_ascii_char (); |
| if (ch == 'e') |
| { |
| ch = gfc_next_ascii_char (); |
| if (ch == '.') |
| { |
| /* Matched ".ne.". */ |
| *result = INTRINSIC_NE_OS; |
| return MATCH_YES; |
| } |
| else if (ch == 'q') |
| { |
| if (gfc_next_ascii_char () == 'v' |
| && gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".neqv.". */ |
| *result = INTRINSIC_NEQV; |
| return MATCH_YES; |
| } |
| } |
| } |
| else if (ch == 'o') |
| { |
| if (gfc_next_ascii_char () == 't' |
| && gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".not.". */ |
| *result = INTRINSIC_NOT; |
| return MATCH_YES; |
| } |
| } |
| break; |
| |
| case 'o': |
| if (gfc_next_ascii_char () == 'r' |
| && gfc_next_ascii_char () == '.') |
| { |
| /* Matched ".or.". */ |
| *result = INTRINSIC_OR; |
| return MATCH_YES; |
| } |
| break; |
| |
| case 'x': |
| if (gfc_next_ascii_char () == 'o' |
| && gfc_next_ascii_char () == 'r' |
| && gfc_next_ascii_char () == '.') |
| { |
| if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C")) |
| return MATCH_ERROR; |
| /* Matched ".xor." - equivalent to ".neqv.". */ |
| *result = INTRINSIC_NEQV; |
| return MATCH_YES; |
| } |
| break; |
| |
| default: |
| break; |
| } |
| break; |
| |
| default: |
| break; |
| } |
| |
| gfc_current_locus = orig_loc; |
| return MATCH_NO; |
| } |
| |
| |
| /* Match a loop control phrase: |
| |
| <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ] |
| |
| If the final integer expression is not present, a constant unity |
| expression is returned. We don't return MATCH_ERROR until after |
| the equals sign is seen. */ |
| |
| match |
| gfc_match_iterator (gfc_iterator *iter, int init_flag) |
| { |
| char name[GFC_MAX_SYMBOL_LEN + 1]; |
| gfc_expr *var, *e1, *e2, *e3; |
| locus start; |
| match m; |
| |
| e1 = e2 = e3 = NULL; |
| |
| /* Match the start of an iterator without affecting the symbol table. */ |
| |
| start = gfc_current_locus; |
| m = gfc_match (" %n =", name); |
| gfc_current_locus = start; |
| |
| if (m != MATCH_YES) |
| return MATCH_NO; |
| |
| m = gfc_match_variable (&var, 0); |
| if (m != MATCH_YES) |
| return MATCH_NO; |
| |
| if (var->symtree->n.sym->attr.dimension) |
| { |
| gfc_error ("Loop variable at %C cannot be an array"); |
| goto cleanup; |
| } |
| |
| /* F2008, C617 & C565. */ |
| if (var->symtree->n.sym->attr.codimension) |
| { |
| gfc_error ("Loop variable at %C cannot be a coarray"); |
| goto cleanup; |
| } |
| |
| if (var->ref != NULL) |
| { |
| gfc_error ("Loop variable at %C cannot be a sub-component"); |
| goto cleanup; |
| } |
| |
| gfc_match_char ('='); |
| |
| var->symtree->n.sym->attr.implied_index = 1; |
| |
| m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); |
| if (m == MATCH_NO) |
| goto syntax; |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| |
| if (gfc_match_char (',') != MATCH_YES) |
| goto syntax; |
| |
| m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2); |
| if (m == MATCH_NO) |
| goto syntax; |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| |
| if (gfc_match_char (',') != MATCH_YES) |
| { |
| e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); |
| goto done; |
| } |
| |
| m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| { |
| gfc_error ("Expected a step value in iterator at %C"); |
| goto cleanup; |
| } |
| |
| done: |
| iter->var = var; |
| iter->start = e1; |
| iter->end = e2; |
| iter->step = e3; |
| return MATCH_YES; |
| |
| syntax: |
| gfc_error ("Syntax error in iterator at %C"); |
| |
| cleanup: |
| gfc_free_expr (e1); |
| gfc_free_expr (e2); |
| gfc_free_expr (e3); |
| |
| return MATCH_ERROR; |
| } |
| |
| |
| /* Tries to match the next non-whitespace character on the input. |
| This subroutine does not return MATCH_ERROR. */ |
| |
| match |
| gfc_match_char (char c) |
| { |
| locus where; |
| |
| where = gfc_current_locus; |
| gfc_gobble_whitespace (); |
| |
| if (gfc_next_ascii_char () == c) |
| return MATCH_YES; |
| |
| gfc_current_locus = where; |
| return MATCH_NO; |
| } |
| |
| |
| /* General purpose matching subroutine. The target string is a |
| scanf-like format string in which spaces correspond to arbitrary |
| whitespace (including no whitespace), characters correspond to |
| themselves. The %-codes are: |
| |
| %% Literal percent sign |
| %e Expression, pointer to a pointer is set |
| %s Symbol, pointer to the symbol is set |
| %n Name, character buffer is set to name |
| %t Matches end of statement. |
| %o Matches an intrinsic operator, returned as an INTRINSIC enum. |
| %l Matches a statement label |
| %v Matches a variable expression (an lvalue, except function references |
| having a data pointer result) |
| % Matches a required space (in free form) and optional spaces. */ |
| |
| match |
| gfc_match (const char *target, ...) |
| { |
| gfc_st_label **label; |
| int matches, *ip; |
| locus old_loc; |
| va_list argp; |
| char c, *np; |
| match m, n; |
| void **vp; |
| const char *p; |
| |
| old_loc = gfc_current_locus; |
| va_start (argp, target); |
| m = MATCH_NO; |
| matches = 0; |
| p = target; |
| |
| loop: |
| c = *p++; |
| switch (c) |
| { |
| case ' ': |
| gfc_gobble_whitespace (); |
| goto loop; |
| case '\0': |
| m = MATCH_YES; |
| break; |
| |
| case '%': |
| c = *p++; |
| switch (c) |
| { |
| case 'e': |
| vp = va_arg (argp, void **); |
| n = gfc_match_expr ((gfc_expr **) vp); |
| if (n != MATCH_YES) |
| { |
| m = n; |
| goto not_yes; |
| } |
| |
| matches++; |
| goto loop; |
| |
| case 'v': |
| vp = va_arg (argp, void **); |
| n = gfc_match_variable ((gfc_expr **) vp, 0); |
| if (n != MATCH_YES) |
| { |
| m = n; |
| goto not_yes; |
| } |
| |
| matches++; |
| goto loop; |
| |
| case 's': |
| vp = va_arg (argp, void **); |
| n = gfc_match_symbol ((gfc_symbol **) vp, 0); |
| if (n != MATCH_YES) |
| { |
| m = n; |
| goto not_yes; |
| } |
| |
| matches++; |
| goto loop; |
| |
| case 'n': |
| np = va_arg (argp, char *); |
| n = gfc_match_name (np); |
| if (n != MATCH_YES) |
| { |
| m = n; |
| goto not_yes; |
| } |
| |
| matches++; |
| goto loop; |
| |
| case 'l': |
| label = va_arg (argp, gfc_st_label **); |
| n = gfc_match_st_label (label); |
| if (n != MATCH_YES) |
| { |
| m = n; |
| goto not_yes; |
| } |
| |
| matches++; |
| goto loop; |
| |
| case 'o': |
| ip = va_arg (argp, int *); |
| n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip); |
| if (n != MATCH_YES) |
| { |
| m = n; |
| goto not_yes; |
| } |
| |
| matches++; |
| goto loop; |
| |
| case 't': |
| if (gfc_match_eos () != MATCH_YES) |
| { |
| m = MATCH_NO; |
| goto not_yes; |
| } |
| goto loop; |
| |
| case ' ': |
| if (gfc_match_space () == MATCH_YES) |
| goto loop; |
| m = MATCH_NO; |
| goto not_yes; |
| |
| case '%': |
| break; /* Fall through to character matcher. */ |
| |
| default: |
| gfc_internal_error ("gfc_match(): Bad match code %c", c); |
| } |
| /* FALLTHRU */ |
| |
| default: |
| |
| /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't |
| expect an upper case character here! */ |
| gcc_assert (TOLOWER (c) == c); |
| |
| if (c == gfc_next_ascii_char ()) |
| goto loop; |
| break; |
| } |
| |
| not_yes: |
| va_end (argp); |
| |
| if (m != MATCH_YES) |
| { |
| /* Clean up after a failed match. */ |
| gfc_current_locus = old_loc; |
| va_start (argp, target); |
| |
| p = target; |
| for (; matches > 0; matches--) |
| { |
| while (*p++ != '%'); |
| |
| switch (*p++) |
| { |
| case '%': |
| matches++; |
| break; /* Skip. */ |
| |
| /* Matches that don't have to be undone */ |
| case 'o': |
| case 'l': |
| case 'n': |
| case 's': |
| (void) va_arg (argp, void **); |
| break; |
| |
| case 'e': |
| case 'v': |
| vp = va_arg (argp, void **); |
| gfc_free_expr ((struct gfc_expr *)*vp); |
| *vp = NULL; |
| break; |
| } |
| } |
| |
| va_end (argp); |
| } |
| |
| return m; |
| } |
| |
| |
| /*********************** Statement level matching **********************/ |
| |
| /* Matches the start of a program unit, which is the program keyword |
| followed by an obligatory symbol. */ |
| |
| match |
| gfc_match_program (void) |
| { |
| gfc_symbol *sym; |
| match m; |
| |
| m = gfc_match ("% %s%t", &sym); |
| |
| if (m == MATCH_NO) |
| { |
| gfc_error ("Invalid form of PROGRAM statement at %C"); |
| m = MATCH_ERROR; |
| } |
| |
| if (m == MATCH_ERROR) |
| return m; |
| |
| if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL)) |
| return MATCH_ERROR; |
| |
| gfc_new_block = sym; |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Match a simple assignment statement. */ |
| |
| match |
| gfc_match_assignment (void) |
| { |
| gfc_expr *lvalue, *rvalue; |
| locus old_loc; |
| match m; |
| |
| old_loc = gfc_current_locus; |
| |
| lvalue = NULL; |
| m = gfc_match (" %v =", &lvalue); |
| if (m != MATCH_YES) |
| { |
| gfc_current_locus = old_loc; |
| gfc_free_expr (lvalue); |
| return MATCH_NO; |
| } |
| |
| rvalue = NULL; |
| m = gfc_match (" %e%t", &rvalue); |
| |
| if (m == MATCH_YES |
| && rvalue->ts.type == BT_BOZ |
| && lvalue->ts.type == BT_CLASS) |
| { |
| m = MATCH_ERROR; |
| gfc_error ("BOZ literal constant at %L is neither a DATA statement " |
| "value nor an actual argument of INT/REAL/DBLE/CMPLX " |
| "intrinsic subprogram", &rvalue->where); |
| } |
| |
| if (lvalue->expr_type == EXPR_CONSTANT) |
| { |
| /* This clobbers %len and %kind. */ |
| m = MATCH_ERROR; |
| gfc_error ("Assignment to a constant expression at %C"); |
| } |
| |
| if (m != MATCH_YES) |
| { |
| gfc_current_locus = old_loc; |
| gfc_free_expr (lvalue); |
| gfc_free_expr (rvalue); |
| return m; |
| } |
| |
| if (!lvalue->symtree) |
| { |
| gfc_free_expr (lvalue); |
| gfc_free_expr (rvalue); |
| return MATCH_ERROR; |
| } |
| |
| |
| gfc_set_sym_referenced (lvalue->symtree->n.sym); |
| |
| new_st.op = EXEC_ASSIGN; |
| new_st.expr1 = lvalue; |
| new_st.expr2 = rvalue; |
| |
| gfc_check_do_variable (lvalue->symtree); |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Match a pointer assignment statement. */ |
| |
| match |
| gfc_match_pointer_assignment (void) |
| { |
| gfc_expr *lvalue, *rvalue; |
| locus old_loc; |
| match m; |
| |
| old_loc = gfc_current_locus; |
| |
| lvalue = rvalue = NULL; |
| gfc_matching_ptr_assignment = 0; |
| gfc_matching_procptr_assignment = 0; |
| |
| m = gfc_match (" %v =>", &lvalue); |
| if (m != MATCH_YES || !lvalue->symtree) |
| { |
| m = MATCH_NO; |
| goto cleanup; |
| } |
| |
| if (lvalue->symtree->n.sym->attr.proc_pointer |
| || gfc_is_proc_ptr_comp (lvalue)) |
| gfc_matching_procptr_assignment = 1; |
| else |
| gfc_matching_ptr_assignment = 1; |
| |
| m = gfc_match (" %e%t", &rvalue); |
| gfc_matching_ptr_assignment = 0; |
| gfc_matching_procptr_assignment = 0; |
| if (m != MATCH_YES) |
| goto cleanup; |
| |
| new_st.op = EXEC_POINTER_ASSIGN; |
| new_st.expr1 = lvalue; |
| new_st.expr2 = rvalue; |
| |
| return MATCH_YES; |
| |
| cleanup: |
| gfc_current_locus = old_loc; |
| gfc_free_expr (lvalue); |
| gfc_free_expr (rvalue); |
| return m; |
| } |
| |
| |
| /* We try to match an easy arithmetic IF statement. This only happens |
| when just after having encountered a simple IF statement. This code |
| is really duplicate with parts of the gfc_match_if code, but this is |
| *much* easier. */ |
| |
| static match |
| match_arithmetic_if (void) |
| { |
| gfc_st_label *l1, *l2, *l3; |
| gfc_expr *expr; |
| match m; |
| |
| m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3); |
| if (m != MATCH_YES) |
| return m; |
| |
| if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) |
| || !gfc_reference_st_label (l2, ST_LABEL_TARGET) |
| || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) |
| { |
| gfc_free_expr (expr); |
| return MATCH_ERROR; |
| } |
| |
| if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, |
| "Arithmetic IF statement at %C")) |
| return MATCH_ERROR; |
| |
| new_st.op = EXEC_ARITHMETIC_IF; |
| new_st.expr1 = expr; |
| new_st.label1 = l1; |
| new_st.label2 = l2; |
| new_st.label3 = l3; |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* The IF statement is a bit of a pain. First of all, there are three |
| forms of it, the simple IF, the IF that starts a block and the |
| arithmetic IF. |
| |
| There is a problem with the simple IF and that is the fact that we |
| only have a single level of undo information on symbols. What this |
| means is for a simple IF, we must re-match the whole IF statement |
| multiple times in order to guarantee that the symbol table ends up |
| in the proper state. */ |
| |
| static match match_simple_forall (void); |
| static match match_simple_where (void); |
| |
| match |
| gfc_match_if (gfc_statement *if_type) |
| { |
| gfc_expr *expr; |
| gfc_st_label *l1, *l2, *l3; |
| locus old_loc, old_loc2; |
| gfc_code *p; |
| match m, n; |
| |
| n = gfc_match_label (); |
| if (n == MATCH_ERROR) |
| return n; |
| |
| old_loc = gfc_current_locus; |
| |
| m = gfc_match (" if ", &expr); |
| if (m != MATCH_YES) |
| return m; |
| |
| if (gfc_match_char ('(') != MATCH_YES) |
| { |
| gfc_error ("Missing %<(%> in IF-expression at %C"); |
| return MATCH_ERROR; |
| } |
| |
| m = gfc_match ("%e", &expr); |
| if (m != MATCH_YES) |
| return m; |
| |
| old_loc2 = gfc_current_locus; |
| gfc_current_locus = old_loc; |
| |
| if (gfc_match_parens () == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| gfc_current_locus = old_loc2; |
| |
| if (gfc_match_char (')') != MATCH_YES) |
| { |
| gfc_error ("Syntax error in IF-expression at %C"); |
| gfc_free_expr (expr); |
| return MATCH_ERROR; |
| } |
| |
| m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3); |
| |
| if (m == MATCH_YES) |
| { |
| if (n == MATCH_YES) |
| { |
| gfc_error ("Block label not appropriate for arithmetic IF " |
| "statement at %C"); |
| gfc_free_expr (expr); |
| return MATCH_ERROR; |
| } |
| |
| if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) |
| || !gfc_reference_st_label (l2, ST_LABEL_TARGET) |
| || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) |
| { |
| gfc_free_expr (expr); |
| return MATCH_ERROR; |
| } |
| |
| if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, |
| "Arithmetic IF statement at %C")) |
| return MATCH_ERROR; |
| |
| new_st.op = EXEC_ARITHMETIC_IF; |
| new_st.expr1 = expr; |
| new_st.label1 = l1; |
| new_st.label2 = l2; |
| new_st.label3 = l3; |
| |
| *if_type = ST_ARITHMETIC_IF; |
| return MATCH_YES; |
| } |
| |
| if (gfc_match (" then%t") == MATCH_YES) |
| { |
| new_st.op = EXEC_IF; |
| new_st.expr1 = expr; |
| *if_type = ST_IF_BLOCK; |
| return MATCH_YES; |
| } |
| |
| if (n == MATCH_YES) |
| { |
| gfc_error ("Block label is not appropriate for IF statement at %C"); |
| gfc_free_expr (expr); |
| return MATCH_ERROR; |
| } |
| |
| /* At this point the only thing left is a simple IF statement. At |
| this point, n has to be MATCH_NO, so we don't have to worry about |
| re-matching a block label. From what we've got so far, try |
| matching an assignment. */ |
| |
| *if_type = ST_SIMPLE_IF; |
| |
| m = gfc_match_assignment (); |
| if (m == MATCH_YES) |
| goto got_match; |
| |
| gfc_free_expr (expr); |
| gfc_undo_symbols (); |
| gfc_current_locus = old_loc; |
| |
| /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled |
| assignment was found. For MATCH_NO, continue to call the various |
| matchers. */ |
| if (m == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ |
| |
| m = gfc_match_pointer_assignment (); |
| if (m == MATCH_YES) |
| goto got_match; |
| |
| gfc_free_expr (expr); |
| gfc_undo_symbols (); |
| gfc_current_locus = old_loc; |
| |
| gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ |
| |
| /* Look at the next keyword to see which matcher to call. Matching |
| the keyword doesn't affect the symbol table, so we don't have to |
| restore between tries. */ |
| |
| #define match(string, subr, statement) \ |
| if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; } |
| |
| gfc_clear_error (); |
| |
| match ("allocate", gfc_match_allocate, ST_ALLOCATE) |
| match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) |
| match ("backspace", gfc_match_backspace, ST_BACKSPACE) |
| match ("call", gfc_match_call, ST_CALL) |
| match ("change team", gfc_match_change_team, ST_CHANGE_TEAM) |
| match ("close", gfc_match_close, ST_CLOSE) |
| match ("continue", gfc_match_continue, ST_CONTINUE) |
| match ("cycle", gfc_match_cycle, ST_CYCLE) |
| match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) |
| match ("end file", gfc_match_endfile, ST_END_FILE) |
| match ("end team", gfc_match_end_team, ST_END_TEAM) |
| match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) |
| match ("event post", gfc_match_event_post, ST_EVENT_POST) |
| match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT) |
| match ("exit", gfc_match_exit, ST_EXIT) |
| match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE) |
| match ("flush", gfc_match_flush, ST_FLUSH) |
| match ("forall", match_simple_forall, ST_FORALL) |
| match ("form team", gfc_match_form_team, ST_FORM_TEAM) |
| match ("go to", gfc_match_goto, ST_GOTO) |
| match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) |
| match ("inquire", gfc_match_inquire, ST_INQUIRE) |
| match ("lock", gfc_match_lock, ST_LOCK) |
| match ("nullify", gfc_match_nullify, ST_NULLIFY) |
| match ("open", gfc_match_open, ST_OPEN) |
| match ("pause", gfc_match_pause, ST_NONE) |
| match ("print", gfc_match_print, ST_WRITE) |
| match ("read", gfc_match_read, ST_READ) |
| match ("return", gfc_match_return, ST_RETURN) |
| match ("rewind", gfc_match_rewind, ST_REWIND) |
| match ("stop", gfc_match_stop, ST_STOP) |
| match ("wait", gfc_match_wait, ST_WAIT) |
| match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); |
| match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); |
| match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); |
| match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM) |
| match ("unlock", gfc_match_unlock, ST_UNLOCK) |
| match ("where", match_simple_where, ST_WHERE) |
| match ("write", gfc_match_write, ST_WRITE) |
| |
| if (flag_dec) |
| match ("type", gfc_match_print, ST_WRITE) |
| |
| /* All else has failed, so give up. See if any of the matchers has |
| stored an error message of some sort. */ |
| if (!gfc_error_check ()) |
| gfc_error ("Syntax error in IF-clause after %C"); |
| |
| gfc_free_expr (expr); |
| return MATCH_ERROR; |
| |
| got_match: |
| if (m == MATCH_NO) |
| gfc_error ("Syntax error in IF-clause after %C"); |
| if (m != MATCH_YES) |
| { |
| gfc_free_expr (expr); |
| return MATCH_ERROR; |
| } |
| |
| /* At this point, we've matched the single IF and the action clause |
| is in new_st. Rearrange things so that the IF statement appears |
| in new_st. */ |
| |
| p = gfc_get_code (EXEC_IF); |
| p->next = XCNEW (gfc_code); |
| *p->next = new_st; |
| p->next->loc = gfc_current_locus; |
| |
| p->expr1 = expr; |
| |
| gfc_clear_new_st (); |
| |
| new_st.op = EXEC_IF; |
| new_st.block = p; |
| |
| return MATCH_YES; |
| } |
| |
| #undef match |
| |
| |
| /* Match an ELSE statement. */ |
| |
| match |
| gfc_match_else (void) |
| { |
| char name[GFC_MAX_SYMBOL_LEN + 1]; |
| |
| if (gfc_match_eos () == MATCH_YES) |
| return MATCH_YES; |
| |
| if (gfc_match_name (name) != MATCH_YES |
| || gfc_current_block () == NULL |
| || gfc_match_eos () != MATCH_YES) |
| { |
| gfc_error ("Invalid character(s) in ELSE statement after %C"); |
| return MATCH_ERROR; |
| } |
| |
| if (strcmp (name, gfc_current_block ()->name) != 0) |
| { |
| gfc_error ("Label %qs at %C doesn't match IF label %qs", |
| name, gfc_current_block ()->name); |
| return MATCH_ERROR; |
| } |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Match an ELSE IF statement. */ |
| |
| match |
| gfc_match_elseif (void) |
| { |
| char name[GFC_MAX_SYMBOL_LEN + 1]; |
| gfc_expr *expr, *then; |
| locus where; |
| match m; |
| |
| if (gfc_match_char ('(') != MATCH_YES) |
| { |
| gfc_error ("Missing %<(%> in ELSE IF expression at %C"); |
| return MATCH_ERROR; |
| } |
| |
| m = gfc_match (" %e ", &expr); |
| if (m != MATCH_YES) |
| return m; |
| |
| if (gfc_match_char (')') != MATCH_YES) |
| { |
| gfc_error ("Missing %<)%> in ELSE IF expression at %C"); |
| goto cleanup; |
| } |
| |
| m = gfc_match (" then ", &then); |
| |
| where = gfc_current_locus; |
| |
| if (m == MATCH_YES && (gfc_match_eos () == MATCH_YES |
| || (gfc_current_block () |
| && gfc_match_name (name) == MATCH_YES))) |
| goto done; |
| |
| if (gfc_match_eos () == MATCH_YES) |
| { |
| gfc_error ("Missing THEN in ELSE IF statement after %L", &where); |
| goto cleanup; |
| } |
| |
| if (gfc_match_name (name) != MATCH_YES |
| || gfc_current_block () == NULL |
| || gfc_match_eos () != MATCH_YES) |
| { |
| gfc_error ("Syntax error in ELSE IF statement after %L", &where); |
| goto cleanup; |
| } |
| |
| if (strcmp (name, gfc_current_block ()->name) != 0) |
| { |
| gfc_error ("Label %qs after %L doesn't match IF label %qs", |
| name, &where, gfc_current_block ()->name); |
| goto cleanup; |
| } |
| |
| if (m != MATCH_YES) |
| return m; |
| |
| done: |
| new_st.op = EXEC_IF; |
| new_st.expr1 = expr; |
| return MATCH_YES; |
| |
| cleanup: |
| gfc_free_expr (expr); |
| return MATCH_ERROR; |
| } |
| |
| |
| /* Free a gfc_iterator structure. */ |
| |
| void |
| gfc_free_iterator (gfc_iterator *iter, int flag) |
| { |
| |
| if (iter == NULL) |
| return; |
| |
| gfc_free_expr (iter->var); |
| gfc_free_expr (iter->start); |
| gfc_free_expr (iter->end); |
| gfc_free_expr (iter->step); |
| |
| if (flag) |
| free (iter); |
| } |
| |
| |
| /* Match a CRITICAL statement. */ |
| match |
| gfc_match_critical (void) |
| { |
| gfc_st_label *label = NULL; |
| |
| if (gfc_match_label () == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| if (gfc_match (" critical") != MATCH_YES) |
| return MATCH_NO; |
| |
| if (gfc_match_st_label (&label) == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| if (gfc_match_eos () != MATCH_YES) |
| { |
| gfc_syntax_error (ST_CRITICAL); |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_pure (NULL)) |
| { |
| gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_find_state (COMP_DO_CONCURRENT)) |
| { |
| gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT " |
| "block"); |
| return MATCH_ERROR; |
| } |
| |
| gfc_unset_implicit_pure (NULL); |
| |
| if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C")) |
| return MATCH_ERROR; |
| |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " |
| "enable"); |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_find_state (COMP_CRITICAL)) |
| { |
| gfc_error ("Nested CRITICAL block at %C"); |
| return MATCH_ERROR; |
| } |
| |
| new_st.op = EXEC_CRITICAL; |
| |
| if (label != NULL |
| && !gfc_reference_st_label (label, ST_LABEL_TARGET)) |
| return MATCH_ERROR; |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Match a BLOCK statement. */ |
| |
| match |
| gfc_match_block (void) |
| { |
| match m; |
| |
| if (gfc_match_label () == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| if (gfc_match (" block") != MATCH_YES) |
| return MATCH_NO; |
| |
| /* For this to be a correct BLOCK statement, the line must end now. */ |
| m = gfc_match_eos (); |
| if (m == MATCH_ERROR) |
| return MATCH_ERROR; |
| if (m == MATCH_NO) |
| return MATCH_NO; |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Match an ASSOCIATE statement. */ |
| |
| match |
| gfc_match_associate (void) |
| { |
| if (gfc_match_label () == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| if (gfc_match (" associate") != MATCH_YES) |
| return MATCH_NO; |
| |
| /* Match the association list. */ |
| if (gfc_match_char ('(') != MATCH_YES) |
| { |
| gfc_error ("Expected association list at %C"); |
| return MATCH_ERROR; |
| } |
| new_st.ext.block.assoc = NULL; |
| while (true) |
| { |
| gfc_association_list* newAssoc = gfc_get_association_list (); |
| gfc_association_list* a; |
| |
| /* Match the next association. */ |
| if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES) |
| { |
| gfc_error ("Expected association at %C"); |
| goto assocListError; |
| } |
| |
| if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) |
| { |
| /* Have another go, allowing for procedure pointer selectors. */ |
| gfc_matching_procptr_assignment = 1; |
| if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) |
| { |
| gfc_error ("Invalid association target at %C"); |
| goto assocListError; |
| } |
| gfc_matching_procptr_assignment = 0; |
| } |
| newAssoc->where = gfc_current_locus; |
| |
| /* Check that the current name is not yet in the list. */ |
| for (a = new_st.ext.block.assoc; a; a = a->next) |
| if (!strcmp (a->name, newAssoc->name)) |
| { |
| gfc_error ("Duplicate name %qs in association at %C", |
| newAssoc->name); |
| goto assocListError; |
| } |
| |
| /* The target expression must not be coindexed. */ |
| if (gfc_is_coindexed (newAssoc->target)) |
| { |
| gfc_error ("Association target at %C must not be coindexed"); |
| goto assocListError; |
| } |
| |
| /* The target expression cannot be a BOZ literal constant. */ |
| if (newAssoc->target->ts.type == BT_BOZ) |
| { |
| gfc_error ("Association target at %L cannot be a BOZ literal " |
| "constant", &newAssoc->target->where); |
| goto assocListError; |
| } |
| |
| /* The `variable' field is left blank for now; because the target is not |
| yet resolved, we can't use gfc_has_vector_subscript to determine it |
| for now. This is set during resolution. */ |
| |
| /* Put it into the list. */ |
| newAssoc->next = new_st.ext.block.assoc; |
| new_st.ext.block.assoc = newAssoc; |
| |
| /* Try next one or end if closing parenthesis is found. */ |
| gfc_gobble_whitespace (); |
| if (gfc_peek_char () == ')') |
| break; |
| if (gfc_match_char (',') != MATCH_YES) |
| { |
| gfc_error ("Expected %<)%> or %<,%> at %C"); |
| return MATCH_ERROR; |
| } |
| |
| continue; |
| |
| assocListError: |
| free (newAssoc); |
| goto error; |
| } |
| if (gfc_match_char (')') != MATCH_YES) |
| { |
| /* This should never happen as we peek above. */ |
| gcc_unreachable (); |
| } |
| |
| if (gfc_match_eos () != MATCH_YES) |
| { |
| gfc_error ("Junk after ASSOCIATE statement at %C"); |
| goto error; |
| } |
| |
| return MATCH_YES; |
| |
| error: |
| gfc_free_association_list (new_st.ext.block.assoc); |
| return MATCH_ERROR; |
| } |
| |
| |
| /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of |
| an accessible derived type. */ |
| |
| static match |
| match_derived_type_spec (gfc_typespec *ts) |
| { |
| char name[GFC_MAX_SYMBOL_LEN + 1]; |
| locus old_locus; |
| gfc_symbol *derived, *der_type; |
| match m = MATCH_YES; |
| gfc_actual_arglist *decl_type_param_list = NULL; |
| bool is_pdt_template = false; |
| |
| old_locus = gfc_current_locus; |
| |
| if (gfc_match ("%n", name) != MATCH_YES) |
| { |
| gfc_current_locus = old_locus; |
| return MATCH_NO; |
| } |
| |
| gfc_find_symbol (name, NULL, 1, &derived); |
| |
| /* Match the PDT spec list, if there. */ |
| if (derived && derived->attr.flavor == FL_PROCEDURE) |
| { |
| gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type); |
| is_pdt_template = der_type |
| && der_type->attr.flavor == FL_DERIVED |
| && der_type->attr.pdt_template; |
| } |
| |
| if (is_pdt_template) |
| m = gfc_match_actual_arglist (1, &decl_type_param_list, true); |
| |
| if (m == MATCH_ERROR) |
| { |
| gfc_free_actual_arglist (decl_type_param_list); |
| return m; |
| } |
| |
| if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic) |
| derived = gfc_find_dt_in_generic (derived); |
| |
| /* If this is a PDT, find the specific instance. */ |
| if (m == MATCH_YES && is_pdt_template) |
| { |
| gfc_namespace *old_ns; |
| |
| old_ns = gfc_current_ns; |
| while (gfc_current_ns && gfc_current_ns->parent) |
| gfc_current_ns = gfc_current_ns->parent; |
| |
| if (type_param_spec_list) |
| gfc_free_actual_arglist (type_param_spec_list); |
| m = gfc_get_pdt_instance (decl_type_param_list, &der_type, |
| &type_param_spec_list); |
| gfc_free_actual_arglist (decl_type_param_list); |
| |
| if (m != MATCH_YES) |
| return m; |
| derived = der_type; |
| gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type); |
| gfc_set_sym_referenced (derived); |
| |
| gfc_current_ns = old_ns; |
| } |
| |
| if (derived && derived->attr.flavor == FL_DERIVED) |
| { |
| ts->type = BT_DERIVED; |
| ts->u.derived = derived; |
| return MATCH_YES; |
| } |
| |
| gfc_current_locus = old_locus; |
| return MATCH_NO; |
| } |
| |
| |
| /* Match a Fortran 2003 type-spec (F03:R401). This is similar to |
| gfc_match_decl_type_spec() from decl.cc, with the following exceptions: |
| It only includes the intrinsic types from the Fortran 2003 standard |
| (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, |
| the implicit_flag is not needed, so it was removed. Derived types are |
| identified by their name alone. */ |
| |
| match |
| gfc_match_type_spec (gfc_typespec *ts) |
| { |
| match m; |
| locus old_locus; |
| char c, name[GFC_MAX_SYMBOL_LEN + 1]; |
| |
| gfc_clear_ts (ts); |
| gfc_gobble_whitespace (); |
| old_locus = gfc_current_locus; |
| |
| /* If c isn't [a-z], then return immediately. */ |
| c = gfc_peek_ascii_char (); |
| if (!ISALPHA(c)) |
| return MATCH_NO; |
| |
| type_param_spec_list = NULL; |
| |
| if (match_derived_type_spec (ts) == MATCH_YES) |
| { |
| /* Enforce F03:C401. */ |
| if (ts->u.derived->attr.abstract) |
| { |
| gfc_error ("Derived type %qs at %L may not be ABSTRACT", |
| ts->u.derived->name, &old_locus); |
| return MATCH_ERROR; |
| } |
| return MATCH_YES; |
| } |
| |
| if (gfc_match ("integer") == MATCH_YES) |
| { |
| ts->type = BT_INTEGER; |
| ts->kind = gfc_default_integer_kind; |
| goto kind_selector; |
| } |
| |
| if (gfc_match ("double precision") == MATCH_YES) |
| { |
| ts->type = BT_REAL; |
| ts->kind = gfc_default_double_kind; |
| return MATCH_YES; |
| } |
| |
| if (gfc_match ("complex") == MATCH_YES) |
| { |
| ts->type = BT_COMPLEX; |
| ts->kind = gfc_default_complex_kind; |
| goto kind_selector; |
| } |
| |
| if (gfc_match ("character") == MATCH_YES) |
| { |
| ts->type = BT_CHARACTER; |
| |
| m = gfc_match_char_spec (ts); |
| |
| if (m == MATCH_NO) |
| m = MATCH_YES; |
| |
| return m; |
| } |
| |
| /* REAL is a real pain because it can be a type, intrinsic subprogram, |
| or list item in a type-list of an OpenMP reduction clause. Need to |
| differentiate REAL([KIND]=scalar-int-initialization-expr) from |
| REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was |
| written the use of LOGICAL as a type-spec or intrinsic subprogram |
| was overlooked. */ |
| |
| m = gfc_match (" %n", name); |
| if (m == MATCH_YES |
| && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0)) |
| { |
| char c; |
| gfc_expr *e; |
| locus where; |
| |
| if (*name == 'r') |
| { |
| ts->type = BT_REAL; |
| ts->kind = gfc_default_real_kind; |
| } |
| else |
| { |
| ts->type = BT_LOGICAL; |
| ts->kind = gfc_default_logical_kind; |
| } |
| |
| gfc_gobble_whitespace (); |
| |
| /* Prevent REAL*4, etc. */ |
| c = gfc_peek_ascii_char (); |
| if (c == '*') |
| { |
| gfc_error ("Invalid type-spec at %C"); |
| return MATCH_ERROR; |
| } |
| |
| /* Found leading colon in REAL::, a trailing ')' in for example |
| TYPE IS (REAL), or REAL, for an OpenMP list-item. */ |
| if (c == ':' || c == ')' || (flag_openmp && c == ',')) |
| return MATCH_YES; |
| |
| /* Found something other than the opening '(' in REAL(... */ |
| if (c != '(') |
| return MATCH_NO; |
| else |
| gfc_next_char (); /* Burn the '('. */ |
| |
| /* Look for the optional KIND=. */ |
| where = gfc_current_locus; |
| m = gfc_match ("%n", name); |
| if (m == MATCH_YES) |
| { |
| gfc_gobble_whitespace (); |
| c = gfc_next_char (); |
| if (c == '=') |
| { |
| if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0) |
| return MATCH_NO; |
| else if (strcmp(name, "kind") == 0) |
| goto found; |
| else |
| return MATCH_ERROR; |
| } |
| else |
| gfc_current_locus = where; |
| } |
| else |
| gfc_current_locus = where; |
| |
| found: |
| |
| m = gfc_match_expr (&e); |
| if (m == MATCH_NO || m == MATCH_ERROR) |
| return m; |
| |
| /* If a comma appears, it is an intrinsic subprogram. */ |
| gfc_gobble_whitespace (); |
| c = gfc_peek_ascii_char (); |
| if (c == ',') |
| { |
| gfc_free_expr (e); |
| return MATCH_NO; |
| } |
| |
| /* If ')' appears, we have REAL(initialization-expr), here check for |
| a scalar integer initialization-expr and valid kind parameter. */ |
| if (c == ')') |
| { |
| bool ok = true; |
| if (e->expr_type != EXPR_CONSTANT && e->expr_type != EXPR_VARIABLE) |
| ok = gfc_reduce_init_expr (e); |
| if (!ok || e->ts.type != BT_INTEGER || e->rank > 0) |
| { |
| gfc_free_expr (e); |
| return MATCH_NO; |
| } |
| |
| if (e->expr_type != EXPR_CONSTANT) |
| goto ohno; |
| |
| gfc_next_char (); /* Burn the ')'. */ |
| ts->kind = (int) mpz_get_si (e->value.integer); |
| if (gfc_validate_kind (ts->type, ts->kind , true) == -1) |
| { |
| gfc_error ("Invalid type-spec at %C"); |
| return MATCH_ERROR; |
| } |
| |
| gfc_free_expr (e); |
| |
| return MATCH_YES; |
| } |
| } |
| |
| ohno: |
| |
| /* If a type is not matched, simply return MATCH_NO. */ |
| gfc_current_locus = old_locus; |
| return MATCH_NO; |
| |
| kind_selector: |
| |
| gfc_gobble_whitespace (); |
| |
| /* This prevents INTEGER*4, etc. */ |
| if (gfc_peek_ascii_char () == '*') |
| { |
| gfc_error ("Invalid type-spec at %C"); |
| return MATCH_ERROR; |
| } |
| |
| m = gfc_match_kind_spec (ts, false); |
| |
| /* No kind specifier found. */ |
| if (m == MATCH_NO) |
| m = MATCH_YES; |
| |
| return m; |
| } |
| |
| |
| /******************** FORALL subroutines ********************/ |
| |
| /* Free a list of FORALL iterators. */ |
| |
| void |
| gfc_free_forall_iterator (gfc_forall_iterator *iter) |
| { |
| gfc_forall_iterator *next; |
| |
| while (iter) |
| { |
| next = iter->next; |
| gfc_free_expr (iter->var); |
| gfc_free_expr (iter->start); |
| gfc_free_expr (iter->end); |
| gfc_free_expr (iter->stride); |
| free (iter); |
| iter = next; |
| } |
| } |
| |
| |
| /* Match an iterator as part of a FORALL statement. The format is: |
| |
| <var> = <start>:<end>[:<stride>] |
| |
| On MATCH_NO, the caller tests for the possibility that there is a |
| scalar mask expression. */ |
| |
| static match |
| match_forall_iterator (gfc_forall_iterator **result) |
| { |
| gfc_forall_iterator *iter; |
| locus where; |
| match m; |
| |
| where = gfc_current_locus; |
| iter = XCNEW (gfc_forall_iterator); |
| |
| m = gfc_match_expr (&iter->var); |
| if (m != MATCH_YES) |
| goto cleanup; |
| |
| if (gfc_match_char ('=') != MATCH_YES |
| || iter->var->expr_type != EXPR_VARIABLE) |
| { |
| m = MATCH_NO; |
| goto cleanup; |
| } |
| |
| m = gfc_match_expr (&iter->start); |
| if (m != MATCH_YES) |
| goto cleanup; |
| |
| if (gfc_match_char (':') != MATCH_YES) |
| goto syntax; |
| |
| m = gfc_match_expr (&iter->end); |
| if (m == MATCH_NO) |
| goto syntax; |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| |
| if (gfc_match_char (':') == MATCH_NO) |
| iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); |
| else |
| { |
| m = gfc_match_expr (&iter->stride); |
| if (m == MATCH_NO) |
| goto syntax; |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| } |
| |
| /* Mark the iteration variable's symbol as used as a FORALL index. */ |
| iter->var->symtree->n.sym->forall_index = true; |
| |
| *result = iter; |
| return MATCH_YES; |
| |
| syntax: |
| gfc_error ("Syntax error in FORALL iterator at %C"); |
| m = MATCH_ERROR; |
| |
| cleanup: |
| |
| gfc_current_locus = where; |
| gfc_free_forall_iterator (iter); |
| return m; |
| } |
| |
| |
| /* Match the header of a FORALL statement. */ |
| |
| static match |
| match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) |
| { |
| gfc_forall_iterator *head, *tail, *new_iter; |
| gfc_expr *msk; |
| match m; |
| |
| gfc_gobble_whitespace (); |
| |
| head = tail = NULL; |
| msk = NULL; |
| |
| if (gfc_match_char ('(') != MATCH_YES) |
| return MATCH_NO; |
| |
| m = match_forall_iterator (&new_iter); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| goto syntax; |
| |
| head = tail = new_iter; |
| |
| for (;;) |
| { |
| if (gfc_match_char (',') != MATCH_YES) |
| break; |
| |
| m = match_forall_iterator (&new_iter); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| |
| if (m == MATCH_YES) |
| { |
| tail->next = new_iter; |
| tail = new_iter; |
| continue; |
| } |
| |
| /* Have to have a mask expression. */ |
| |
| m = gfc_match_expr (&msk); |
| if (m == MATCH_NO) |
| goto syntax; |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| |
| break; |
| } |
| |
| if (gfc_match_char (')') == MATCH_NO) |
| goto syntax; |
| |
| *phead = head; |
| *mask = msk; |
| return MATCH_YES; |
| |
| syntax: |
| gfc_syntax_error (ST_FORALL); |
| |
| cleanup: |
| gfc_free_expr (msk); |
| gfc_free_forall_iterator (head); |
| |
| return MATCH_ERROR; |
| } |
| |
| /* Match the rest of a simple FORALL statement that follows an |
| IF statement. */ |
| |
| static match |
| match_simple_forall (void) |
| { |
| gfc_forall_iterator *head; |
| gfc_expr *mask; |
| gfc_code *c; |
| match m; |
| |
| mask = NULL; |
| head = NULL; |
| c = NULL; |
| |
| m = match_forall_header (&head, &mask); |
| |
| if (m == MATCH_NO) |
| goto syntax; |
| if (m != MATCH_YES) |
| goto cleanup; |
| |
| m = gfc_match_assignment (); |
| |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| { |
| m = gfc_match_pointer_assignment (); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| goto syntax; |
| } |
| |
| c = XCNEW (gfc_code); |
| *c = new_st; |
| c->loc = gfc_current_locus; |
| |
| if (gfc_match_eos () != MATCH_YES) |
| goto syntax; |
| |
| gfc_clear_new_st (); |
| new_st.op = EXEC_FORALL; |
| new_st.expr1 = mask; |
| new_st.ext.forall_iterator = head; |
| new_st.block = gfc_get_code (EXEC_FORALL); |
| new_st.block->next = c; |
| |
| return MATCH_YES; |
| |
| syntax: |
| gfc_syntax_error (ST_FORALL); |
| |
| cleanup: |
| gfc_free_forall_iterator (head); |
| gfc_free_expr (mask); |
| |
| return MATCH_ERROR; |
| } |
| |
| |
| /* Match a FORALL statement. */ |
| |
| match |
| gfc_match_forall (gfc_statement *st) |
| { |
| gfc_forall_iterator *head; |
| gfc_expr *mask; |
| gfc_code *c; |
| match m0, m; |
| |
| head = NULL; |
| mask = NULL; |
| c = NULL; |
| |
| m0 = gfc_match_label (); |
| if (m0 == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| m = gfc_match (" forall"); |
| if (m != MATCH_YES) |
| return m; |
| |
| m = match_forall_header (&head, &mask); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| goto syntax; |
| |
| if (gfc_match_eos () == MATCH_YES) |
| { |
| *st = ST_FORALL_BLOCK; |
| new_st.op = EXEC_FORALL; |
| new_st.expr1 = mask; |
| new_st.ext.forall_iterator = head; |
| return MATCH_YES; |
| } |
| |
| m = gfc_match_assignment (); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| { |
| m = gfc_match_pointer_assignment (); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| goto syntax; |
| } |
| |
| c = XCNEW (gfc_code); |
| *c = new_st; |
| c->loc = gfc_current_locus; |
| |
| gfc_clear_new_st (); |
| new_st.op = EXEC_FORALL; |
| new_st.expr1 = mask; |
| new_st.ext.forall_iterator = head; |
| new_st.block = gfc_get_code (EXEC_FORALL); |
| new_st.block->next = c; |
| |
| *st = ST_FORALL; |
| return MATCH_YES; |
| |
| syntax: |
| gfc_syntax_error (ST_FORALL); |
| |
| cleanup: |
| gfc_free_forall_iterator (head); |
| gfc_free_expr (mask); |
| gfc_free_statements (c); |
| return MATCH_NO; |
| } |
| |
| |
| /* Match a DO statement. */ |
| |
| match |
| gfc_match_do (void) |
| { |
| gfc_iterator iter, *ip; |
| locus old_loc; |
| gfc_st_label *label; |
| match m; |
| |
| old_loc = gfc_current_locus; |
| |
| memset (&iter, '\0', sizeof (gfc_iterator)); |
| label = NULL; |
| |
| m = gfc_match_label (); |
| if (m == MATCH_ERROR) |
| return m; |
| |
| if (gfc_match (" do") != MATCH_YES) |
| return MATCH_NO; |
| |
| m = gfc_match_st_label (&label); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| |
| /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ |
| |
| if (gfc_match_eos () == MATCH_YES) |
| { |
| iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); |
| new_st.op = EXEC_DO_WHILE; |
| goto done; |
| } |
| |
| /* Match an optional comma, if no comma is found, a space is obligatory. */ |
| if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) |
| return MATCH_NO; |
| |
| /* Check for balanced parens. */ |
| |
| if (gfc_match_parens () == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| if (gfc_match (" concurrent") == MATCH_YES) |
| { |
| gfc_forall_iterator *head; |
| gfc_expr *mask; |
| |
| if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C")) |
| return MATCH_ERROR; |
| |
| |
| mask = NULL; |
| head = NULL; |
| m = match_forall_header (&head, &mask); |
| |
| if (m == MATCH_NO) |
| return m; |
| if (m == MATCH_ERROR) |
| goto concurr_cleanup; |
| |
| if (gfc_match_eos () != MATCH_YES) |
| goto concurr_cleanup; |
| |
| if (label != NULL |
| && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) |
| goto concurr_cleanup; |
| |
| new_st.label1 = label; |
| new_st.op = EXEC_DO_CONCURRENT; |
| new_st.expr1 = mask; |
| new_st.ext.forall_iterator = head; |
| |
| return MATCH_YES; |
| |
| concurr_cleanup: |
| gfc_syntax_error (ST_DO); |
| gfc_free_expr (mask); |
| gfc_free_forall_iterator (head); |
| return MATCH_ERROR; |
| } |
| |
| /* See if we have a DO WHILE. */ |
| if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) |
| { |
| new_st.op = EXEC_DO_WHILE; |
| goto done; |
| } |
| |
| /* The abortive DO WHILE may have done something to the symbol |
| table, so we start over. */ |
| gfc_undo_symbols (); |
| gfc_current_locus = old_loc; |
| |
| gfc_match_label (); /* This won't error. */ |
| gfc_match (" do "); /* This will work. */ |
| |
| gfc_match_st_label (&label); /* Can't error out. */ |
| gfc_match_char (','); /* Optional comma. */ |
| |
| m = gfc_match_iterator (&iter, 0); |
| if (m == MATCH_NO) |
| return MATCH_NO; |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| |
| iter.var->symtree->n.sym->attr.implied_index = 0; |
| gfc_check_do_variable (iter.var->symtree); |
| |
| if (gfc_match_eos () != MATCH_YES) |
| { |
| gfc_syntax_error (ST_DO); |
| goto cleanup; |
| } |
| |
| new_st.op = EXEC_DO; |
| |
| done: |
| if (label != NULL |
| && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) |
| goto cleanup; |
| |
| new_st.label1 = label; |
| |
| if (new_st.op == EXEC_DO_WHILE) |
| new_st.expr1 = iter.end; |
| else |
| { |
| new_st.ext.iterator = ip = gfc_get_iterator (); |
| *ip = iter; |
| } |
| |
| return MATCH_YES; |
| |
| cleanup: |
| gfc_free_iterator (&iter, 0); |
| |
| return MATCH_ERROR; |
| } |
| |
| |
| /* Match an EXIT or CYCLE statement. */ |
| |
| static match |
| match_exit_cycle (gfc_statement st, gfc_exec_op op) |
| { |
| gfc_state_data *p, *o; |
| gfc_symbol *sym; |
| match m; |
| int cnt; |
| |
| if (gfc_match_eos () == MATCH_YES) |
| sym = NULL; |
| else |
| { |
| char name[GFC_MAX_SYMBOL_LEN + 1]; |
| gfc_symtree* stree; |
| |
| m = gfc_match ("% %n%t", name); |
| if (m == MATCH_ERROR) |
| return MATCH_ERROR; |
| if (m == MATCH_NO) |
| { |
| gfc_syntax_error (st); |
| return MATCH_ERROR; |
| } |
| |
| /* Find the corresponding symbol. If there's a BLOCK statement |
| between here and the label, it is not in gfc_current_ns but a parent |
| namespace! */ |
| stree = gfc_find_symtree_in_proc (name, gfc_current_ns); |
| if (!stree) |
| { |
| gfc_error ("Name %qs in %s statement at %C is unknown", |
| name, gfc_ascii_statement (st)); |
| return MATCH_ERROR; |
| } |
| |
| sym = stree->n.sym; |
| if (sym->attr.flavor != FL_LABEL) |
| { |
| gfc_error ("Name %qs in %s statement at %C is not a construct name", |
| name, gfc_ascii_statement (st)); |
| return MATCH_ERROR; |
| } |
| } |
| |
| /* Find the loop specified by the label (or lack of a label). */ |
| for (o = NULL, p = gfc_state_stack; p; p = p->previous) |
| if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) |
| o = p; |
| else if (p->state == COMP_CRITICAL) |
| { |
| gfc_error("%s statement at %C leaves CRITICAL construct", |
| gfc_ascii_statement (st)); |
| return MATCH_ERROR; |
| } |
| else if (p->state == COMP_DO_CONCURRENT |
| && (op == EXEC_EXIT || (sym && sym != p->sym))) |
| { |
| /* F2008, C821 & C845. */ |
| gfc_error("%s statement at %C leaves DO CONCURRENT construct", |
| gfc_ascii_statement (st)); |
| return MATCH_ERROR; |
| } |
| else if ((sym && sym == p->sym) |
| || (!sym && (p->state == COMP_DO |
| || p->state == COMP_DO_CONCURRENT))) |
| break; |
| |
| if (p == NULL) |
| { |
| if (sym == NULL) |
| gfc_error ("%s statement at %C is not within a construct", |
| gfc_ascii_statement (st)); |
| else |
| gfc_error ("%s statement at %C is not within construct %qs", |
| gfc_ascii_statement (st), sym->name); |
| |
| return MATCH_ERROR; |
| } |
| |
| /* Special checks for EXIT from non-loop constructs. */ |
| switch (p->state) |
| { |
| case COMP_DO: |
| case COMP_DO_CONCURRENT: |
| break; |
| |
| case COMP_CRITICAL: |
| /* This is already handled above. */ |
| gcc_unreachable (); |
| |
| case COMP_ASSOCIATE: |
| case COMP_BLOCK: |
| case COMP_IF: |
| case COMP_SELECT: |
| case COMP_SELECT_TYPE: |
| case COMP_SELECT_RANK: |
| gcc_assert (sym); |
| if (op == EXEC_CYCLE) |
| { |
| gfc_error ("CYCLE statement at %C is not applicable to non-loop" |
| " construct %qs", sym->name); |
| return MATCH_ERROR; |
| } |
| gcc_assert (op == EXEC_EXIT); |
| if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no" |
| " do-construct-name at %C")) |
| return MATCH_ERROR; |
| break; |
| |
| default: |
| gfc_error ("%s statement at %C is not applicable to construct %qs", |
| gfc_ascii_statement (st), sym->name); |
| return MATCH_ERROR; |
| } |
| |
| if (o != NULL) |
| { |
| gfc_error (is_oacc (p) |
| ? G_("%s statement at %C leaving OpenACC structured block") |
| : G_("%s statement at %C leaving OpenMP structured block"), |
| gfc_ascii_statement (st)); |
| return MATCH_ERROR; |
| } |
| |
| for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) |
| o = o->previous; |
| |
| int count = 1; |
| if (cnt > 0 |
| && o != NULL |
| && o->state == COMP_OMP_STRUCTURED_BLOCK) |
| switch (o->head->op) |
| { |
| case EXEC_OACC_LOOP: |
| case EXEC_OACC_KERNELS_LOOP: |
| case EXEC_OACC_PARALLEL_LOOP: |
| case EXEC_OACC_SERIAL_LOOP: |
| gcc_assert (o->head->next != NULL |
| && (o->head->next->op == EXEC_DO |
| || o->head->next->op == EXEC_DO_WHILE) |
| && o->previous != NULL |
| && o->previous->tail->op == o->head->op); |
| if (o->previous->tail->ext.omp_clauses != NULL) |
| { |
| /* Both collapsed and tiled loops are lowered the same way, but are |
| not compatible. In gfc_trans_omp_do, the tile is prioritized. */ |
| if (o->previous->tail->ext.omp_clauses->tile_list) |
| { |
| count = 0; |
| gfc_expr_list *el |
| = o->previous->tail->ext.omp_clauses->tile_list; |
| for ( ; el; el = el->next) |
| ++count; |
| } |
| else if (o->previous->tail->ext.omp_clauses->collapse > 1) |
| count = o->previous->tail->ext.omp_clauses->collapse; |
| } |
| if (st == ST_EXIT && cnt <= count) |
| { |
| gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop"); |
| return MATCH_ERROR; |
| } |
| if (st == ST_CYCLE && cnt < count) |
| { |
| gfc_error (o->previous->tail->ext.omp_clauses->tile_list |
| ? G_("CYCLE statement at %C to non-innermost tiled " |
| "!$ACC LOOP loop") |
| : G_("CYCLE statement at %C to non-innermost collapsed " |
| "!$ACC LOOP loop")); |
| return MATCH_ERROR; |
| } |
| break; |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_SIMD: |
| case EXEC_OMP_TASKLOOP_SIMD: |
| case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
| case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
| case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
| case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
| case EXEC_OMP_PARALLEL_DO_SIMD: |
| case EXEC_OMP_DISTRIBUTE_SIMD: |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
| case EXEC_OMP_LOOP: |
| case EXEC_OMP_PARALLEL_LOOP: |
| case EXEC_OMP_TEAMS_LOOP: |
| case EXEC_OMP_TARGET_PARALLEL_LOOP: |
| case EXEC_OMP_TARGET_TEAMS_LOOP: |
| case EXEC_OMP_DO: |
| case EXEC_OMP_PARALLEL_DO: |
| case EXEC_OMP_SIMD: |
| case EXEC_OMP_DO_SIMD: |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TARGET_PARALLEL_DO: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| |
| gcc_assert (o->head->next != NULL |
| && (o->head->next->op == EXEC_DO |
| || o->head->next->op == EXEC_DO_WHILE) |
| && o->previous != NULL |
| && o->previous->tail->op == o->head->op); |
| if (o->previous->tail->ext.omp_clauses != NULL) |
| { |
| if (o->previous->tail->ext.omp_clauses->collapse > 1) |
| count = o->previous->tail->ext.omp_clauses->collapse; |
| if (o->previous->tail->ext.omp_clauses->orderedc) |
| count = o->previous->tail->ext.omp_clauses->orderedc; |
| } |
| if (st == ST_EXIT && cnt <= count) |
| { |
| gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); |
| return MATCH_ERROR; |
| } |
| if (st == ST_CYCLE && cnt < count) |
| { |
| gfc_error ("CYCLE statement at %C to non-innermost collapsed " |
| "!$OMP DO loop"); |
| return MATCH_ERROR; |
| } |
| break; |
| default: |
| break; |
| } |
| |
| /* Save the first statement in the construct - needed by the backend. */ |
| new_st.ext.which_construct = p->construct; |
| |
| new_st.op = op; |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Match the EXIT statement. */ |
| |
| match |
| gfc_match_exit (void) |
| { |
| return match_exit_cycle (ST_EXIT, EXEC_EXIT); |
| } |
| |
| |
| /* Match the CYCLE statement. */ |
| |
| match |
| gfc_match_cycle (void) |
| { |
| return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); |
| } |
| |
| |
| /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The |
| requirements for a stop-code differ in the standards. |
| |
| Fortran 95 has |
| |
| R840 stop-stmt is STOP [ stop-code ] |
| R841 stop-code is scalar-char-constant |
| or digit [ digit [ digit [ digit [ digit ] ] ] ] |
| |
| Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850. |
| Fortran 2008 has |
| |
| R855 stop-stmt is STOP [ stop-code ] |
| R856 allstop-stmt is ALL STOP [ stop-code ] |
| R857 stop-code is scalar-default-char-constant-expr |
| or scalar-int-constant-expr |
| Fortran 2018 has |
| |
| R1160 stop-stmt is STOP [ stop-code ] [ , QUIET = scalar-logical-expr] |
| R1161 error-stop-stmt is |
| ERROR STOP [ stop-code ] [ , QUIET = scalar-logical-expr] |
| R1162 stop-code is scalar-default-char-expr |
| or scalar-int-expr |
| |
| For free-form source code, all standards contain a statement of the form: |
| |
| A blank shall be used to separate names, constants, or labels from |
| adjacent keywords, names, constants, or labels. |
| |
| A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003, |
| |
| STOP123 |
| |
| is valid, but it is invalid Fortran 2008. */ |
| |
| static match |
| gfc_match_stopcode (gfc_statement st) |
| { |
| gfc_expr *e = NULL; |
| gfc_expr *quiet = NULL; |
| match m; |
| bool f95, f03, f08; |
| char c; |
| |
| /* Set f95 for -std=f95. */ |
| f95 = (gfc_option.allow_std == GFC_STD_OPT_F95); |
| |
| /* Set f03 for -std=f2003. */ |
| f03 = (gfc_option.allow_std == GFC_STD_OPT_F03); |
| |
| /* Set f08 for -std=f2008. */ |
| f08 = (gfc_option.allow_std == GFC_STD_OPT_F08); |
| |
| /* Plain STOP statement? */ |
| if (gfc_match_eos () == MATCH_YES) |
| goto checks; |
| |
| /* Look for a blank between STOP and the stop-code for F2008 or later. |
| But allow for F2018's ,QUIET= specifier. */ |
| c = gfc_peek_ascii_char (); |
| |
| if (gfc_current_form != FORM_FIXED && !(f95 || f03) && c != ',') |
| { |
| /* Look for end-of-statement. There is no stop-code. */ |
| if (c == '\n' || c == '!' || c == ';') |
| goto done; |
| |
| if (c != ' ') |
| { |
| gfc_error ("Blank required in %s statement near %C", |
| gfc_ascii_statement (st)); |
| return MATCH_ERROR; |
| } |
| } |
| |
| if (c == ' ') |
| { |
| gfc_gobble_whitespace (); |
| c = gfc_peek_ascii_char (); |
| } |
| if (c != ',') |
| { |
| int stopcode; |
| locus old_locus; |
| |
| /* First look for the F95 or F2003 digit [...] construct. */ |
| old_locus = gfc_current_locus; |
| m = gfc_match_small_int (&stopcode); |
| if (m == MATCH_YES && (f95 || f03)) |
| { |
| if (stopcode < 0) |
| { |
| gfc_error ("STOP code at %C cannot be negative"); |
| return MATCH_ERROR; |
| } |
| |
| if (stopcode > 99999) |
| { |
| gfc_error ("STOP code at %C contains too many digits"); |
| return MATCH_ERROR; |
| } |
| } |
| |
| /* Reset the locus and now load gfc_expr. */ |
| gfc_current_locus = old_locus; |
| m = gfc_match_expr (&e); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| goto syntax; |
| } |
| |
| if (gfc_match (" , quiet = %e", &quiet) == MATCH_YES) |
| { |
| if (!gfc_notify_std (GFC_STD_F2018, "QUIET= specifier for %s at %L", |
| gfc_ascii_statement (st), &quiet->where)) |
| goto cleanup; |
| } |
| |
| if (gfc_match_eos () != MATCH_YES) |
| goto syntax; |
| |
| checks: |
| |
| if (gfc_pure (NULL)) |
| { |
| if (st == ST_ERROR_STOP) |
| { |
| if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE " |
| "procedure", gfc_ascii_statement (st))) |
| goto cleanup; |
| } |
| else |
| { |
| gfc_error ("%s statement not allowed in PURE procedure at %C", |
| gfc_ascii_statement (st)); |
| goto cleanup; |
| } |
| } |
| |
| gfc_unset_implicit_pure (NULL); |
| |
| if (st == ST_STOP && gfc_find_state (COMP_CRITICAL)) |
| { |
| gfc_error ("Image control statement STOP at %C in CRITICAL block"); |
| goto cleanup; |
| } |
| if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT)) |
| { |
| gfc_error ("Image control statement STOP at %C in DO CONCURRENT block"); |
| goto cleanup; |
| } |
| |
| if (e != NULL) |
| { |
| if (!gfc_simplify_expr (e, 0)) |
| goto cleanup; |
| |
| /* Test for F95 and F2003 style STOP stop-code. */ |
| if (e->expr_type != EXPR_CONSTANT && (f95 || f03)) |
| { |
| gfc_error ("STOP code at %L must be a scalar CHARACTER constant " |
| "or digit[digit[digit[digit[digit]]]]", &e->where); |
| goto cleanup; |
| } |
| |
| /* Use the machinery for an initialization expression to reduce the |
| stop-code to a constant. */ |
| gfc_reduce_init_expr (e); |
| |
| /* Test for F2008 style STOP stop-code. */ |
| if (e->expr_type != EXPR_CONSTANT && f08) |
| { |
| gfc_error ("STOP code at %L must be a scalar default CHARACTER or " |
| "INTEGER constant expression", &e->where); |
| goto cleanup; |
| } |
| |
| if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) |
| { |
| gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", |
| &e->where); |
| goto cleanup; |
| } |
| |
| if (e->rank != 0) |
| { |
| gfc_error ("STOP code at %L must be scalar", &e->where); |
| goto cleanup; |
| } |
| |
| if (e->ts.type == BT_CHARACTER |
| && e->ts.kind != gfc_default_character_kind) |
| { |
| gfc_error ("STOP code at %L must be default character KIND=%d", |
| &e->where, (int) gfc_default_character_kind); |
| goto cleanup; |
| } |
| |
| if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind |
| && !gfc_notify_std (GFC_STD_F2018, |
| "STOP code at %L must be default integer KIND=%d", |
| &e->where, (int) gfc_default_integer_kind)) |
| goto cleanup; |
| } |
| |
| if (quiet != NULL) |
| { |
| if (!gfc_simplify_expr (quiet, 0)) |
| goto cleanup; |
| |
| if (quiet->rank != 0) |
| { |
| gfc_error ("QUIET specifier at %L must be a scalar LOGICAL", |
| &quiet->where); |
| goto cleanup; |
| } |
| } |
| |
| done: |
| |
| switch (st) |
| { |
| case ST_STOP: |
| new_st.op = EXEC_STOP; |
| break; |
| case ST_ERROR_STOP: |
| new_st.op = EXEC_ERROR_STOP; |
| break; |
| case ST_PAUSE: |
| new_st.op = EXEC_PAUSE; |
| break; |
| default: |
| gcc_unreachable (); |
| } |
| |
| new_st.expr1 = e; |
| new_st.expr2 = quiet; |
| new_st.ext.stop_code = -1; |
| |
| return MATCH_YES; |
| |
| syntax: |
| gfc_syntax_error (st); |
| |
| cleanup: |
| |
| gfc_free_expr (e); |
| gfc_free_expr (quiet); |
| return MATCH_ERROR; |
| } |
| |
| |
| /* Match the (deprecated) PAUSE statement. */ |
| |
| match |
| gfc_match_pause (void) |
| { |
| match m; |
| |
| m = gfc_match_stopcode (ST_PAUSE); |
| if (m == MATCH_YES) |
| { |
| if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C")) |
| m = MATCH_ERROR; |
| } |
| return m; |
| } |
| |
| |
| /* Match the STOP statement. */ |
| |
| match |
| gfc_match_stop (void) |
| { |
| return gfc_match_stopcode (ST_STOP); |
| } |
| |
| |
| /* Match the ERROR STOP statement. */ |
| |
| match |
| gfc_match_error_stop (void) |
| { |
| if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C")) |
| return MATCH_ERROR; |
| |
| return gfc_match_stopcode (ST_ERROR_STOP); |
| } |
| |
| /* Match EVENT POST/WAIT statement. Syntax: |
| EVENT POST ( event-variable [, sync-stat-list] ) |
| EVENT WAIT ( event-variable [, wait-spec-list] ) |
| with |
| wait-spec-list is sync-stat-list or until-spec |
| until-spec is UNTIL_COUNT = scalar-int-expr |
| sync-stat is STAT= or ERRMSG=. */ |
| |
| static match |
| event_statement (gfc_statement st) |
| { |
| match m; |
| gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg; |
| bool saw_until_count, saw_stat, saw_errmsg; |
| |
| tmp = eventvar = until_count = stat = errmsg = NULL; |
| saw_until_count = saw_stat = saw_errmsg = false; |
| |
| if (gfc_pure (NULL)) |
| { |
| gfc_error ("Image control statement EVENT %s at %C in PURE procedure", |
| st == ST_EVENT_POST ? "POST" : "WAIT"); |
| return MATCH_ERROR; |
| } |
| |
| gfc_unset_implicit_pure (NULL); |
| |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_find_state (COMP_CRITICAL)) |
| { |
| gfc_error ("Image control statement EVENT %s at %C in CRITICAL block", |
| st == ST_EVENT_POST ? "POST" : "WAIT"); |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_find_state (COMP_DO_CONCURRENT)) |
| { |
| gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT " |
| "block", st == ST_EVENT_POST ? "POST" : "WAIT"); |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_match_char ('(') != MATCH_YES) |
| goto syntax; |
| |
| if (gfc_match ("%e", &eventvar) != MATCH_YES) |
| goto syntax; |
| m = gfc_match_char (','); |
| if (m == MATCH_ERROR) |
| goto syntax; |
| if (m == MATCH_NO) |
| { |
| m = gfc_match_char (')'); |
| if (m == MATCH_YES) |
| goto done; |
| goto syntax; |
| } |
| |
| for (;;) |
| { |
| m = gfc_match (" stat = %v", &tmp); |
| if (m == MATCH_ERROR) |
| goto syntax; |
| if (m == MATCH_YES) |
| { |
| if (saw_stat) |
| { |
| gfc_error ("Redundant STAT tag found at %L", &tmp->where); |
| goto cleanup; |
| } |
| stat = tmp; |
| saw_stat = true; |
| |
| m = gfc_match_char (','); |
| if (m == MATCH_YES) |
| continue; |
| |
| tmp = NULL; |
| break; |
| } |
| |
| m = gfc_match (" errmsg = %v", &tmp); |
| if (m == MATCH_ERROR) |
| goto syntax; |
| if (m == MATCH_YES) |
| { |
| if (saw_errmsg) |
| { |
| gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); |
| goto cleanup; |
| } |
| errmsg = tmp; |
| saw_errmsg = true; |
| |
| m = gfc_match_char (','); |
| if (m == MATCH_YES) |
| continue; |
| |
| tmp = NULL; |
| break; |
| } |
| |
| m = gfc_match (" until_count = %e", &tmp); |
| if (m == MATCH_ERROR || st == ST_EVENT_POST) |
| goto syntax; |
| if (m == MATCH_YES) |
| { |
| if (saw_until_count) |
| { |
| gfc_error ("Redundant UNTIL_COUNT tag found at %L", |
| &tmp->where); |
| goto cleanup |