/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
#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. */
-
-static 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_OS),
- minit ("==", INTRINSIC_EQ),
- minit (".ne.", INTRINSIC_NE_OS),
- minit ("/=", INTRINSIC_NE),
- minit (".ge.", INTRINSIC_GE_OS),
- minit (">=", INTRINSIC_GE),
- minit (".le.", INTRINSIC_LE_OS),
- minit ("<=", INTRINSIC_LE),
- minit (".lt.", INTRINSIC_LT_OS),
- minit ("<", INTRINSIC_LT),
- minit (".gt.", INTRINSIC_GT_OS),
- minit (">", INTRINSIC_GT),
- minit (".not.", INTRINSIC_NOT),
- minit ("parens", INTRINSIC_PARENTHESES),
- minit (NULL, INTRINSIC_NONE)
-};
+int gfc_matching_procptr_assignment = 0;
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
/******************** 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 count, instring;
+ gfc_char_t c, 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 = 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 at or before %L", &where);
+ return MATCH_ERROR;
+ }
+ if (count < 0)
+ {
+ gfc_error ("Missing '(' in statement at or 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)
+gfc_match_special_char (gfc_char_t *res)
{
-
+ int len, i;
+ gfc_char_t c, n;
match m;
m = MATCH_YES;
- switch (gfc_next_char_literal (1))
+ switch ((c = gfc_next_char_literal (1)))
{
case 'a':
- *c = '\a';
+ *res = '\a';
break;
case 'b':
- *c = '\b';
+ *res = '\b';
break;
case 't':
- *c = '\t';
+ *res = '\t';
break;
case 'f':
- *c = '\f';
+ *res = '\f';
break;
case 'n':
- *c = '\n';
+ *res = '\n';
break;
case 'r':
- *c = '\r';
+ *res = '\r';
break;
case 'v':
- *c = '\v';
+ *res = '\v';
break;
case '\\':
- *c = '\\';
+ *res = '\\';
break;
case '0':
- *c = '\0';
+ *res = '\0';
break;
+
+ case 'x':
+ case 'u':
+ case 'U':
+ /* Hexadecimal form of wide characters. */
+ len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
+ n = 0;
+ for (i = 0; i < len; i++)
+ {
+ char buf[2] = { '\0', '\0' };
+
+ c = gfc_next_char_literal (1);
+ if (!gfc_wide_fits_in_byte (c)
+ || !gfc_check_digit ((unsigned char) c, 16))
+ return MATCH_NO;
+
+ buf[0] = (unsigned char) c;
+ n = n << 4;
+ n += strtol (buf, NULL, 16);
+ }
+ *res = n;
+ break;
+
default:
/* Unknown backslash codes are simply not expanded. */
m = MATCH_NO;
gfc_match_space (void)
{
locus old_loc;
- int c;
+ char c;
if (gfc_current_form == FORM_FIXED)
return MATCH_YES;
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (!gfc_is_whitespace (c))
{
gfc_current_locus = old_loc;
gfc_match_eos (void)
{
locus old_loc;
- int flag, c;
+ int flag;
+ char c;
flag = 0;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
switch (c)
{
case '!':
do
{
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
while (c != '\n');
old_loc = gfc_current_locus;
+ *value = -1;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (cnt)
*cnt = 0;
for (;;)
{
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (!ISDIGIT (c))
break;
}
-/* 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
gfc_match_name (char *buffer)
{
locus old_loc;
- int i, c;
+ int i;
+ char c;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_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;
}
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
+ if (c == '$' && !gfc_option.flag_dollar_ok)
+ {
+ gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
+ "as an extension");
+ return MATCH_ERROR;
+ }
+
buffer[i] = '\0';
gfc_current_locus = old_loc;
{
locus old_loc;
int i = 0;
- int c;
+ gfc_char_t c;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
/* Continue to read valid variable name characters. */
do
{
- buffer[i++] = c;
+ gcc_assert (gfc_wide_fits_in_byte (c));
+
+ buffer[i++] = (unsigned char) c;
/* C does not define a maximum length of variable names, to my
knowledge, but the compiler typically places a limit on them.
if (c == ' ')
{
gfc_gobble_whitespace ();
- c = gfc_peek_char ();
+ c = gfc_peek_ascii_char ();
if (c != '"' && c != '\'')
{
gfc_error ("Embedded space in NAME= specifier at %C");
match
gfc_match_intrinsic_op (gfc_intrinsic_op *result)
{
- gfc_intrinsic_op op;
+ locus orig_loc = gfc_current_locus;
+ char ch;
- op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
+ gfc_gobble_whitespace ();
+ ch = gfc_next_ascii_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_ascii_char () == '=')
+ {
+ /* Matched "==". */
+ *result = INTRINSIC_EQ;
+ return MATCH_YES;
+ }
+ break;
+
+ case '<':
+ if (gfc_peek_ascii_char () == '=')
+ {
+ /* Matched "<=". */
+ gfc_next_ascii_char ();
+ *result = INTRINSIC_LE;
+ return MATCH_YES;
+ }
+ /* Matched "<". */
+ *result = INTRINSIC_LT;
+ return MATCH_YES;
+
+ case '>':
+ if (gfc_peek_ascii_char () == '=')
+ {
+ /* Matched ">=". */
+ gfc_next_ascii_char ();
+ *result = INTRINSIC_GE;
+ return MATCH_YES;
+ }
+ /* Matched ">". */
+ *result = INTRINSIC_GT;
+ return MATCH_YES;
+
+ case '*':
+ if (gfc_peek_ascii_char () == '*')
+ {
+ /* Matched "**". */
+ gfc_next_ascii_char ();
+ *result = INTRINSIC_POWER;
+ return MATCH_YES;
+ }
+ /* Matched "*". */
+ *result = INTRINSIC_TIMES;
+ return MATCH_YES;
+
+ case '/':
+ ch = gfc_peek_ascii_char ();
+ if (ch == '=')
+ {
+ /* Matched "/=". */
+ gfc_next_ascii_char ();
+ *result = INTRINSIC_NE;
+ return MATCH_YES;
+ }
+ else if (ch == '/')
+ {
+ /* Matched "//". */
+ gfc_next_ascii_char ();
+ *result = INTRINSIC_CONCAT;
+ return MATCH_YES;
+ }
+ /* Matched "/". */
+ *result = INTRINSIC_DIVIDE;
+ return MATCH_YES;
+
+ case '.':
+ ch = gfc_next_ascii_char ();
+ switch (ch)
+ {
+ case 'a':
+ if (gfc_next_ascii_char () == 'n'
+ && gfc_next_ascii_char () == 'd'
+ && gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".and.". */
+ *result = INTRINSIC_AND;
+ return MATCH_YES;
+ }
+ break;
+
+ case 'e':
+ if (gfc_next_ascii_char () == 'q')
+ {
+ ch = gfc_next_ascii_char ();
+ if (ch == '.')
+ {
+ /* Matched ".eq.". */
+ *result = INTRINSIC_EQ_OS;
+ return MATCH_YES;
+ }
+ else if (ch == 'v')
+ {
+ if (gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".eqv.". */
+ *result = INTRINSIC_EQV;
+ return MATCH_YES;
+ }
+ }
+ }
+ break;
+
+ case 'g':
+ ch = gfc_next_ascii_char ();
+ if (ch == 'e')
+ {
+ if (gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".ge.". */
+ *result = INTRINSIC_GE_OS;
+ return MATCH_YES;
+ }
+ }
+ else if (ch == 't')
+ {
+ if (gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".gt.". */
+ *result = INTRINSIC_GT_OS;
+ return MATCH_YES;
+ }
+ }
+ break;
+
+ case 'l':
+ ch = gfc_next_ascii_char ();
+ if (ch == 'e')
+ {
+ if (gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".le.". */
+ *result = INTRINSIC_LE_OS;
+ return MATCH_YES;
+ }
+ }
+ else if (ch == 't')
+ {
+ if (gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".lt.". */
+ *result = INTRINSIC_LT_OS;
+ return MATCH_YES;
+ }
+ }
+ break;
+
+ case 'n':
+ ch = gfc_next_ascii_char ();
+ if (ch == 'e')
+ {
+ ch = gfc_next_ascii_char ();
+ if (ch == '.')
+ {
+ /* Matched ".ne.". */
+ *result = INTRINSIC_NE_OS;
+ return MATCH_YES;
+ }
+ else if (ch == 'q')
+ {
+ if (gfc_next_ascii_char () == 'v'
+ && gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".neqv.". */
+ *result = INTRINSIC_NEQV;
+ return MATCH_YES;
+ }
+ }
+ }
+ else if (ch == 'o')
+ {
+ if (gfc_next_ascii_char () == 't'
+ && gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".not.". */
+ *result = INTRINSIC_NOT;
+ return MATCH_YES;
+ }
+ }
+ break;
+
+ case 'o':
+ if (gfc_next_ascii_char () == 'r'
+ && gfc_next_ascii_char () == '.')
+ {
+ /* Matched ".or.". */
+ *result = INTRINSIC_OR;
+ return MATCH_YES;
+ }
+ break;
+
+ default:
+ break;
+ }
+ break;
+
+ default:
+ break;
+ }
+
+ gfc_current_locus = orig_loc;
+ return MATCH_NO;
}
where = gfc_current_locus;
gfc_gobble_whitespace ();
- if (gfc_next_char () == c)
+ if (gfc_next_ascii_char () == c)
return MATCH_YES;
gfc_current_locus = where;
}
default:
- if (c == gfc_next_char ())
+ if (c == gfc_next_ascii_char ())
goto loop;
break;
}
case 'e':
case 'v':
vp = va_arg (argp, void **);
- gfc_free_expr (*vp);
+ gfc_free_expr ((struct gfc_expr *)*vp);
*vp = NULL;
break;
}
return MATCH_NO;
}
- if (lvalue->symtree->n.sym->attr.protected
+ if (lvalue->symtree->n.sym->attr.is_protected
&& lvalue->symtree->n.sym->attr.use_assoc)
{
gfc_current_locus = old_loc;
old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
+ gfc_matching_procptr_assignment = 0;
m = gfc_match (" %v =>", &lvalue);
if (m != MATCH_YES)
goto cleanup;
}
+ if (lvalue->symtree->n.sym->attr.proc_pointer)
+ gfc_matching_procptr_assignment = 1;
+
m = gfc_match (" %e%t", &rvalue);
+ gfc_matching_procptr_assignment = 0;
if (m != MATCH_YES)
goto cleanup;
- if (lvalue->symtree->n.sym->attr.protected
+ if (lvalue->symtree->n.sym->attr.is_protected
&& lvalue->symtree->n.sym->attr.use_assoc)
{
gfc_error ("Assigning to a PROTECTED pointer at %C");
{
gfc_expr *expr;
gfc_st_label *l1, *l2, *l3;
- locus old_loc;
+ locus old_loc, old_loc2;
gfc_code *p;
match m, n;
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");
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;
}
match ("return", gfc_match_return, ST_RETURN)
match ("rewind", gfc_match_rewind, ST_REWIND)
match ("stop", gfc_match_stop, ST_STOP)
+ match ("wait", gfc_match_wait, ST_WAIT)
match ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
return MATCH_NO;
+ /* Check for balanced parens. */
+
+ if (gfc_match_parens () == MATCH_ERROR)
+ return MATCH_ERROR;
+
/* See if we have a DO WHILE. */
if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
{
}
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);
- 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;
- }
-
- 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);
- }
+ gfc_check_do_variable(stat->symtree);
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
}
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;
gfc_expr *e;
match m;
gfc_compile_state s;
- int c;
e = NULL;
if (gfc_match_eos () == MATCH_YES)
RETURN keyword:
return+1
return(1) */
- c = gfc_peek_char ();
+ char c = gfc_peek_ascii_char ();
if (ISALPHA (c) || ISDIGIT (c))
return MATCH_NO;
}
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;
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
gfc_gobble_whitespace ();
if (gfc_match_eos () == MATCH_YES)
goto done;
- if (gfc_peek_char () == '/')
+ if (gfc_peek_ascii_char () == '/')
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
gfc_gobble_whitespace ();
- if (gfc_peek_char () == '/')
+ if (gfc_peek_ascii_char () == '/')
break;
}
}
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;
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;
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;
-
- case REF_SUBSTRING:
- if (recursive_stmt_fcn (ref->u.ss.start, sym)
- || recursive_stmt_fcn (ref->u.ss.end, sym))
- return true;
+ return false;
+}
- 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);
}
match m;
where = gfc_current_locus;
- iter = gfc_getmem (sizeof (gfc_forall_iterator));
+ iter = XCNEW (gfc_forall_iterator);
m = gfc_match_expr (&iter->var);
if (m != MATCH_YES)
static match
match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
{
- gfc_forall_iterator *head, *tail, *new;
+ gfc_forall_iterator *head, *tail, *new_iter;
gfc_expr *msk;
match m;
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
- m = match_forall_iterator (&new);
+ m = match_forall_iterator (&new_iter);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
- head = tail = new;
+ head = tail = new_iter;
for (;;)
{
if (gfc_match_char (',') != MATCH_YES)
break;
- m = match_forall_iterator (&new);
+ m = match_forall_iterator (&new_iter);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
{
- tail->next = new;
- tail = new;
+ tail->next = new_iter;
+ tail = new_iter;
continue;
}