/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
Inc.
Contributed by Andy Vaught
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. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "flags.h"
-
-#include <stdarg.h>
-#include <string.h>
-
#include "gfortran.h"
#include "match.h"
#include "parse.h"
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;
}
for (;;)
{
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
break;
}
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return (flag) ? MATCH_YES : MATCH_NO;
}
char c;
int i;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if (!ISDIGIT (c))
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_NO;
}
for (;;)
{
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
c = gfc_next_char ();
if (!ISDIGIT (c))
}
}
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
*value = i;
return MATCH_YES;
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;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
m = gfc_match_small_literal_int (&i);
if (m != MATCH_YES)
return m;
- if (((i == 0) && allow_zero) || i <= 99999)
+ if (i > 0 && i <= 99999)
{
*label = gfc_get_st_label (i);
return MATCH_YES;
}
- gfc_error ("Statement label at %C is out of range");
- gfc_set_locus (&old_loc);
+ if (i == 0)
+ gfc_error ("Statement label at %C is zero");
+ else
+ gfc_error ("Statement label at %C is out of range");
+ gfc_current_locus = old_loc;
return MATCH_ERROR;
}
gfc_match_label (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_state_data *p;
match m;
gfc_new_block = NULL;
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;
}
no_match = p->tag;
best_match = NULL;
- match_loc = *gfc_current_locus ();
+ match_loc = gfc_current_locus;
gfc_gobble_whitespace ();
if (*p->mp == '\0')
{
/* Found a match. */
- match_loc = *gfc_current_locus ();
+ match_loc = gfc_current_locus;
best_match = p;
possibles--;
p->mp = NULL;
}
}
- gfc_set_locus (&match_loc);
+ gfc_current_locus = match_loc;
return (best_match == NULL) ? no_match : best_match->tag;
}
locus old_loc;
int i, c;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if (!ISALPHA (c))
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_NO;
}
return MATCH_ERROR;
}
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
c = gfc_next_char ();
}
while (ISALNUM (c)
|| (gfc_option.flag_dollar_ok && c == '$'));
buffer[i] = '\0';
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_YES;
}
else
*matched_symbol = NULL;
}
+ else
+ *matched_symbol = NULL;
return m;
}
/* Match the start of an iterator without affecting the symbol
table. */
- start = *gfc_current_locus ();
+ start = gfc_current_locus;
m = gfc_match (" %n =", name);
- gfc_set_locus (&start);
+ gfc_current_locus = start;
if (m != MATCH_YES)
return MATCH_NO;
{
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;
}
void **vp;
const char *p;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
va_start (argp, target);
m = MATCH_NO;
matches = 0;
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;
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;
/*********************** 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)
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)
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;
locus old_loc;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
m = gfc_match (" %v =", &lvalue);
if (m != MATCH_YES)
goto cleanup;
+ if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ {
+ gfc_error ("Cannot assign to a PARAMETER variable at %C");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
m = gfc_match (" %e%t", &rvalue);
if (m != MATCH_YES)
goto cleanup;
new_st.expr = lvalue;
new_st.expr2 = rvalue;
+ gfc_check_do_variable (lvalue->symtree);
+
return MATCH_YES;
cleanup:
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
gfc_free_expr (lvalue);
gfc_free_expr (rvalue);
return m;
locus old_loc;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
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_DEL,
+ "Obsolete: 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.
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)
{
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)
gfc_free_expr (expr);
return MATCH_ERROR;
}
+
+ if (gfc_notify_std (GFC_STD_F95_DEL,
+ "Obsolete: arithmetic IF statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
new_st.expr = expr;
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;
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_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_clear_error ();
match ("allocate", gfc_match_allocate, ST_ALLOCATE)
+ match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
match ("backspace", gfc_match_backspace, ST_BACKSPACE)
match ("call", gfc_match_call, ST_CALL)
match ("close", gfc_match_close, ST_CLOSE)
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 ("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 ("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 ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
/* All else has failed, so give up. See if any of the matchers has
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;
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;
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;
/* The abortive DO WHILE may have done something to the symbol
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_st_label (&label, 0); /* Can't error out */
+ gfc_match_st_label (&label); /* Can't error out */
gfc_match_char (','); /* Optional comma */
m = gfc_match_iterator (&iter, 0);
if (m == MATCH_ERROR)
goto cleanup;
+ gfc_check_do_variable (iter.var->symtree);
+
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_DO);
gfc_expr *e;
match m;
- stop_code = 0;
+ stop_code = -1;
e = NULL;
if (gfc_match_eos () != MATCH_YES)
== FAILURE)
return MATCH_ERROR;
- expr->symtree->n.sym->attr.assign = 1;
new_st.op = EXEC_GOTO;
new_st.expr = expr;
do
{
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
do
{
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
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))
{
"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)
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
/* 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;
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;
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))
{
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)
{
gfc_expr *e;
match m;
+ gfc_compile_state s;
+ int c;
e = NULL;
if (gfc_match_eos () == MATCH_YES)
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)
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;
if (!sym->attr.generic
&& !sym->attr.subroutine
- && gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
+ && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_match_eos () != MATCH_YES)
i = 0;
for (a = arglist; a; a = a->next)
if (a->expr == NULL)
- i = 1;
+ i = 1;
if (i)
{
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)
}
-/* 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. */
-
-match
-gfc_match_implicit_none (void)
-{
-
- return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
-}
-
-
-/* Match the letter range(s) of an IMPLICIT statement. */
+/* 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. */
-static match
-match_implicit_range (gfc_typespec * ts)
+gfc_common_head *
+gfc_get_common (const char *name, int from_module)
{
- int c, c1, c2, inner;
- locus cur_loc;
-
- cur_loc = *gfc_current_locus ();
+ gfc_symtree *st;
+ static int serial = 0;
+ char mangled_name[GFC_MAX_SYMBOL_LEN+1];
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if (c != '(')
+ if (from_module)
{
- gfc_error ("Missing character range in IMPLICIT at %C");
- goto bad;
+ /* 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);
}
-
- inner = 1;
- while (inner)
+ else
{
- 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 */
-
- case ',':
- c2 = c1;
- break;
-
- case '-':
- gfc_gobble_whitespace ();
- c2 = gfc_next_char ();
- if (!ISALPHA (c2))
- goto bad;
-
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
-
- 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)
+ st = gfc_find_symtree (gfc_current_ns->common_root, name);
- 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;
+ if (st == NULL)
+ st = gfc_new_symtree (&gfc_current_ns->common_root, name);
}
- /* First cleanup. */
- gfc_clear_new_implicit ();
-
- do
+ if (st->n.common == NULL)
{
- /* 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 <TYPE> (<RANGE>). */
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if ((c == '\n') || (c == ','))
- continue;
-
- gfc_set_locus (&cur_loc);
- }
-
- /* Last chance -- check <TYPE> (<KIND>) (<RANGE>). */
- 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;
-
+ st->n.common = gfc_get_common_head ();
+ st->n.common->where = gfc_current_locus;
+ strcpy (st->n.common->name, name);
}
- 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;
+ return st->n.common;
}
/* Match a common block name. */
static match
-match_common_name (gfc_symbol ** sym)
+match_common_name (char *name)
{
match m;
if (gfc_match_char ('/') == MATCH_NO)
- return MATCH_NO;
+ {
+ name[0] = '\0';
+ return MATCH_YES;
+ }
if (gfc_match_char ('/') == MATCH_YES)
{
- *sym = NULL;
+ name[0] = '\0';
return MATCH_YES;
}
- m = gfc_match_symbol (sym, 0);
+ m = gfc_match_name (name);
if (m == MATCH_ERROR)
return MATCH_ERROR;
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;
- 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;
+ if (name[0] == '\0')
+ {
+ t = &gfc_current_ns->blank_common;
+ if (t->head == NULL)
+ t->where = gfc_current_locus;
+ head = &t->head;
+ }
else
{
- head = &common_name->common_head;
-
- if (!common_name->attr.common
- && gfc_add_common (&common_name->attr, NULL) == FAILURE)
- goto cleanup;
+ t = gfc_get_common (name, 0);
+ head = &t->head;
}
if (*head == NULL)
goto cleanup;
}
- if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
+ goto cleanup;
+
+ if (sym->value != NULL
+ && (name[0] == '\0' || !sym->attr.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_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
/* Derived type names must have the SEQUENCE attribute. */
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)
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;
}
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;
}
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;
}
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 (;;)
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. */
-
nl = gfc_get_namelist ();
nl->sym = sym;
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;
{
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;
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)
{
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;
set = set->eq;
}
+ if (cnt < 2)
+ {
+ gfc_error ("EQUIVALENCE at %C requires two or more objects");
+ goto cleanup;
+ }
+
+ /* 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_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
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)
+/* 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. */
+static bool
+recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
{
- gfc_error_buf old_error;
- gfc_symbol *sym;
- gfc_expr *expr;
- match m;
+ gfc_actual_arglist *arg;
+ gfc_ref *ref;
+ int i;
- m = gfc_match_symbol (&sym, 0);
- if (m != MATCH_YES)
- return m;
+ if (e == NULL)
+ return false;
- gfc_push_error (&old_error);
+ 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 (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
- goto undo_error;
+ if (e->symtree == NULL)
+ return false;
- if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
- goto undo_error;
+ /* Check the name before testing for nested recursion! */
+ if (sym->name == e->symtree->n.sym->name)
+ return true;
- m = gfc_match (" = %e%t", &expr);
- if (m == MATCH_NO)
- goto undo_error;
- if (m == MATCH_ERROR)
- return m;
+ /* 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;
- sym->value = expr;
+ break;
- 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. */
+ case EXPR_VARIABLE:
+ if (e->symtree && sym->name == e->symtree->n.sym->name)
+ return true;
+ break;
-static void
-free_value (gfc_data_value * p)
-{
- gfc_data_value *q;
+ case EXPR_OP:
+ if (recursive_stmt_fcn (e->value.op.op1, sym)
+ || recursive_stmt_fcn (e->value.op.op2, sym))
+ return true;
+ break;
- for (; p; p = q)
- {
- q = p->next;
- gfc_free_expr (p->expr);
- gfc_free (p);
+ default:
+ break;
}
-}
-
-
-/* Free a list of gfc_data structures. */
-
-void
-gfc_free_data (gfc_data * p)
-{
- gfc_data *q;
- for (; p; p = q)
+ /* Component references do not need to be checked. */
+ if (e->ref)
{
- 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;
+ 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;
- m = var_element (&var);
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_NO)
- goto syntax;
+ case REF_SUBSTRING:
+ if (recursive_stmt_fcn (ref->u.ss.start, sym)
+ || recursive_stmt_fcn (ref->u.ss.end, sym))
+ return true;
- tail->next = gfc_get_data_variable ();
- tail = tail->next;
+ break;
- *tail = var;
+ default:
+ break;
+ }
+ }
}
-
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_DATA);
- return MATCH_ERROR;
+ return false;
}
-/* Match a single element in a data variable list, which can be a
- variable-iterator list. */
+/* 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. */
-static match
-var_element (gfc_data_variable * new)
+match
+gfc_match_st_function (void)
{
+ gfc_error_buf old_error;
+ gfc_symbol *sym;
+ gfc_expr *expr;
match m;
- memset (new, '\0', sizeof (gfc_data_variable));
-
- if (gfc_match_char ('(') == MATCH_YES)
- return var_list (new);
-
- m = gfc_match_variable (&new->expr, 0);
+ m = gfc_match_symbol (&sym, 0);
if (m != MATCH_YES)
return m;
- if (new->expr->symtree->n.sym->value != NULL)
- {
- gfc_error ("Variable '%s' at %C already has an initialization",
- new->expr->symtree->n.sym->name);
- return MATCH_ERROR;
- }
-
- new->expr->symtree->n.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 (gfc_match_char ('/') == MATCH_YES)
- break;
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
- }
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_DATA);
- return MATCH_ERROR;
-}
+ gfc_push_error (&old_error);
+ if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
+ sym->name, NULL) == FAILURE)
+ goto undo_error;
-static match
-match_data_constant (gfc_expr ** result)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
- gfc_expr *expr;
- match m;
+ if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
+ goto undo_error;
- m = gfc_match_literal_constant (&expr, 1);
- if (m == MATCH_YES)
- {
- *result = expr;
- return MATCH_YES;
- }
+ m = gfc_match (" = %e%t", &expr);
+ if (m == MATCH_NO)
+ goto undo_error;
+ gfc_free_error (&old_error);
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;
-
- if (sym == NULL || sym->attr.flavor != FL_PARAMETER)
+ if (recursive_stmt_fcn (expr, sym))
{
- gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
- name);
+ gfc_error ("Statement function at %L is recursive",
+ &expr->where);
return MATCH_ERROR;
}
- *result = gfc_copy_expr (sym->value);
- return MATCH_YES;
-}
-
-
-/* Match a list of values in a DATA statement. The leading '/' has
- already been seen at this point. */
-
-static match
-top_val_list (gfc_data * data)
-{
- gfc_data_value *new, *tail;
- gfc_expr *expr;
- const char *msg;
- match m;
-
- tail = NULL;
-
- for (;;)
- {
- m = match_data_constant (&expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- new = gfc_get_data_value ();
-
- if (tail == NULL)
- data->value = new;
- else
- tail->next = new;
-
- tail = new;
-
- 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;
- }
-
- m = match_data_constant (&tail->expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- }
-
- if (gfc_match_char ('/') == MATCH_YES)
- break;
- if (gfc_match_char (',') == MATCH_NO)
- goto syntax;
- }
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_DATA);
- return MATCH_ERROR;
-}
-
-
-/* Match a DATA statement. */
-
-match
-gfc_match_data (void)
-{
- gfc_data *new;
- match m;
-
- for (;;)
- {
- new = gfc_get_data ();
- new->where = *gfc_current_locus ();
-
- m = top_var_list (new);
- if (m != MATCH_YES)
- goto cleanup;
-
- m = top_val_list (new);
- if (m != MATCH_YES)
- goto cleanup;
-
- new->next = gfc_current_ns->data;
- gfc_current_ns->data = new;
-
- if (gfc_match_eos () == MATCH_YES)
- break;
-
- gfc_match_char (','); /* Optional comma */
- }
-
- if (gfc_pure (NULL))
- {
- gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
- 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;
}
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)
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! */
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);
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;
}
/********************* 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
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->start);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
+ if (m != MATCH_YES)
goto cleanup;
if (gfc_match_char (':') != MATCH_YES)
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;
+ 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;
+ *mask = 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)
continue;
}
- /* Have to have a mask expression. */
- m = gfc_match_expr (&mask);
+ /* Have to have a mask expression */
+
+ m = gfc_match_expr (mask);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
if (gfc_match_char (')') == MATCH_NO)
goto syntax;
+ *phead = head;
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_FORALL);
+
+cleanup:
+ gfc_free_expr (*mask);
+ 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;
OSDN Git Service
