/* 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
#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_new_block->attr.flavor != FL_LABEL
- && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, NULL) == FAILURE)
+ && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
+ gfc_new_block->name, NULL) == FAILURE)
return MATCH_ERROR;
for (p = gfc_state_stack; p; p = p->previous)
/*********************** 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;
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:
}
+/* 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)
{
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_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 ("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
if (m == MATCH_ERROR)
goto cleanup;
+ gfc_check_do_variable (iter.var->symtree);
+
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_DO);
== FAILURE)
return MATCH_ERROR;
- expr->symtree->n.sym->attr.assign = 1;
new_st.op = EXEC_GOTO;
new_st.expr = expr;
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
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)
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;
/* Given a name, return a pointer to the common head structure,
- creating it if it does not exist.
+ 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. */
gfc_common_head *
-gfc_get_common (char *name)
+gfc_get_common (const char *name, int from_module)
{
gfc_symtree *st;
+ static int serial = 0;
+ char mangled_name[GFC_MAX_SYMBOL_LEN+1];
- st = gfc_find_symtree (gfc_current_ns->common_root, name);
- if (st == NULL)
- st = gfc_new_symtree (&gfc_current_ns->common_root, name);
+ 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 st->n.common;
}
else
{
- t = gfc_get_common (name);
+ t = gfc_get_common (name, 0);
head = &t->head;
-
- if (t->use_assoc)
- {
- gfc_error ("COMMON block '%s' at %C has already "
- "been USE-associated");
- goto cleanup;
- }
}
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
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. */
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)
as = NULL;
}
+ 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;
}
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_push_error (&old_error);
- if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
+ if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
+ sym->name, NULL) == FAILURE)
goto undo_error;
if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
}
-/********************* 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;
- gfc_common_head *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 0 // TODO: Find out where to move this message
- 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->head)
- {
- gfc_error ("DATA statement at %C may not initialize variable "
- "'%s' from blank COMMON", sym->name);
- return MATCH_ERROR;
- }
-#endif
-
- if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
- return MATCH_ERROR;
-
- 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;
-}
-
-
-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;
-
- 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);
-
- *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;
- }
-
- return MATCH_YES;
-
-cleanup:
- gfc_free_data (new);
- return MATCH_ERROR;
-}
-
-
/***************** SELECT CASE subroutines ******************/
/* Free a single case structure. */
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
/********************* 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
}
-/* 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
