X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fmatch.c;h=f21748c1b9ae4cdd395a9a1a4b5fd952209c00c6;hp=6c7251f05c0314aea9285f0d2004f2bb8024e52a;hb=922715fd70a4c052eeb69eff2a0a02b49610a2cf;hpb=6cbc841e3b888760aa462440bbb50dde2d2d6841 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 6c7251f05c0..f21748c1b9a 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1,13 +1,13 @@ /* Matching subroutines in all sizes, shapes and colors. - Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, - Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 + 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 2, or (at your option) any later +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 @@ -16,58 +16,206 @@ 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 COPYING. If not, write to the Free -Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. */ - +along with GCC; see the file COPYING3. If not see +. */ #include "config.h" #include "system.h" #include "flags.h" - -#include -#include - #include "gfortran.h" #include "match.h" #include "parse.h" -/* For matching and debugging purposes. Order matters here! The - unary operators /must/ precede the binary plus and minus, or - the expression parser breaks. */ - -mstring intrinsic_operators[] = { - minit ("+", INTRINSIC_UPLUS), - minit ("-", INTRINSIC_UMINUS), - minit ("+", INTRINSIC_PLUS), - minit ("-", INTRINSIC_MINUS), - minit ("**", INTRINSIC_POWER), - minit ("//", INTRINSIC_CONCAT), - minit ("*", INTRINSIC_TIMES), - minit ("/", INTRINSIC_DIVIDE), - minit (".and.", INTRINSIC_AND), - minit (".or.", INTRINSIC_OR), - minit (".eqv.", INTRINSIC_EQV), - minit (".neqv.", INTRINSIC_NEQV), - minit (".eq.", INTRINSIC_EQ), - minit ("==", INTRINSIC_EQ), - minit (".ne.", INTRINSIC_NE), - minit ("/=", INTRINSIC_NE), - minit (".ge.", INTRINSIC_GE), - minit (">=", INTRINSIC_GE), - minit (".le.", INTRINSIC_LE), - minit ("<=", INTRINSIC_LE), - minit (".lt.", INTRINSIC_LT), - minit ("<", INTRINSIC_LT), - minit (".gt.", INTRINSIC_GT), - minit (">", INTRINSIC_GT), - minit (".not.", INTRINSIC_NOT), - minit (NULL, INTRINSIC_NONE) -}; + +/* 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"; + + default: + break; + } + + gfc_internal_error ("gfc_op2string(): Bad code"); + /* Not reached. */ +} /******************** Generic matching subroutines ************************/ +/* 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 c, count, instring; + char quote; + + old_loc = gfc_current_locus; + count = 0; + instring = 0; + quote = ' '; + + for (;;) + { + c = gfc_next_char_literal (instring); + if (c == '\n') + break; + if (quote == ' ' && ((c == '\'') || (c == '"'))) + { + quote = (char) c; + instring = 1; + continue; + } + if (quote != ' ' && c == quote) + { + quote = ' '; + instring = 0; + continue; + } + + if (c == '(' && quote == ' ') + { + count++; + where = gfc_current_locus; + } + if (c == ')' && quote == ' ') + { + count--; + where = gfc_current_locus; + } + } + + gfc_current_locus = old_loc; + + if (count > 0) + { + gfc_error ("Missing ')' in statement before %L", &where); + return MATCH_ERROR; + } + if (count < 0) + { + gfc_error ("Missing '(' in statement before %L", &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 (int *c) +{ + + match m; + + m = MATCH_YES; + + switch (gfc_next_char_literal (1)) + { + case 'a': + *c = '\a'; + break; + case 'b': + *c = '\b'; + break; + case 't': + *c = '\t'; + break; + case 'f': + *c = '\f'; + break; + case 'n': + *c = '\n'; + break; + case 'r': + *c = '\r'; + break; + case 'v': + *c = '\v'; + break; + case '\\': + *c = '\\'; + break; + case '0': + *c = '\0'; + 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. */ @@ -80,12 +228,12 @@ gfc_match_space (void) if (gfc_current_form == FORM_FIXED) return MATCH_YES; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; c = gfc_next_char (); if (!gfc_is_whitespace (c)) { - gfc_set_locus (&old_loc); + gfc_current_locus = old_loc; return MATCH_NO; } @@ -109,7 +257,7 @@ gfc_match_eos (void) for (;;) { - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; gfc_gobble_whitespace (); c = gfc_next_char (); @@ -122,7 +270,7 @@ gfc_match_eos (void) } while (c != '\n'); - /* Fall through */ + /* Fall through. */ case '\n': return MATCH_YES; @@ -135,44 +283,49 @@ gfc_match_eos (void) break; } - gfc_set_locus (&old_loc); + 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. */ + 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) +gfc_match_small_literal_int (int *value, int *cnt) { locus old_loc; char c; - int i; + int i, j; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; gfc_gobble_whitespace (); c = gfc_next_char (); + if (cnt) + *cnt = 0; if (!ISDIGIT (c)) { - gfc_set_locus (&old_loc); + gfc_current_locus = old_loc; return MATCH_NO; } i = c - '0'; + j = 1; for (;;) { - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; c = gfc_next_char (); if (!ISDIGIT (c)) break; i = 10 * i + c - '0'; + j++; if (i > 99999999) { @@ -181,9 +334,11 @@ gfc_match_small_literal_int (int *value) } } - gfc_set_locus (&old_loc); + gfc_current_locus = old_loc; *value = i; + if (cnt) + *cnt = j; return MATCH_YES; } @@ -217,30 +372,72 @@ gfc_match_small_int (int *value) } +/* This function is the same as the gfc_match_small_int, except that + we're keeping the pointer to the expr. This function could just be + removed and the previously mentioned one modified, though all calls + to it would have to be modified then (and there were a number of + them). Return MATCH_ERROR if fail to extract the int; otherwise, + return the result of gfc_match_expr(). The expr (if any) that was + matched is returned in the parameter expr. */ + +match +gfc_match_small_int_expr (int *value, gfc_expr **expr) +{ + const char *p; + match m; + int i; + + m = gfc_match_expr (expr); + if (m != MATCH_YES) + return m; + + p = gfc_extract_int (*expr, &i); + + if (p != NULL) + { + gfc_error (p); + m = MATCH_ERROR; + } + + *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, int allow_zero) +gfc_match_st_label (gfc_st_label **label) { locus old_loc; match m; - int i; + int i, cnt; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; - m = gfc_match_small_literal_int (&i); + m = gfc_match_small_literal_int (&i, &cnt); if (m != MATCH_YES) return m; - if (((i == 0) && allow_zero) || i <= 99999) + if (cnt > 5) { - *label = gfc_get_st_label (i); - return MATCH_YES; + 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; } - gfc_error ("Statement label at %C is out of range"); - gfc_set_locus (&old_loc); + *label = gfc_get_st_label (i); + return MATCH_YES; + +cleanup: + + gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -254,7 +451,6 @@ match gfc_match_label (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_state_data *p; match m; gfc_new_block = NULL; @@ -269,147 +465,155 @@ gfc_match_label (void) return MATCH_ERROR; } - if (gfc_new_block->attr.flavor != FL_LABEL - && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, NULL) == FAILURE) - return MATCH_ERROR; + if (gfc_new_block->attr.flavor == FL_LABEL) + { + gfc_error ("Duplicate construct label '%s' at %C", name); + return MATCH_ERROR; + } - for (p = gfc_state_stack; p; p = p->previous) - if (p->sym == gfc_new_block) - { - gfc_error ("Label %s at %C already in use by a parent block", - gfc_new_block->name); - return MATCH_ERROR; - } + if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, + gfc_new_block->name, NULL) == FAILURE) + return MATCH_ERROR; return MATCH_YES; } -/* Try and match the input against an array of possibilities. If one - potential matching string is a substring of another, the longest - match takes precedence. Spaces in the target strings are optional - spaces that do not necessarily have to be found in the input - stream. In fixed mode, spaces never appear. If whitespace is - matched, it matches unlimited whitespace in the input. For this - reason, the 'mp' member of the mstring structure is used to track - the progress of each potential match. - - If there is no match we return the tag associated with the - terminating NULL mstring structure and leave the locus pointer - where it started. If there is a match we return the tag member of - the matched mstring and leave the locus pointer after the matched - character. - - A '%' character is a mandatory space. */ +/* 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.c restricts max_identifier_length to not more + than GFC_MAX_SYMBOL_LEN. */ -int -gfc_match_strings (mstring * a) +match +gfc_match_name (char *buffer) { - mstring *p, *best_match; - int no_match, c, possibles; - locus match_loc; + locus old_loc; + int i, c; - possibles = 0; + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); - for (p = a; p->string != NULL; p++) + c = gfc_next_char (); + if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore))) { - p->mp = p->string; - possibles++; + if (gfc_error_flag_test() == 0 && c != '(') + gfc_error ("Invalid character in name at %C"); + gfc_current_locus = old_loc; + return MATCH_NO; } - no_match = p->tag; - - best_match = NULL; - match_loc = *gfc_current_locus (); - - gfc_gobble_whitespace (); + i = 0; - while (possibles > 0) + do { - c = gfc_next_char (); + buffer[i++] = c; - /* Apply the next character to the current possibilities. */ - for (p = a; p->string != NULL; p++) + if (i > gfc_option.max_identifier_length) { - if (p->mp == NULL) - continue; - - if (*p->mp == ' ') - { - /* Space matches 1+ whitespace(s). */ - if ((gfc_current_form == FORM_FREE) - && gfc_is_whitespace (c)) - continue; - - p->mp++; - } - - if (*p->mp != c) - { - /* Match failed. */ - p->mp = NULL; - possibles--; - continue; - } - - p->mp++; - if (*p->mp == '\0') - { - /* Found a match. */ - match_loc = *gfc_current_locus (); - best_match = p; - possibles--; - p->mp = NULL; - } + gfc_error ("Name at %C is too long"); + return MATCH_ERROR; } + + old_loc = gfc_current_locus; + c = gfc_next_char (); } + while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$')); - gfc_set_locus (&match_loc); + buffer[i] = '\0'; + gfc_current_locus = old_loc; - return (best_match == NULL) ? no_match : best_match->tag; + 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. */ +/* Match a valid name for C, which is almost the same as for Fortran, + except that you can start with an underscore, etc.. It could have + been done by modifying the gfc_match_name, but this way other + things C allows can be added, such as no limits on the length. + Right now, the length is limited to the same thing as Fortran.. + Also, by rewriting it, we use the gfc_next_char_C() to prevent the + input characters from being automatically lower cased, since C is + case sensitive. The parameter, buffer, is used to return the name + that is matched. Return MATCH_ERROR if the name is too long + (though this is a self-imposed limit), MATCH_NO if what we're + seeing isn't a name, and MATCH_YES if we successfully match a C + name. */ match -gfc_match_name (char *buffer) +gfc_match_name_C (char *buffer) { locus old_loc; - int i, c; + int i = 0; + int c; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_char (); - if (!ISALPHA (c)) + /* Get the next char (first possible char of name) and see if + it's valid for C (either a letter or an underscore). */ + c = gfc_next_char_literal (1); + + /* If the user put nothing expect spaces between the quotes, it is valid + and simply means there is no name= specifier and the name is the fortran + symbol name, all lowercase. */ + if (c == '"' || c == '\'') { - gfc_set_locus (&old_loc); - return MATCH_NO; + buffer[0] = '\0'; + gfc_current_locus = old_loc; + return MATCH_YES; + } + + if (!ISALPHA (c) && c != '_') + { + gfc_error ("Invalid C name in NAME= specifier at %C"); + return MATCH_ERROR; } - i = 0; - + /* Continue to read valid variable name characters. */ do { buffer[i++] = c; - + + /* C does not define a maximum length of variable names, to my + knowledge, but the compiler typically places a limit on them. + For now, i'll use the same as the fortran limit for simplicity, + but this may need to be changed to a dynamic buffer that can + be realloc'ed here if necessary, or more likely, a larger + upper-bound set. */ 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_char (); - } - while (ISALNUM (c) - || c == '_' - || (gfc_option.flag_dollar_ok && c == '$')); + { + gfc_error ("Name at %C is too long"); + return MATCH_ERROR; + } + + old_loc = gfc_current_locus; + + /* Get next char; param means we're in a string. */ + c = gfc_next_char_literal (1); + } while (ISALNUM (c) || c == '_'); buffer[i] = '\0'; - gfc_set_locus (&old_loc); + gfc_current_locus = old_loc; + + /* See if we stopped because of whitespace. */ + if (c == ' ') + { + gfc_gobble_whitespace (); + c = gfc_peek_char (); + if (c != '"' && c != '\'') + { + gfc_error ("Embedded space in NAME= specifier at %C"); + return MATCH_ERROR; + } + } + + /* If we stopped because we had an invalid character for a C name, report + that to the user by returning MATCH_NO. */ + if (c != '"' && c != '\'') + { + gfc_error ("Invalid C name in NAME= specifier at %C"); + return MATCH_ERROR; + } return MATCH_YES; } @@ -419,7 +623,7 @@ gfc_match_name (char *buffer) pointer if successful. */ match -gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc) +gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) { char buffer[GFC_MAX_SYMBOL_LEN + 1]; match m; @@ -430,7 +634,7 @@ gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc) if (host_assoc) return (gfc_get_ha_sym_tree (buffer, matched_symbol)) - ? MATCH_ERROR : MATCH_YES; + ? MATCH_ERROR : MATCH_YES; if (gfc_get_sym_tree (buffer, NULL, matched_symbol)) return MATCH_ERROR; @@ -440,7 +644,7 @@ gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc) match -gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc) +gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) { gfc_symtree *st; match m; @@ -450,61 +654,272 @@ gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc) if (m == MATCH_YES) { if (st) - *matched_symbol = st->n.sym; + *matched_symbol = st->n.sym; else - *matched_symbol = NULL; + *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.c. */ match -gfc_match_intrinsic_op (gfc_intrinsic_op * result) +gfc_match_intrinsic_op (gfc_intrinsic_op *result) { - gfc_intrinsic_op op; + locus orig_loc = gfc_current_locus; + int ch; - op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators); + gfc_gobble_whitespace (); + ch = gfc_next_char (); + switch (ch) + { + case '+': + /* Matched "+". */ + *result = INTRINSIC_PLUS; + return MATCH_YES; - if (op == INTRINSIC_NONE) - return MATCH_NO; + case '-': + /* Matched "-". */ + *result = INTRINSIC_MINUS; + return MATCH_YES; - *result = op; - return MATCH_YES; -} + case '=': + if (gfc_next_char () == '=') + { + /* Matched "==". */ + *result = INTRINSIC_EQ; + return MATCH_YES; + } + break; + case '<': + if (gfc_peek_char () == '=') + { + /* Matched "<=". */ + gfc_next_char (); + *result = INTRINSIC_LE; + return MATCH_YES; + } + /* Matched "<". */ + *result = INTRINSIC_LT; + return MATCH_YES; -/* Match a loop control phrase: + case '>': + if (gfc_peek_char () == '=') + { + /* Matched ">=". */ + gfc_next_char (); + *result = INTRINSIC_GE; + return MATCH_YES; + } + /* Matched ">". */ + *result = INTRINSIC_GT; + return MATCH_YES; - = , [, ] + case '*': + if (gfc_peek_char () == '*') + { + /* Matched "**". */ + gfc_next_char (); + *result = INTRINSIC_POWER; + return MATCH_YES; + } + /* Matched "*". */ + *result = INTRINSIC_TIMES; + return MATCH_YES; - 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. */ + case '/': + ch = gfc_peek_char (); + if (ch == '=') + { + /* Matched "/=". */ + gfc_next_char (); + *result = INTRINSIC_NE; + return MATCH_YES; + } + else if (ch == '/') + { + /* Matched "//". */ + gfc_next_char (); + *result = INTRINSIC_CONCAT; + return MATCH_YES; + } + /* Matched "/". */ + *result = INTRINSIC_DIVIDE; + return MATCH_YES; -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; + case '.': + ch = gfc_next_char (); + switch (ch) + { + case 'a': + if (gfc_next_char () == 'n' + && gfc_next_char () == 'd' + && gfc_next_char () == '.') + { + /* Matched ".and.". */ + *result = INTRINSIC_AND; + return MATCH_YES; + } + break; - /* Match the start of an iterator without affecting the symbol - table. */ + case 'e': + if (gfc_next_char () == 'q') + { + ch = gfc_next_char (); + if (ch == '.') + { + /* Matched ".eq.". */ + *result = INTRINSIC_EQ_OS; + return MATCH_YES; + } + else if (ch == 'v') + { + if (gfc_next_char () == '.') + { + /* Matched ".eqv.". */ + *result = INTRINSIC_EQV; + return MATCH_YES; + } + } + } + break; - start = *gfc_current_locus (); - m = gfc_match (" %n =", name); - gfc_set_locus (&start); + case 'g': + ch = gfc_next_char (); + if (ch == 'e') + { + if (gfc_next_char () == '.') + { + /* Matched ".ge.". */ + *result = INTRINSIC_GE_OS; + return MATCH_YES; + } + } + else if (ch == 't') + { + if (gfc_next_char () == '.') + { + /* Matched ".gt.". */ + *result = INTRINSIC_GT_OS; + return MATCH_YES; + } + } + break; - if (m != MATCH_YES) - return MATCH_NO; + case 'l': + ch = gfc_next_char (); + if (ch == 'e') + { + if (gfc_next_char () == '.') + { + /* Matched ".le.". */ + *result = INTRINSIC_LE_OS; + return MATCH_YES; + } + } + else if (ch == 't') + { + if (gfc_next_char () == '.') + { + /* Matched ".lt.". */ + *result = INTRINSIC_LT_OS; + return MATCH_YES; + } + } + break; - m = gfc_match_variable (&var, 0); - if (m != MATCH_YES) - return MATCH_NO; + case 'n': + ch = gfc_next_char (); + if (ch == 'e') + { + ch = gfc_next_char (); + if (ch == '.') + { + /* Matched ".ne.". */ + *result = INTRINSIC_NE_OS; + return MATCH_YES; + } + else if (ch == 'q') + { + if (gfc_next_char () == 'v' + && gfc_next_char () == '.') + { + /* Matched ".neqv.". */ + *result = INTRINSIC_NEQV; + return MATCH_YES; + } + } + } + else if (ch == 'o') + { + if (gfc_next_char () == 't' + && gfc_next_char () == '.') + { + /* Matched ".not.". */ + *result = INTRINSIC_NOT; + return MATCH_YES; + } + } + break; + + case 'o': + if (gfc_next_char () == 'r' + && gfc_next_char () == '.') + { + /* Matched ".or.". */ + *result = INTRINSIC_OR; + return MATCH_YES; + } + break; + + default: + break; + } + break; + + default: + break; + } + + gfc_current_locus = orig_loc; + return MATCH_NO; +} + + +/* Match a loop control phrase: + + = , [, ] + + 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; + + /* 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; gfc_match_char ('='); @@ -523,11 +938,7 @@ gfc_match_iterator (gfc_iterator * iter, int init_flag) goto cleanup; } - if (var->symtree->n.sym->attr.pointer) - { - gfc_error ("Loop variable at %C cannot have the POINTER attribute"); - goto cleanup; - } + var->symtree->n.sym->attr.implied_index = 1; m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); if (m == MATCH_NO) @@ -586,13 +997,13 @@ gfc_match_char (char c) { locus where; - where = *gfc_current_locus (); + where = gfc_current_locus; gfc_gobble_whitespace (); if (gfc_next_char () == c) return MATCH_YES; - gfc_set_locus (&where); + gfc_current_locus = where; return MATCH_NO; } @@ -624,7 +1035,7 @@ gfc_match (const char *target, ...) void **vp; const char *p; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; va_start (argp, target); m = MATCH_NO; matches = 0; @@ -695,7 +1106,7 @@ loop: case 'l': label = va_arg (argp, gfc_st_label **); - n = gfc_match_st_label (label, 0); + n = gfc_match_st_label (label); if (n != MATCH_YES) { m = n; @@ -732,7 +1143,7 @@ loop: goto not_yes; case '%': - break; /* Fall through to character matcher */ + break; /* Fall through to character matcher. */ default: gfc_internal_error ("gfc_match(): Bad match code %c", c); @@ -750,7 +1161,7 @@ not_yes: if (m != MATCH_YES) { /* Clean up after a failed match. */ - gfc_set_locus (&old_loc); + gfc_current_locus = old_loc; va_start (argp, target); p = target; @@ -762,14 +1173,14 @@ not_yes: { case '%': matches++; - break; /* Skip */ + break; /* Skip. */ /* Matches that don't have to be undone */ case 'o': case 'l': case 'n': case 's': - (void)va_arg (argp, void **); + (void) va_arg (argp, void **); break; case 'e': @@ -791,7 +1202,7 @@ not_yes: /*********************** Statement level matching **********************/ /* Matches the start of a program unit, which is the program keyword - followed by an optional symbol. */ + followed by an obligatory symbol. */ match gfc_match_program (void) @@ -799,10 +1210,6 @@ gfc_match_program (void) gfc_symbol *sym; match m; - m = gfc_match_eos (); - if (m == MATCH_YES) - return m; - m = gfc_match ("% %s%t", &sym); if (m == MATCH_NO) @@ -814,7 +1221,7 @@ gfc_match_program (void) if (m == MATCH_ERROR) return m; - if (gfc_add_flavor (&sym->attr, FL_PROGRAM, NULL) == FAILURE) + if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE) return MATCH_ERROR; gfc_new_block = sym; @@ -832,16 +1239,35 @@ gfc_match_assignment (void) locus old_loc; match m; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; - lvalue = rvalue = NULL; + lvalue = NULL; m = gfc_match (" %v =", &lvalue); if (m != MATCH_YES) - goto cleanup; + { + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + return MATCH_NO; + } + + if (lvalue->symtree->n.sym->attr.protected + && lvalue->symtree->n.sym->attr.use_assoc) + { + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + gfc_error ("Setting value of PROTECTED variable at %C"); + return MATCH_ERROR; + } + rvalue = NULL; m = gfc_match (" %e%t", &rvalue); if (m != MATCH_YES) - goto cleanup; + { + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + gfc_free_expr (rvalue); + return m; + } gfc_set_sym_referenced (lvalue->symtree->n.sym); @@ -849,13 +1275,9 @@ gfc_match_assignment (void) new_st.expr = lvalue; new_st.expr2 = rvalue; - return MATCH_YES; + gfc_check_do_variable (lvalue->symtree); -cleanup: - gfc_set_locus (&old_loc); - gfc_free_expr (lvalue); - gfc_free_expr (rvalue); - return m; + return MATCH_YES; } @@ -868,7 +1290,7 @@ gfc_match_pointer_assignment (void) locus old_loc; match m; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; lvalue = rvalue = NULL; @@ -883,6 +1305,14 @@ gfc_match_pointer_assignment (void) if (m != MATCH_YES) goto cleanup; + if (lvalue->symtree->n.sym->attr.protected + && lvalue->symtree->n.sym->attr.use_assoc) + { + gfc_error ("Assigning to a PROTECTED pointer at %C"); + m = MATCH_ERROR; + goto cleanup; + } + new_st.op = EXEC_POINTER_ASSIGN; new_st.expr = lvalue; new_st.expr2 = rvalue; @@ -890,13 +1320,51 @@ gfc_match_pointer_assignment (void) return MATCH_YES; cleanup: - gfc_set_locus (&old_loc); + 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) == FAILURE + || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE + || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement " + "at %C") == FAILURE) + return MATCH_ERROR; + + new_st.op = EXEC_ARITHMETIC_IF; + new_st.expr = expr; + new_st.label = 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. @@ -907,12 +1375,15 @@ cleanup: 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_match_if (gfc_statement *if_type) { gfc_expr *expr; gfc_st_label *l1, *l2, *l3; - locus old_loc; + locus old_loc, old_loc2; gfc_code *p; match m, n; @@ -920,12 +1391,20 @@ gfc_match_if (gfc_statement * if_type) if (n == MATCH_ERROR) return n; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; m = gfc_match (" if ( %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"); @@ -939,10 +1418,8 @@ gfc_match_if (gfc_statement * if_type) { if (n == MATCH_YES) { - gfc_error - ("Block label not appropriate for arithmetic IF statement " - "at %C"); - + gfc_error ("Block label not appropriate for arithmetic IF " + "statement at %C"); gfc_free_expr (expr); return MATCH_ERROR; } @@ -951,10 +1428,13 @@ gfc_match_if (gfc_statement * if_type) || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE) { - gfc_free_expr (expr); return MATCH_ERROR; } + + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF " + "statement at %C") == FAILURE) + return MATCH_ERROR; new_st.op = EXEC_ARITHMETIC_IF; new_st.expr = expr; @@ -966,19 +1446,17 @@ gfc_match_if (gfc_statement * if_type) return MATCH_YES; } - if (gfc_match (" then %t") == MATCH_YES) + if (gfc_match (" then%t") == MATCH_YES) { new_st.op = EXEC_IF; new_st.expr = expr; - *if_type = ST_IF_BLOCK; return MATCH_YES; } if (n == MATCH_YES) { - gfc_error ("Block label is not appropriate IF statement at %C"); - + gfc_error ("Block label is not appropriate for IF statement at %C"); gfc_free_expr (expr); return MATCH_ERROR; } @@ -996,9 +1474,15 @@ gfc_match_if (gfc_statement * if_type) gfc_free_expr (expr); gfc_undo_symbols (); - gfc_set_locus (&old_loc); + 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 */ + gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ m = gfc_match_pointer_assignment (); if (m == MATCH_YES) @@ -1006,9 +1490,9 @@ gfc_match_if (gfc_statement * if_type) gfc_free_expr (expr); gfc_undo_symbols (); - gfc_set_locus (&old_loc); + gfc_current_locus = old_loc; - gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */ + 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 @@ -1020,31 +1504,47 @@ gfc_match_if (gfc_statement * if_type) gfc_clear_error (); match ("allocate", gfc_match_allocate, ST_ALLOCATE) - match ("backspace", gfc_match_backspace, ST_BACKSPACE) - match ("call", gfc_match_call, ST_CALL) - 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 ("exit", gfc_match_exit, ST_EXIT) - match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) - match ("go to", gfc_match_goto, ST_GOTO) - match ("inquire", gfc_match_inquire, ST_INQUIRE) - 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 ("pause", gfc_match_stop, ST_PAUSE) - match ("stop", gfc_match_stop, ST_STOP) - match ("write", gfc_match_write, ST_WRITE) + match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) + match ("backspace", gfc_match_backspace, ST_BACKSPACE) + match ("call", gfc_match_call, ST_CALL) + 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 ("exit", gfc_match_exit, ST_EXIT) + match ("flush", gfc_match_flush, ST_FLUSH) + match ("forall", match_simple_forall, ST_FORALL) + match ("go to", gfc_match_goto, ST_GOTO) + match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) + match ("inquire", gfc_match_inquire, ST_INQUIRE) + 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 ("where", match_simple_where, ST_WHERE) + match ("write", gfc_match_write, ST_WRITE) + + /* The gfc_match_assignment() above may have returned a MATCH_NO + where the assignment was to a named constant. Check that + special case here. */ + m = gfc_match_assignment (); + if (m == MATCH_NO) + { + gfc_error ("Cannot assign to a named constant at %C"); + gfc_free_expr (expr); + gfc_undo_symbols (); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } /* 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 () == 0) + if (gfc_error_check () == 0) gfc_error ("Unclassifiable statement in IF-clause at %C"); gfc_free_expr (expr); @@ -1066,7 +1566,7 @@ got_match: p = gfc_get_code (); p->next = gfc_get_code (); *p->next = new_st; - p->next->loc = *gfc_current_locus (); + p->next->loc = gfc_current_locus; p->expr = expr; p->op = EXEC_IF; @@ -1156,7 +1656,7 @@ cleanup: /* Free a gfc_iterator structure. */ void -gfc_free_iterator (gfc_iterator * iter, int flag) +gfc_free_iterator (gfc_iterator *iter, int flag) { if (iter == NULL) @@ -1182,7 +1682,7 @@ gfc_match_do (void) gfc_st_label *label; match m; - old_loc = *gfc_current_locus (); + old_loc = gfc_current_locus; label = NULL; iter.var = iter.start = iter.end = iter.step = NULL; @@ -1194,11 +1694,11 @@ gfc_match_do (void) if (gfc_match (" do") != MATCH_YES) return MATCH_NO; - m = gfc_match_st_label (&label, 0); + m = gfc_match_st_label (&label); if (m == MATCH_ERROR) goto cleanup; -/* Match an infinite DO, make it like a DO WHILE(.TRUE.) */ + /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ if (gfc_match_eos () == MATCH_YES) { @@ -1207,9 +1707,8 @@ gfc_match_do (void) 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) + /* 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; /* See if we have a DO WHILE. */ @@ -1220,15 +1719,15 @@ gfc_match_do (void) } /* The abortive DO WHILE may have done something to the symbol - table, so we start over: */ + table, so we start over. */ gfc_undo_symbols (); - gfc_set_locus (&old_loc); + gfc_current_locus = old_loc; - gfc_match_label (); /* This won't error */ - gfc_match (" do "); /* This will work */ + gfc_match_label (); /* This won't error. */ + gfc_match (" do "); /* This will work. */ - gfc_match_st_label (&label, 0); /* Can't error out */ - gfc_match_char (','); /* Optional comma */ + gfc_match_st_label (&label); /* Can't error out. */ + gfc_match_char (','); /* Optional comma. */ m = gfc_match_iterator (&iter, 0); if (m == MATCH_NO) @@ -1236,6 +1735,9 @@ gfc_match_do (void) 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); @@ -1273,7 +1775,7 @@ cleanup: static match match_exit_cycle (gfc_statement st, gfc_exec_op op) { - gfc_state_data *p; + gfc_state_data *p, *o; gfc_symbol *sym; match m; @@ -1298,11 +1800,12 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) } } - /* Find the loop mentioned specified by the label (or lack of a - label). */ - for (p = gfc_state_stack; p; p = p->previous) + /* Find the loop mentioned specified by the label (or lack of a label). */ + for (o = NULL, p = gfc_state_stack; p; p = p->previous) if (p->state == COMP_DO && (sym == NULL || sym == p->sym)) break; + else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) + o = p; if (p == NULL) { @@ -1316,11 +1819,29 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) return MATCH_ERROR; } + if (o != NULL) + { + gfc_error ("%s statement at %C leaving OpenMP structured block", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + else if (st == ST_EXIT + && p->previous != NULL + && p->previous->state == COMP_OMP_STRUCTURED_BLOCK + && (p->previous->head->op == EXEC_OMP_DO + || p->previous->head->op == EXEC_OMP_PARALLEL_DO)) + { + gcc_assert (p->previous->head->next != NULL); + gcc_assert (p->previous->head->next->op == EXEC_DO + || p->previous->head->next->op == EXEC_DO_WHILE); + gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); + return MATCH_ERROR; + } + /* Save the first statement in the loop - needed by the backend. */ new_st.ext.whichloop = p->head; new_st.op = op; -/* new_st.sym = sym;*/ return MATCH_YES; } @@ -1331,7 +1852,6 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) match gfc_match_exit (void) { - return match_exit_cycle (ST_EXIT, EXEC_EXIT); } @@ -1341,7 +1861,6 @@ gfc_match_exit (void) match gfc_match_cycle (void) { - return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); } @@ -1354,42 +1873,43 @@ gfc_match_stopcode (gfc_statement st) int stop_code; gfc_expr *e; match m; + int cnt; - stop_code = 0; + stop_code = -1; e = NULL; if (gfc_match_eos () != MATCH_YES) { - m = gfc_match_small_literal_int (&stop_code); + m = gfc_match_small_literal_int (&stop_code, &cnt); if (m == MATCH_ERROR) - goto cleanup; + goto cleanup; - if (m == MATCH_YES && stop_code > 99999) - { - gfc_error ("STOP code out of range at %C"); - goto cleanup; - } + if (m == MATCH_YES && cnt > 5) + { + gfc_error ("Too many digits in STOP code at %C"); + goto cleanup; + } if (m == MATCH_NO) - { - /* Try a character constant. */ - m = gfc_match_expr (&e); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) - goto syntax; - } + { + /* Try a character constant. */ + m = gfc_match_expr (&e); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) + goto syntax; + } if (gfc_match_eos () != MATCH_YES) - goto syntax; + goto syntax; } if (gfc_pure (NULL)) { gfc_error ("%s statement not allowed in PURE procedure at %C", - gfc_ascii_statement (st)); + gfc_ascii_statement (st)); goto cleanup; } @@ -1408,6 +1928,7 @@ cleanup: return MATCH_ERROR; } + /* Match the (deprecated) PAUSE statement. */ match @@ -1418,8 +1939,8 @@ gfc_match_pause (void) m = gfc_match_stopcode (ST_PAUSE); if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F95_DEL, - "Obsolete: PAUSE statement at %C") + if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement" + " at %C") == FAILURE) m = MATCH_ERROR; } @@ -1441,7 +1962,6 @@ gfc_match_stop (void) match gfc_match_continue (void) { - if (gfc_match_eos () != MATCH_YES) { gfc_syntax_error (ST_CONTINUE); @@ -1464,21 +1984,21 @@ gfc_match_assign (void) if (gfc_match (" %l", &label) == MATCH_YES) { if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE) - return MATCH_ERROR; + return MATCH_ERROR; if (gfc_match (" to %v%t", &expr) == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F95_DEL, - "Obsolete: ASSIGN statement at %C") + { + if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN " + "statement at %C") == FAILURE) return MATCH_ERROR; - expr->symtree->n.sym->attr.assign = 1; + expr->symtree->n.sym->attr.assign = 1; - new_st.op = EXEC_LABEL_ASSIGN; - new_st.label = label; - new_st.expr = expr; - return MATCH_YES; - } + new_st.op = EXEC_LABEL_ASSIGN; + new_st.label = label; + new_st.expr = expr; + return MATCH_YES; + } } return MATCH_NO; } @@ -1513,12 +2033,11 @@ gfc_match_goto (void) if (gfc_match_variable (&expr, 0) == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F95_DEL, - "Obsolete: Assigned GOTO statement at %C") + if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO " + "statement at %C") == FAILURE) return MATCH_ERROR; - expr->symtree->n.sym->attr.assign = 1; new_st.op = EXEC_GOTO; new_st.expr = expr; @@ -1536,7 +2055,7 @@ gfc_match_goto (void) do { - m = gfc_match_st_label (&label, 0); + m = gfc_match_st_label (&label); if (m != MATCH_YES) goto syntax; @@ -1561,8 +2080,7 @@ gfc_match_goto (void) if (head == NULL) { - gfc_error ( - "Statement label list in GOTO at %C cannot be empty"); + gfc_error ("Statement label list in GOTO at %C cannot be empty"); goto syntax; } new_st.block = head; @@ -1582,7 +2100,7 @@ gfc_match_goto (void) do { - m = gfc_match_st_label (&label, 0); + m = gfc_match_st_label (&label); if (m != MATCH_YES) goto syntax; @@ -1648,7 +2166,7 @@ cleanup: /* Frees a list of gfc_alloc structures. */ void -gfc_free_alloc_list (gfc_alloc * p) +gfc_free_alloc_list (gfc_alloc *p) { gfc_alloc *q; @@ -1692,14 +2210,20 @@ gfc_match_allocate (void) if (m == MATCH_ERROR) goto cleanup; + if (gfc_check_do_variable (tail->expr->symtree)) + goto cleanup; + if (gfc_pure (NULL) - && gfc_impure_variable (tail->expr->symtree->n.sym)) + && gfc_impure_variable (tail->expr->symtree->n.sym)) { gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a " "PURE procedure"); goto cleanup; } + if (tail->expr->ts.type == BT_DERIVED) + tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived); + if (gfc_match_char (',') != MATCH_YES) break; @@ -1712,21 +2236,60 @@ gfc_match_allocate (void) if (stat != NULL) { + bool is_variable; + if (stat->symtree->n.sym->attr.intent == INTENT_IN) { - gfc_error - ("STAT variable '%s' of ALLOCATE statement at %C cannot be " - "INTENT(IN)", stat->symtree->n.sym->name); + gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot " + "be INTENT(IN)", stat->symtree->n.sym->name); goto cleanup; } if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym)) { - gfc_error - ("Illegal STAT variable in ALLOCATE statement at %C for a PURE " - "procedure"); + gfc_error ("Illegal STAT variable in ALLOCATE statement at %C " + "for a PURE procedure"); + goto cleanup; + } + + is_variable = false; + if (stat->symtree->n.sym->attr.flavor == FL_VARIABLE) + is_variable = true; + else if (stat->symtree->n.sym->attr.function + && stat->symtree->n.sym->result == stat->symtree->n.sym + && (gfc_current_ns->proc_name == stat->symtree->n.sym + || (gfc_current_ns->parent + && gfc_current_ns->parent->proc_name + == stat->symtree->n.sym))) + is_variable = true; + else if (gfc_current_ns->entries + && stat->symtree->n.sym->result == stat->symtree->n.sym) + { + gfc_entry_list *el; + for (el = gfc_current_ns->entries; el; el = el->next) + if (el->sym == stat->symtree->n.sym) + { + is_variable = true; + } + } + else if (gfc_current_ns->parent && gfc_current_ns->parent->entries + && stat->symtree->n.sym->result == stat->symtree->n.sym) + { + gfc_entry_list *el; + for (el = gfc_current_ns->parent->entries; el; el = el->next) + if (el->sym == stat->symtree->n.sym) + { + is_variable = true; + } + } + + if (!is_variable) + { + gfc_error ("STAT expression at %C must be a variable"); goto cleanup; } + + gfc_check_do_variable(stat->symtree); } if (gfc_match (" )%t") != MATCH_YES) @@ -1771,20 +2334,22 @@ gfc_match_nullify (void) if (m == MATCH_NO) goto syntax; + if (gfc_check_do_variable (p->symtree)) + goto cleanup; + if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym)) { - gfc_error - ("Illegal variable in NULLIFY at %C for a PURE procedure"); + gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure"); goto cleanup; } - /* build ' => NULL() ' */ + /* build ' => NULL() '. */ e = gfc_get_expr (); - e->where = *gfc_current_locus (); + e->where = gfc_current_locus; e->expr_type = EXPR_NULL; e->ts.type = BT_UNKNOWN; - /* Chain to list */ + /* Chain to list. */ if (tail == NULL) tail = &new_st; else @@ -1797,7 +2362,7 @@ gfc_match_nullify (void) tail->expr = p; tail->expr2 = e; - if (gfc_match_char (')') == MATCH_YES) + if (gfc_match (" )%t") == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) goto syntax; @@ -1809,7 +2374,7 @@ syntax: gfc_syntax_error (ST_NULLIFY); cleanup: - gfc_free_statements (tail); + gfc_free_statements (new_st.next); return MATCH_ERROR; } @@ -1845,12 +2410,14 @@ gfc_match_deallocate (void) if (m == MATCH_NO) goto syntax; + if (gfc_check_do_variable (tail->expr->symtree)) + goto cleanup; + if (gfc_pure (NULL) - && gfc_impure_variable (tail->expr->symtree->n.sym)) + && gfc_impure_variable (tail->expr->symtree->n.sym)) { - gfc_error - ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE " - "procedure"); + gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C " + "for a PURE procedure"); goto cleanup; } @@ -1864,11 +2431,29 @@ gfc_match_deallocate (void) break; } - if (stat != NULL && stat->symtree->n.sym->attr.intent == INTENT_IN) + if (stat != NULL) { - gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C cannot be " - "INTENT(IN)", stat->symtree->n.sym->name); - goto cleanup; + if (stat->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C " + "cannot be INTENT(IN)", stat->symtree->n.sym->name); + goto cleanup; + } + + if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym)) + { + gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C " + "for a PURE procedure"); + goto cleanup; + } + + if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE) + { + gfc_error ("STAT expression at %C must be a variable"); + goto cleanup; + } + + gfc_check_do_variable(stat->symtree); } if (gfc_match (" )%t") != MATCH_YES) @@ -1897,6 +2482,8 @@ gfc_match_return (void) { gfc_expr *e; match m; + gfc_compile_state s; + int c; e = NULL; if (gfc_match_eos () == MATCH_YES) @@ -1909,7 +2496,18 @@ gfc_match_return (void) goto cleanup; } - m = gfc_match ("% %e%t", &e); + if (gfc_current_form == FORM_FREE) + { + /* The following are valid, so we can't require a blank after the + RETURN keyword: + return+1 + return(1) */ + c = gfc_peek_char (); + if (ISALPHA (c) || ISDIGIT (c)) + return MATCH_NO; + } + + m = gfc_match (" %e%t", &e); if (m == MATCH_YES) goto done; if (m == MATCH_ERROR) @@ -1922,6 +2520,12 @@ cleanup: return MATCH_ERROR; done: + gfc_enclosing_unit (&s); + if (s == COMP_PROGRAM + && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in " + "main program at %C") == FAILURE) + return MATCH_ERROR; + new_st.op = EXEC_RETURN; new_st.expr = e; @@ -1960,12 +2564,28 @@ gfc_match_call (void) return MATCH_ERROR; sym = st->n.sym; - gfc_set_sym_referenced (sym); + /* If it does not seem to be callable... */ if (!sym->attr.generic - && !sym->attr.subroutine - && gfc_add_subroutine (&sym->attr, NULL) == FAILURE) - return MATCH_ERROR; + && !sym->attr.subroutine) + { + if (!(sym->attr.external && !sym->attr.referenced)) + { + /* ...create a symbol in this scope... */ + if (sym->ns != gfc_current_ns + && gfc_get_sym_tree (name, NULL, &st) == 1) + return MATCH_ERROR; + + if (sym != st->n.sym) + sym = st->n.sym; + } + + /* ...and then to try to make the symbol into a subroutine. */ + if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) + return MATCH_ERROR; + } + + gfc_set_sym_referenced (sym); if (gfc_match_eos () != MATCH_YES) { @@ -1995,18 +2615,18 @@ gfc_match_call (void) new_st.next = c = gfc_get_code (); c->op = EXEC_SELECT; - sprintf (name, "_result_%s",sym->name); - gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */ + sprintf (name, "_result_%s", sym->name); + gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */ select_sym = select_st->n.sym; select_sym->ts.type = BT_INTEGER; - select_sym->ts.kind = gfc_default_integer_kind (); + select_sym->ts.kind = gfc_default_integer_kind; gfc_set_sym_referenced (select_sym); c->expr = gfc_get_expr (); c->expr->expr_type = EXPR_VARIABLE; c->expr->symtree = select_st; c->expr->ts = select_sym->ts; - c->expr->where = *gfc_current_locus (); + c->expr->where = gfc_current_locus; i = 0; for (a = arglist; a; a = a->next) @@ -2048,270 +2668,131 @@ cleanup: } -/* Match an IMPLICIT NONE statement. Actually, this statement is - already matched in parse.c, or we would not end up here in the - first place. So the only thing we need to check, is if there is - trailing garbage. If not, the match is successful. */ +/* Given a name, return a pointer to the common head structure, + creating it if it does not exist. If FROM_MODULE is nonzero, we + mangle the name so that it doesn't interfere with commons defined + in the using namespace. + TODO: Add to global symbol tree. */ -match -gfc_match_implicit_none (void) +gfc_common_head * +gfc_get_common (const char *name, int from_module) { + gfc_symtree *st; + static int serial = 0; + char mangled_name[GFC_MAX_SYMBOL_LEN + 1]; + + if (from_module) + { + /* A use associated common block is only needed to correctly layout + the variables it contains. */ + snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); + st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); + } + else + { + st = gfc_find_symtree (gfc_current_ns->common_root, name); + + if (st == NULL) + st = gfc_new_symtree (&gfc_current_ns->common_root, name); + } + + if (st->n.common == NULL) + { + st->n.common = gfc_get_common_head (); + st->n.common->where = gfc_current_locus; + strcpy (st->n.common->name, name); + } - return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO; + return st->n.common; } -/* Match the letter range(s) of an IMPLICIT statement. */ +/* Match a common block name. */ -static match -match_implicit_range (gfc_typespec * ts) +match match_common_name (char *name) { - int c, c1, c2, inner; - locus cur_loc; - - cur_loc = *gfc_current_locus (); + match m; - gfc_gobble_whitespace (); - c = gfc_next_char (); - if (c != '(') + if (gfc_match_char ('/') == MATCH_NO) { - gfc_error ("Missing character range in IMPLICIT at %C"); - goto bad; + name[0] = '\0'; + return MATCH_YES; } - inner = 1; - while (inner) + if (gfc_match_char ('/') == MATCH_YES) { - gfc_gobble_whitespace (); - c1 = gfc_next_char (); - if (!ISALPHA (c1)) - goto bad; - - gfc_gobble_whitespace (); - c = gfc_next_char (); - - switch (c) - { - case ')': - inner = 0; /* Fall through */ + name[0] = '\0'; + return MATCH_YES; + } - case ',': - c2 = c1; - break; + m = gfc_match_name (name); - case '-': - gfc_gobble_whitespace (); - c2 = gfc_next_char (); - if (!ISALPHA (c2)) - goto bad; + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) + return MATCH_YES; - gfc_gobble_whitespace (); - c = gfc_next_char (); + gfc_error ("Syntax error in common block name at %C"); + return MATCH_ERROR; +} - if ((c != ',') && (c != ')')) - goto bad; - if (c == ')') - inner = 0; - break; - - default: - goto bad; - } - - if (c1 > c2) - { - gfc_error ("Letters must be in alphabetic order in " - "IMPLICIT statement at %C"); - goto bad; - } - - /* See if we can add the newly matched range to the pending - implicits from this IMPLICIT statement. We do not check for - conflicts with whatever earlier IMPLICIT statements may have - set. This is done when we've successfully finished matching - the current one. */ - if (gfc_add_new_implicit_range (c1, c2, ts) != SUCCESS) - goto bad; - } - - return MATCH_YES; - -bad: - gfc_syntax_error (ST_IMPLICIT); - - gfc_set_locus (&cur_loc); - return MATCH_ERROR; -} - - -/* Match an IMPLICIT statement, storing the types for - gfc_set_implicit() if the statement is accepted by the parser. - There is a strange looking, but legal syntactic construction - possible. It looks like: - - IMPLICIT INTEGER (a-b) (c-d) - - This is legal if "a-b" is a constant expression that happens to - equal one of the legal kinds for integers. The real problem - happens with an implicit specification that looks like: - - IMPLICIT INTEGER (a-b) - - In this case, a typespec matcher that is "greedy" (as most of the - matchers are) gobbles the character range as a kindspec, leaving - nothing left. We therefore have to go a bit more slowly in the - matching process by inhibiting the kindspec checking during - typespec matching and checking for a kind later. */ - -match -gfc_match_implicit (void) -{ - gfc_typespec ts; - locus cur_loc; - int c; - match m; - - /* We don't allow empty implicit statements. */ - if (gfc_match_eos () == MATCH_YES) - { - gfc_error ("Empty IMPLICIT statement at %C"); - return MATCH_ERROR; - } - - /* First cleanup. */ - gfc_clear_new_implicit (); - - do - { - /* A basic type is mandatory here. */ - m = gfc_match_type_spec (&ts, 0); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - goto syntax; - - cur_loc = *gfc_current_locus (); - m = match_implicit_range (&ts); - - if (m == MATCH_YES) - { - /* Looks like we have the (). */ - gfc_gobble_whitespace (); - c = gfc_next_char (); - if ((c == '\n') || (c == ',')) - continue; - - gfc_set_locus (&cur_loc); - } - - /* Last chance -- check () (). */ - m = gfc_match_kind_spec (&ts); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - { - m = gfc_match_old_kind_spec (&ts); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - goto syntax; - } - - m = match_implicit_range (&ts); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - goto syntax; - - gfc_gobble_whitespace (); - c = gfc_next_char (); - if ((c != '\n') && (c != ',')) - goto syntax; - - } - while (c == ','); - - /* All we need to now is try to merge the new implicit types back - into the existing types. This will fail if another implicit - type is already defined for a letter. */ - return (gfc_merge_new_implicit () == SUCCESS) ? - MATCH_YES : MATCH_ERROR; - -syntax: - gfc_syntax_error (ST_IMPLICIT); - -error: - return MATCH_ERROR; -} - - -/* Match a common block name. */ - -static match -match_common_name (gfc_symbol ** sym) -{ - match m; - - if (gfc_match_char ('/') == MATCH_NO) - return MATCH_NO; - - if (gfc_match_char ('/') == MATCH_YES) - { - *sym = NULL; - return MATCH_YES; - } - - m = gfc_match_symbol (sym, 0); - - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) - return MATCH_YES; - - gfc_error ("Syntax error in common block name at %C"); - return MATCH_ERROR; -} - - -/* Match a COMMON statement. */ +/* Match a COMMON statement. */ match gfc_match_common (void) { - gfc_symbol *sym, *common_name, **head, *tail, *old_blank_common; + gfc_symbol *sym, **head, *tail, *other, *old_blank_common; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_common_head *t; gfc_array_spec *as; + gfc_equiv *e1, *e2; match m; + gfc_gsymbol *gsym; - old_blank_common = gfc_current_ns->blank_common; + old_blank_common = gfc_current_ns->blank_common.head; if (old_blank_common) { while (old_blank_common->common_next) old_blank_common = old_blank_common->common_next; } - common_name = NULL; as = NULL; - if (gfc_match_eos () == MATCH_YES) - goto syntax; - for (;;) { - m = match_common_name (&common_name); + m = match_common_name (name); if (m == MATCH_ERROR) goto cleanup; - if (common_name == NULL) - head = &gfc_current_ns->blank_common; - else + gsym = gfc_get_gsymbol (name); + if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON) + { + gfc_error ("Symbol '%s' at %C is already an external symbol that " + "is not COMMON", name); + goto cleanup; + } + + if (gsym->type == GSYM_UNKNOWN) { - head = &common_name->common_head; + gsym->type = GSYM_COMMON; + gsym->where = gfc_current_locus; + gsym->defined = 1; + } - if (!common_name->attr.common - && gfc_add_common (&common_name->attr, NULL) == FAILURE) - goto cleanup; + gsym->used = 1; + + if (name[0] == '\0') + { + t = &gfc_current_ns->blank_common; + if (t->head == NULL) + t->where = gfc_current_locus; } + else + { + t = gfc_get_common (name, 0); + } + head = &t->head; if (*head == NULL) tail = NULL; @@ -2331,6 +2812,35 @@ gfc_match_common (void) if (m == MATCH_NO) goto syntax; + /* Store a ref to the common block for error checking. */ + sym->common_block = t; + + /* See if we know the current common block is bind(c), and if + so, then see if we can check if the symbol is (which it'll + need to be). This can happen if the bind(c) attr stmt was + applied to the common block, and the variable(s) already + defined, before declaring the common block. */ + if (t->is_bind_c == 1) + { + if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) + { + /* If we find an error, just print it and continue, + cause it's just semantic, and we can see if there + are more errors. */ + gfc_error_now ("Variable '%s' at %L in common block '%s' " + "at %C must be declared with a C " + "interoperable kind since common block " + "'%s' is bind(c)", + sym->name, &(sym->declared_at), t->name, + t->name); + } + + if (sym->attr.is_bind_c == 1) + gfc_error_now ("Variable '%s' in common block " + "'%s' at %C can not be bind(c) since " + "it is not global", sym->name, t->name); + } + if (sym->attr.in_common) { gfc_error ("Symbol '%s' at %C is already in a COMMON block", @@ -2338,31 +2848,19 @@ gfc_match_common (void) goto cleanup; } - if (sym->value != NULL - && (common_name == NULL || !sym->attr.data)) + if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) + || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) { - if (common_name == NULL) - gfc_error ("Previously initialized symbol '%s' in " - "blank COMMON block at %C", sym->name); - else - gfc_error ("Previously initialized symbol '%s' in " - "COMMON block '%s' at %C", sym->name, - common_name->name); - goto cleanup; + if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C " + "can only be COMMON in " + "BLOCK DATA", sym->name) + == FAILURE) + goto cleanup; } - if (gfc_add_in_common (&sym->attr, NULL) == FAILURE) + if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; - /* Derived type names must have the SEQUENCE attribute. */ - if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence) - { - gfc_error - ("Derived type variable in COMMON at %C does not have the " - "SEQUENCE attribute"); - goto cleanup; - } - if (tail != NULL) tail->common_next = sym; else @@ -2371,7 +2869,7 @@ gfc_match_common (void) tail = sym; /* Deal with an optional array specification after the - symbol name. */ + symbol name. */ m = gfc_match_array_spec (&as); if (m == MATCH_ERROR) goto cleanup; @@ -2380,33 +2878,70 @@ gfc_match_common (void) { if (as->type != AS_EXPLICIT) { - gfc_error - ("Array specification for symbol '%s' in COMMON at %C " - "must be explicit", sym->name); + gfc_error ("Array specification for symbol '%s' in COMMON " + "at %C must be explicit", sym->name); goto cleanup; } - if (gfc_add_dimension (&sym->attr, NULL) == FAILURE) + if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; if (sym->attr.pointer) { - gfc_error - ("Symbol '%s' in COMMON at %C cannot be a POINTER array", - sym->name); + gfc_error ("Symbol '%s' in COMMON at %C cannot be a " + "POINTER array", sym->name); goto cleanup; } sym->as = as; as = NULL; + + } + + sym->common_head = t; + + /* Check to see if the symbol is already in an equivalence group. + If it is, set the other members as being in common. */ + if (sym->attr.in_equivalence) + { + for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) + { + for (e2 = e1; e2; e2 = e2->eq) + if (e2->expr->symtree->n.sym == sym) + goto equiv_found; + + continue; + + equiv_found: + + for (e2 = e1; e2; e2 = e2->eq) + { + other = e2->expr->symtree->n.sym; + if (other->common_head + && other->common_head != sym->common_head) + { + gfc_error ("Symbol '%s', in COMMON block '%s' at " + "%C is being indirectly equivalenced to " + "another COMMON block '%s'", + sym->name, sym->common_head->name, + other->common_head->name); + goto cleanup; + } + other->attr.in_common = 1; + other->common_head = t; + } + } } + + gfc_gobble_whitespace (); if (gfc_match_eos () == MATCH_YES) goto done; if (gfc_peek_char () == '/') break; if (gfc_match_char (',') != MATCH_YES) goto syntax; + gfc_gobble_whitespace (); if (gfc_peek_char () == '/') break; } @@ -2416,13 +2951,15 @@ done: return MATCH_YES; syntax: + gfc_free_common_tree (gfc_current_ns->common_root); + gfc_current_ns->common_root = NULL; gfc_syntax_error (ST_COMMON); cleanup: if (old_blank_common) old_blank_common->common_next = NULL; else - gfc_current_ns->blank_common = NULL; + gfc_current_ns->blank_common.head = NULL; gfc_free_array_spec (as); return MATCH_ERROR; } @@ -2443,14 +2980,14 @@ gfc_match_block_data (void) return MATCH_YES; } - m = gfc_match (" %n%t", name); + m = gfc_match ("% %n%t", name); if (m != MATCH_YES) return MATCH_ERROR; if (gfc_get_symbol (name, NULL, &sym)) return MATCH_ERROR; - if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE) + if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE) return MATCH_ERROR; gfc_new_block = sym; @@ -2462,7 +2999,7 @@ gfc_match_block_data (void) /* Free a namelist structure. */ void -gfc_free_namelist (gfc_namelist * name) +gfc_free_namelist (gfc_namelist *name) { gfc_namelist *n; @@ -2493,14 +3030,23 @@ gfc_match_namelist (void) { if (group_name->ts.type != BT_UNKNOWN) { - gfc_error - ("Namelist group name '%s' at %C already has a basic type " - "of %s", group_name->name, gfc_typename (&group_name->ts)); + gfc_error ("Namelist group name '%s' at %C already has a basic " + "type of %s", group_name->name, + gfc_typename (&group_name->ts)); return MATCH_ERROR; } + if (group_name->attr.flavor == FL_NAMELIST + && group_name->attr.use_assoc + && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' " + "at %C already is USE associated and can" + "not be respecified.", group_name->name) + == FAILURE) + return MATCH_ERROR; + if (group_name->attr.flavor != FL_NAMELIST - && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE) + && gfc_add_flavor (&group_name->attr, FL_NAMELIST, + group_name->name, NULL) == FAILURE) return MATCH_ERROR; for (;;) @@ -2512,14 +3058,28 @@ gfc_match_namelist (void) goto error; if (sym->attr.in_namelist == 0 - && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE) + && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE) goto error; - /* TODO: worry about PRIVATE members of a PUBLIC namelist - group. */ + /* Use gfc_error_check here, rather than goto error, so that + these are the only errors for the next two lines. */ + if (sym->as && sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Assumed size array '%s' in namelist '%s' at " + "%C is not allowed", sym->name, group_name->name); + gfc_error_check (); + } + + if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL) + { + gfc_error ("Assumed character length '%s' in namelist '%s' at " + "%C is not allowed", sym->name, group_name->name); + gfc_error_check (); + } nl = gfc_get_namelist (); nl->sym = sym; + sym->refs++; if (group_name->namelist == NULL) group_name->namelist = group_name->namelist_tail = nl; @@ -2571,7 +3131,8 @@ gfc_match_module (void) if (m != MATCH_YES) return m; - if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE) + if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, + gfc_new_block->name, NULL) == FAILURE) return MATCH_ERROR; return MATCH_YES; @@ -2582,15 +3143,13 @@ gfc_match_module (void) do this. */ void -gfc_free_equiv (gfc_equiv * eq) +gfc_free_equiv (gfc_equiv *eq) { - if (eq == NULL) return; gfc_free_equiv (eq->eq); gfc_free_equiv (eq->next); - gfc_free_expr (eq->expr); gfc_free (eq); } @@ -2603,7 +3162,11 @@ gfc_match_equivalence (void) { gfc_equiv *eq, *set, *tail; gfc_ref *ref; + gfc_symbol *sym; match m; + gfc_common_head *common_head = NULL; + bool common_flag; + int cnt; tail = NULL; @@ -2620,26 +3183,49 @@ gfc_match_equivalence (void) goto syntax; set = eq; + common_flag = FALSE; + cnt = 0; for (;;) { - m = gfc_match_variable (&set->expr, 1); + m = gfc_match_equiv_variable (&set->expr); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; + /* count the number of objects. */ + cnt++; + + if (gfc_match_char ('%') == MATCH_YES) + { + gfc_error ("Derived type component %C is not a " + "permitted EQUIVALENCE member"); + goto cleanup; + } + for (ref = set->expr->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) { - gfc_error - ("Array reference in EQUIVALENCE at %C cannot be an " - "array section"); + gfc_error ("Array reference in EQUIVALENCE at %C cannot " + "be an array section"); goto cleanup; } + sym = set->expr->symtree->n.sym; + + if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE) + goto cleanup; + + if (sym->attr.in_common) + { + common_flag = TRUE; + common_head = sym->common_head; + } + if (gfc_match_char (')') == MATCH_YES) break; + if (gfc_match_char (',') != MATCH_YES) goto syntax; @@ -2647,251 +3233,32 @@ gfc_match_equivalence (void) set = set->eq; } - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_EQUIVALENCE); - -cleanup: - eq = tail->next; - tail->next = NULL; - - gfc_free_equiv (gfc_current_ns->equiv); - gfc_current_ns->equiv = eq; - - return MATCH_ERROR; -} - - -/* Match a statement function declaration. It is so easy to match - non-statement function statements with a MATCH_ERROR as opposed to - MATCH_NO that we suppress error message in most cases. */ - -match -gfc_match_st_function (void) -{ - gfc_error_buf old_error; - gfc_symbol *sym; - gfc_expr *expr; - match m; - - m = gfc_match_symbol (&sym, 0); - if (m != MATCH_YES) - return m; - - gfc_push_error (&old_error); - - if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE) - goto undo_error; - - if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) - goto undo_error; - - m = gfc_match (" = %e%t", &expr); - if (m == MATCH_NO) - goto undo_error; - if (m == MATCH_ERROR) - return m; - - sym->value = expr; - - return MATCH_YES; - -undo_error: - gfc_pop_error (&old_error); - return MATCH_NO; -} - - -/********************* DATA statement subroutines *********************/ - -/* Free a gfc_data_variable structure and everything beneath it. */ - -static void -free_variable (gfc_data_variable * p) -{ - gfc_data_variable *q; - - for (; p; p = q) - { - q = p->next; - gfc_free_expr (p->expr); - gfc_free_iterator (&p->iter, 0); - free_variable (p->list); - - gfc_free (p); - } -} - - -/* Free a gfc_data_value structure and everything beneath it. */ - -static void -free_value (gfc_data_value * p) -{ - gfc_data_value *q; - - for (; p; p = q) - { - q = p->next; - gfc_free_expr (p->expr); - gfc_free (p); - } -} - - -/* Free a list of gfc_data structures. */ - -void -gfc_free_data (gfc_data * p) -{ - gfc_data *q; - - for (; p; p = q) - { - q = p->next; - - free_variable (p->var); - free_value (p->value); - - gfc_free (p); - } -} - - -static match var_element (gfc_data_variable *); - -/* Match a list of variables terminated by an iterator and a right - parenthesis. */ - -static match -var_list (gfc_data_variable * parent) -{ - gfc_data_variable *tail, var; - match m; - - m = var_element (&var); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - goto syntax; - - tail = gfc_get_data_variable (); - *tail = var; - - parent->list = tail; - - for (;;) - { - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = gfc_match_iterator (&parent->iter, 1); - if (m == MATCH_YES) - break; - if (m == MATCH_ERROR) - return MATCH_ERROR; - - m = var_element (&var); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - goto syntax; - - tail->next = gfc_get_data_variable (); - tail = tail->next; - - *tail = var; - } - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_DATA); - return MATCH_ERROR; -} - - -/* Match a single element in a data variable list, which can be a - variable-iterator list. */ - -static match -var_element (gfc_data_variable * new) -{ - match m; - gfc_symbol *sym, *t; - - memset (new, '\0', sizeof (gfc_data_variable)); - - if (gfc_match_char ('(') == MATCH_YES) - return var_list (new); - - m = gfc_match_variable (&new->expr, 0); - if (m != MATCH_YES) - return m; - - sym = new->expr->symtree->n.sym; - - if(sym->value != NULL) - { - gfc_error ("Variable '%s' at %C already has an initialization", - sym->name); - return MATCH_ERROR; - } - - if (sym->attr.in_common) - /* See if sym is in the blank common block. */ - for (t = sym->ns->blank_common; t; t = t->common_next) - if (sym == t) + if (cnt < 2) { - gfc_error ("DATA statement at %C may not initialize variable " - "'%s' from blank COMMON", sym->name); - return MATCH_ERROR; + gfc_error ("EQUIVALENCE at %C requires two or more objects"); + goto cleanup; } - sym->attr.data = 1; - - return MATCH_YES; -} - - -/* Match the top-level list of data variables. */ - -static match -top_var_list (gfc_data * d) -{ - gfc_data_variable var, *tail, *new; - match m; - - tail = NULL; - - for (;;) - { - m = var_element (&var); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - return MATCH_ERROR; - - new = gfc_get_data_variable (); - *new = var; - - if (tail == NULL) - d->var = new; - else - tail->next = new; - - tail = new; + /* If one of the members of an equivalence is in common, then + mark them all as being in common. Before doing this, check + that members of the equivalence group are not in different + common blocks. */ + if (common_flag) + for (set = eq; set; set = set->eq) + { + sym = set->expr->symtree->n.sym; + if (sym->common_head && sym->common_head != common_head) + { + gfc_error ("Attempt to indirectly overlap COMMON " + "blocks %s and %s by EQUIVALENCE at %C", + sym->common_head->name, common_head->name); + goto cleanup; + } + sym->attr.in_common = 1; + sym->common_head = common_head; + } - if (gfc_match_char ('/') == MATCH_YES) + if (gfc_match_eos () == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) goto syntax; @@ -2900,162 +3267,125 @@ top_var_list (gfc_data * d) return MATCH_YES; syntax: - gfc_syntax_error (ST_DATA); - return MATCH_ERROR; -} - - -static match -match_data_constant (gfc_expr ** result) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - gfc_expr *expr; - match m; - - m = gfc_match_literal_constant (&expr, 1); - if (m == MATCH_YES) - { - *result = expr; - return MATCH_YES; - } - - if (m == MATCH_ERROR) - return MATCH_ERROR; - - m = gfc_match_null (result); - if (m != MATCH_NO) - return m; - - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - if (gfc_find_symbol (name, NULL, 1, &sym)) - return MATCH_ERROR; + gfc_syntax_error (ST_EQUIVALENCE); - if (sym == NULL - || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED)) - { - gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C", - name); - return MATCH_ERROR; - } - else if (sym->attr.flavor == FL_DERIVED) - return gfc_match_structure_constructor (sym, result); +cleanup: + eq = tail->next; + tail->next = NULL; - *result = gfc_copy_expr (sym->value); - return MATCH_YES; + gfc_free_equiv (gfc_current_ns->equiv); + gfc_current_ns->equiv = eq; + + return MATCH_ERROR; } -/* Match a list of values in a DATA statement. The leading '/' has - already been seen at this point. */ +/* Check that a statement function is not recursive. This is done by looking + for the statement function symbol(sym) by looking recursively through its + expression(e). If a reference to sym is found, true is returned. + 12.5.4 requires that any variable of function that is implicitly typed + shall have that type confirmed by any subsequent type declaration. The + implicit typing is conveniently done here. */ +static bool +recursive_stmt_fcn (gfc_expr *, gfc_symbol *); -static match -top_val_list (gfc_data * data) +static bool +check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) { - gfc_data_value *new, *tail; - gfc_expr *expr; - const char *msg; - match m; - tail = NULL; + if (e == NULL) + return false; - for (;;) + switch (e->expr_type) { - m = match_data_constant (&expr); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - return MATCH_ERROR; + case EXPR_FUNCTION: + if (e->symtree == NULL) + return false; - new = gfc_get_data_value (); + /* Check the name before testing for nested recursion! */ + if (sym->name == e->symtree->n.sym->name) + return true; - if (tail == NULL) - data->value = new; - else - tail->next = new; + /* Catch recursion via other statement functions. */ + if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION + && e->symtree->n.sym->value + && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) + return true; - tail = new; + if (e->symtree->n.sym->ts.type == BT_UNKNOWN) + gfc_set_default_type (e->symtree->n.sym, 0, NULL); - if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) - { - tail->expr = expr; - tail->repeat = 1; - } - else - { - msg = gfc_extract_int (expr, &tail->repeat); - gfc_free_expr (expr); - if (msg != NULL) - { - gfc_error (msg); - return MATCH_ERROR; - } + break; - m = match_data_constant (&tail->expr); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - return MATCH_ERROR; - } + case EXPR_VARIABLE: + if (e->symtree && sym->name == e->symtree->n.sym->name) + return true; - if (gfc_match_char ('/') == MATCH_YES) - break; - if (gfc_match_char (',') == MATCH_NO) - goto syntax; + if (e->symtree->n.sym->ts.type == BT_UNKNOWN) + gfc_set_default_type (e->symtree->n.sym, 0, NULL); + break; + + default: + break; } - return MATCH_YES; + return false; +} -syntax: - gfc_syntax_error (ST_DATA); - return MATCH_ERROR; + +static bool +recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) +{ + return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); } -/* Match a DATA statement. */ +/* Match a statement function declaration. It is so easy to match + non-statement function statements with a MATCH_ERROR as opposed to + MATCH_NO that we suppress error message in most cases. */ match -gfc_match_data (void) +gfc_match_st_function (void) { - gfc_data *new; + gfc_error_buf old_error; + gfc_symbol *sym; + gfc_expr *expr; match m; - for (;;) - { - new = gfc_get_data (); - new->where = *gfc_current_locus (); + m = gfc_match_symbol (&sym, 0); + if (m != MATCH_YES) + return m; - m = top_var_list (new); - if (m != MATCH_YES) - goto cleanup; + gfc_push_error (&old_error); - m = top_val_list (new); - if (m != MATCH_YES) - goto cleanup; + if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, + sym->name, NULL) == FAILURE) + goto undo_error; - new->next = gfc_current_ns->data; - gfc_current_ns->data = new; + if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) + goto undo_error; - if (gfc_match_eos () == MATCH_YES) - break; + m = gfc_match (" = %e%t", &expr); + if (m == MATCH_NO) + goto undo_error; - gfc_match_char (','); /* Optional comma */ - } + gfc_free_error (&old_error); + if (m == MATCH_ERROR) + return m; - if (gfc_pure (NULL)) + if (recursive_stmt_fcn (expr, sym)) { - gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); + gfc_error ("Statement function at %L is recursive", &expr->where); return MATCH_ERROR; } + sym->value = expr; + return MATCH_YES; -cleanup: - gfc_free_data (new); - return MATCH_ERROR; +undo_error: + gfc_pop_error (&old_error); + return MATCH_NO; } @@ -3064,7 +3394,7 @@ cleanup: /* Free a single case structure. */ static void -free_case (gfc_case * p) +free_case (gfc_case *p) { if (p->low == p->high) p->high = NULL; @@ -3077,7 +3407,7 @@ free_case (gfc_case * p) /* Free a list of case structures. */ void -gfc_free_case_list (gfc_case * p) +gfc_free_case_list (gfc_case *p) { gfc_case *q; @@ -3092,38 +3422,37 @@ gfc_free_case_list (gfc_case * p) /* Match a single case selector. */ static match -match_case_selector (gfc_case ** cp) +match_case_selector (gfc_case **cp) { gfc_case *c; match m; c = gfc_get_case (); - c->where = *gfc_current_locus (); + c->where = gfc_current_locus; if (gfc_match_char (':') == MATCH_YES) { - m = gfc_match_expr (&c->high); + m = gfc_match_init_expr (&c->high); if (m == MATCH_NO) goto need_expr; if (m == MATCH_ERROR) goto cleanup; } - else { - m = gfc_match_expr (&c->low); + m = gfc_match_init_expr (&c->low); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto need_expr; /* If we're not looking at a ':' now, make a range out of a single - target. Else get the upper bound for the case range. */ + target. Else get the upper bound for the case range. */ if (gfc_match_char (':') != MATCH_YES) c->high = c->low; else { - m = gfc_match_expr (&c->high); + m = gfc_match_init_expr (&c->high); if (m == MATCH_ERROR) goto cleanup; /* MATCH_NO is fine. It's OK if nothing is there! */ @@ -3134,7 +3463,7 @@ match_case_selector (gfc_case ** cp) return MATCH_YES; need_expr: - gfc_error ("Expected expression in CASE at %C"); + gfc_error ("Expected initialization expression in CASE at %C"); cleanup: free_case (c); @@ -3153,6 +3482,14 @@ match_case_eos (void) if (gfc_match_eos () == MATCH_YES) return MATCH_YES; + /* If the case construct doesn't have a case-construct-name, we + should have matched the EOS. */ + if (!gfc_current_block ()) + { + gfc_error ("Expected the name of the SELECT CASE construct at %C"); + return MATCH_ERROR; + } + gfc_gobble_whitespace (); m = gfc_match_name (name); @@ -3219,7 +3556,7 @@ gfc_match_case (void) new_st.op = EXEC_SELECT; c = gfc_get_case (); - c->where = *gfc_current_locus (); + c->where = gfc_current_locus; new_st.ext.case_list = c; return MATCH_YES; } @@ -3266,10 +3603,56 @@ cleanup: /********************* WHERE subroutines ********************/ +/* Match the rest of a simple WHERE statement that follows an IF statement. + */ + +static match +match_simple_where (void) +{ + gfc_expr *expr; + gfc_code *c; + match m; + + m = gfc_match (" ( %e )", &expr); + if (m != MATCH_YES) + return m; + + m = gfc_match_assignment (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + c = gfc_get_code (); + + c->op = EXEC_WHERE; + c->expr = expr; + c->next = gfc_get_code (); + + *c->next = new_st; + gfc_clear_new_st (); + + new_st.op = EXEC_WHERE; + new_st.block = c; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_WHERE); + +cleanup: + gfc_free_expr (expr); + return MATCH_ERROR; +} + + /* Match a WHERE statement. */ match -gfc_match_where (gfc_statement * st) +gfc_match_where (gfc_statement *st) { gfc_expr *expr; match m0, m; @@ -3286,7 +3669,6 @@ gfc_match_where (gfc_statement * st) if (gfc_match_eos () == MATCH_YES) { *st = ST_WHERE_BLOCK; - new_st.op = EXEC_WHERE; new_st.expr = expr; return MATCH_YES; @@ -3351,7 +3733,14 @@ gfc_match_elsewhere (void) } if (gfc_match_eos () != MATCH_YES) - { /* Better be a name at this point */ + { + /* Only makes sense if we have a where-construct-name. */ + if (!gfc_current_block ()) + { + m = MATCH_ERROR; + goto cleanup; + } + /* Better be a name at this point. */ m = gfc_match_name (name); if (m == MATCH_NO) goto syntax; @@ -3387,19 +3776,17 @@ cleanup: /* Free a list of FORALL iterators. */ void -gfc_free_forall_iterator (gfc_forall_iterator * iter) +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); - gfc_free (iter); iter = next; } @@ -3408,32 +3795,34 @@ gfc_free_forall_iterator (gfc_forall_iterator * iter) /* Match an iterator as part of a FORALL statement. The format is: - = :[:][, ] */ + = :[:] + + 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) +match_forall_iterator (gfc_forall_iterator **result) { gfc_forall_iterator *iter; locus where; match m; - where = *gfc_current_locus (); + where = gfc_current_locus; iter = gfc_getmem (sizeof (gfc_forall_iterator)); - m = gfc_match_variable (&iter->var, 0); + m = gfc_match_expr (&iter->var); if (m != MATCH_YES) goto cleanup; - if (gfc_match_char ('=') != MATCH_YES) + 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_NO) - goto syntax; - if (m == MATCH_ERROR) + if (m != MATCH_YES) goto cleanup; if (gfc_match_char (':') != MATCH_YES) @@ -3456,6 +3845,9 @@ match_forall_iterator (gfc_forall_iterator ** result) 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; @@ -3464,33 +3856,29 @@ syntax: m = MATCH_ERROR; cleanup: - gfc_set_locus (&where); + + gfc_current_locus = where; gfc_free_forall_iterator (iter); return m; } -/* Match a FORALL statement. */ +/* Match the header of a FORALL statement. */ -match -gfc_match_forall (gfc_statement * st) +static match +match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) { gfc_forall_iterator *head, *tail, *new; - gfc_expr *mask; - gfc_code *c; - match m0, m; + gfc_expr *msk; + match m; - head = tail = NULL; - mask = NULL; - c = NULL; + gfc_gobble_whitespace (); - m0 = gfc_match_label (); - if (m0 == MATCH_ERROR) - return MATCH_ERROR; + head = tail = NULL; + msk = NULL; - m = gfc_match (" forall ("); - if (m != MATCH_YES) - return m; + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; m = match_forall_iterator (&new); if (m == MATCH_ERROR) @@ -3508,6 +3896,7 @@ gfc_match_forall (gfc_statement * st) m = match_forall_iterator (&new); if (m == MATCH_ERROR) goto cleanup; + if (m == MATCH_YES) { tail->next = new; @@ -3516,7 +3905,8 @@ gfc_match_forall (gfc_statement * st) } /* Have to have a mask expression. */ - m = gfc_match_expr (&mask); + + m = gfc_match_expr (&msk); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) @@ -3528,14 +3918,118 @@ gfc_match_forall (gfc_statement * st) 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 = gfc_get_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.expr = mask; + new_st.ext.forall_iterator = head; + new_st.block = gfc_get_code (); + + new_st.block->op = 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.expr = mask; new_st.ext.forall_iterator = head; - return MATCH_YES; } @@ -3553,16 +4047,13 @@ gfc_match_forall (gfc_statement * st) c = gfc_get_code (); *c = new_st; - - if (gfc_match_eos () != MATCH_YES) - goto syntax; + c->loc = gfc_current_locus; gfc_clear_new_st (); new_st.op = EXEC_FORALL; new_st.expr = mask; new_st.ext.forall_iterator = head; new_st.block = gfc_get_code (); - new_st.block->op = EXEC_FORALL; new_st.block->next = c;