X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fmatch.c;h=324e52ecee042d532c5acb6985c25d104dc54043;hb=a9e7fd6a16ffdbec685fac893dd44f1831849cc1;hp=e00c2853f0ce1b00856608ebca55cdca47e88dbc;hpb=0e70e3df12d2339ff1abb2bc41791f2de0bc0a77;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index e00c2853f0c..324e52ecee0 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -7,7 +7,7 @@ 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,9 +16,8 @@ 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, 51 Franklin Street, Fifth Floor, Boston, MA -02110-1301, USA. */ +along with GCC; see the file COPYING3. If not see +. */ #include "config.h" #include "system.h" @@ -27,43 +26,146 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #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 ("parens", INTRINSIC_PARENTHESES), - 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. */ @@ -270,6 +372,38 @@ 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. */ @@ -345,90 +479,6 @@ gfc_match_label (void) } -/* 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. */ - -int -gfc_match_strings (mstring *a) -{ - mstring *p, *best_match; - int no_match, c, possibles; - locus match_loc; - - possibles = 0; - - for (p = a; p->string != NULL; p++) - { - p->mp = p->string; - possibles++; - } - - no_match = p->tag; - - best_match = NULL; - match_loc = gfc_current_locus; - - gfc_gobble_whitespace (); - - while (possibles > 0) - { - c = gfc_next_char (); - - /* Apply the next character to the current possibilities. */ - for (p = a; p->string != NULL; p++) - { - 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_current_locus = match_loc; - - return (best_match == NULL) ? no_match : best_match->tag; -} - - /* 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 @@ -446,7 +496,7 @@ gfc_match_name (char *buffer) c = gfc_next_char (); if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore))) { - if (gfc_error_flag_test() == 0) + if (gfc_error_flag_test() == 0 && c != '(') gfc_error ("Invalid character in name at %C"); gfc_current_locus = old_loc; return MATCH_NO; @@ -476,6 +526,99 @@ gfc_match_name (char *buffer) } +/* 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_C (char *buffer) +{ + locus old_loc; + int i = 0; + int c; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + /* 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 == '\'') + { + 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; + } + + /* 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; + + /* Get next char; param means we're in a string. */ + c = gfc_next_char_literal (1); + } while (ISALNUM (c) || c == '_'); + + buffer[i] = '\0'; + 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; +} + + /* Match a symbol on the input. Modifies the pointer to the symbol pointer if successful. */ @@ -528,15 +671,224 @@ gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) match gfc_match_intrinsic_op (gfc_intrinsic_op *result) { - gfc_intrinsic_op op; + locus orig_loc = gfc_current_locus; + int ch; + + gfc_gobble_whitespace (); + ch = gfc_next_char (); + switch (ch) + { + case '+': + /* Matched "+". */ + *result = INTRINSIC_PLUS; + return MATCH_YES; - op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators); + case '-': + /* Matched "-". */ + *result = INTRINSIC_MINUS; + return MATCH_YES; - if (op == INTRINSIC_NONE) - return MATCH_NO; + case '=': + if (gfc_next_char () == '=') + { + /* Matched "==". */ + *result = INTRINSIC_EQ; + return MATCH_YES; + } + break; - *result = op; - return MATCH_YES; + case '<': + if (gfc_peek_char () == '=') + { + /* Matched "<=". */ + gfc_next_char (); + *result = INTRINSIC_LE; + return MATCH_YES; + } + /* Matched "<". */ + *result = INTRINSIC_LT; + return MATCH_YES; + + 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; + + 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; + + 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; + + 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; + + 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; + + 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; + + 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; } @@ -1031,7 +1383,7 @@ 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; @@ -1045,6 +1397,14 @@ gfc_match_if (gfc_statement *if_type) 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"); @@ -1096,7 +1456,7 @@ gfc_match_if (gfc_statement *if_type) 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; } @@ -1375,6 +1735,7 @@ 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) @@ -1874,29 +2235,7 @@ gfc_match_allocate (void) } if (stat != NULL) - { - 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); - 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"); - 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); - } + gfc_check_do_variable(stat->symtree); if (gfc_match (" )%t") != MATCH_YES) goto syntax; @@ -2038,29 +2377,7 @@ gfc_match_deallocate (void) } if (stat != NULL) - { - 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); - } + gfc_check_do_variable(stat->symtree); if (gfc_match (" )%t") != MATCH_YES) goto syntax; @@ -2170,12 +2487,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, sym->name, 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) { @@ -2299,8 +2632,7 @@ gfc_get_common (const char *name, int from_module) /* Match a common block name. */ -static match -match_common_name (char *name) +match match_common_name (char *name) { match m; @@ -2375,11 +2707,6 @@ gfc_match_common (void) if (name[0] == '\0') { - if (gfc_current_ns->is_block_data) - { - gfc_warning ("BLOCK DATA unit cannot contain blank COMMON " - "at %C"); - } t = &gfc_current_ns->blank_common; if (t->head == NULL) t->where = gfc_current_locus; @@ -2408,6 +2735,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", @@ -2415,32 +2771,19 @@ gfc_match_common (void) goto cleanup; } - if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) - goto cleanup; - - if (sym->value != NULL && sym->value->expr_type != EXPR_NULL - && (name[0] == '\0' || !sym->attr.data)) + if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) + || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) { - if (name[0] == '\0') - 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, 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, 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 @@ -2655,12 +2998,6 @@ gfc_match_namelist (void) gfc_error_check (); } - if (sym->as && sym->as->type == AS_ASSUMED_SHAPE - && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in " - "namelist '%s' at %C is an extension.", - sym->name, group_name->name) == FAILURE) - gfc_error_check (); - nl = gfc_get_namelist (); nl->sym = sym; sym->refs++; @@ -2870,13 +3207,12 @@ cleanup: 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 bool -recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) +check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) { - gfc_actual_arglist *arg; - gfc_ref *ref; - int i; if (e == NULL) return false; @@ -2884,12 +3220,6 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) switch (e->expr_type) { case EXPR_FUNCTION: - for (arg = e->value.function.actual; arg; arg = arg->next) - { - if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym)) - return true; - } - if (e->symtree == NULL) return false; @@ -2916,46 +3246,18 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) gfc_set_default_type (e->symtree->n.sym, 0, NULL); break; - case EXPR_OP: - if (recursive_stmt_fcn (e->value.op.op1, sym) - || recursive_stmt_fcn (e->value.op.op2, sym)) - return true; - break; - default: break; } - /* Component references do not need to be checked. */ - if (e->ref) - { - for (ref = e->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - for (i = 0; i < ref->u.ar.dimen; i++) - { - if (recursive_stmt_fcn (ref->u.ar.start[i], sym) - || recursive_stmt_fcn (ref->u.ar.end[i], sym) - || recursive_stmt_fcn (ref->u.ar.stride[i], sym)) - return true; - } - break; + return false; +} - case REF_SUBSTRING: - if (recursive_stmt_fcn (ref->u.ss.start, sym) - || recursive_stmt_fcn (ref->u.ss.end, sym)) - return true; - break; - - default: - break; - } - } - } - return false; +static bool +recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) +{ + return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); }