/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
do most of the work. */
match
-gfc_match_st_label (gfc_st_label ** label)
+gfc_match_st_label (gfc_st_label **label)
{
locus old_loc;
match m;
A '%' character is a mandatory space. */
int
-gfc_match_strings (mstring * a)
+gfc_match_strings (mstring *a)
{
mstring *p, *best_match;
int no_match, c, possibles;
if (*p->mp == ' ')
{
/* Space matches 1+ whitespace(s). */
- if ((gfc_current_form == FORM_FREE)
- && gfc_is_whitespace (c))
+ if ((gfc_current_form == FORM_FREE) && gfc_is_whitespace (c))
continue;
p->mp++;
c = gfc_next_char ();
if (!ISALPHA (c))
{
+ if (gfc_error_flag_test() == 0)
+ 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 ();
}
- while (ISALNUM (c)
- || c == '_'
- || (gfc_option.flag_dollar_ok && c == '$'));
+ while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
buffer[i] = '\0';
gfc_current_locus = old_loc;
pointer if successful. */
match
-gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
+gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
if (host_assoc)
return (gfc_get_ha_sym_tree (buffer, matched_symbol))
- ? MATCH_ERROR : MATCH_YES;
+ ? MATCH_ERROR : MATCH_YES;
if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
return MATCH_ERROR;
match
-gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
+gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
{
gfc_symtree *st;
match m;
if (m == MATCH_YES)
{
if (st)
- *matched_symbol = st->n.sym;
+ *matched_symbol = st->n.sym;
else
- *matched_symbol = NULL;
+ *matched_symbol = NULL;
}
else
*matched_symbol = NULL;
return m;
}
+
/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
in matchexp.c. */
match
-gfc_match_intrinsic_op (gfc_intrinsic_op * result)
+gfc_match_intrinsic_op (gfc_intrinsic_op *result)
{
gfc_intrinsic_op op;
the equals sign is seen. */
match
-gfc_match_iterator (gfc_iterator * iter, int init_flag)
+gfc_match_iterator (gfc_iterator *iter, int init_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *var, *e1, *e2, *e3;
locus start;
match m;
- /* Match the start of an iterator without affecting the symbol
- table. */
+ /* Match the start of an iterator without affecting the symbol table. */
start = gfc_current_locus;
m = gfc_match (" %n =", name);
case 'l':
case 'n':
case 's':
- (void)va_arg (argp, void **);
+ (void) va_arg (argp, void **);
break;
case 'e':
return MATCH_NO;
}
+ if (lvalue->symtree->n.sym->attr.protected
+ && lvalue->symtree->n.sym->attr.use_assoc)
+ {
+ gfc_current_locus = old_loc;
+ gfc_free_expr (lvalue);
+ gfc_error ("Setting value of PROTECTED variable at %C");
+ return MATCH_ERROR;
+ }
+
rvalue = NULL;
m = gfc_match (" %e%t", &rvalue);
if (m != MATCH_YES)
if (m != MATCH_YES)
goto cleanup;
+ if (lvalue->symtree->n.sym->attr.protected
+ && lvalue->symtree->n.sym->attr.use_assoc)
+ {
+ gfc_error ("Assigning to a PROTECTED pointer at %C");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+
new_st.op = EXEC_POINTER_ASSIGN;
new_st.expr = lvalue;
new_st.expr2 = rvalue;
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)
{
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: arithmetic IF statement at %C") == FAILURE)
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: arithmetic IF statement "
+ "at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
static match match_simple_where (void);
match
-gfc_match_if (gfc_statement * if_type)
+gfc_match_if (gfc_statement *if_type)
{
gfc_expr *expr;
gfc_st_label *l1, *l2, *l3;
{
if (n == MATCH_YES)
{
- gfc_error
- ("Block label not appropriate for arithmetic IF statement "
- "at %C");
-
+ gfc_error ("Block label not appropriate for arithmetic IF "
+ "statement at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
|| 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;
+ 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.op = EXEC_IF;
new_st.expr = expr;
-
*if_type = ST_IF_BLOCK;
return MATCH_YES;
}
if (n == MATCH_YES)
{
gfc_error ("Block label is not appropriate IF statement at %C");
-
gfc_free_expr (expr);
return MATCH_ERROR;
}
/* All else has failed, so give up. See if any of the matchers has
stored an error message of some sort. */
- if (gfc_error_check () == 0)
+ if (gfc_error_check () == 0)
gfc_error ("Unclassifiable statement in IF-clause at %C");
gfc_free_expr (expr);
/* Free a gfc_iterator structure. */
void
-gfc_free_iterator (gfc_iterator * iter, int flag)
+gfc_free_iterator (gfc_iterator *iter, int flag)
{
-
if (iter == NULL)
return;
}
/* match an optional comma, if no comma is found a space is obligatory. */
- if (gfc_match_char(',') != MATCH_YES
- && gfc_match ("% ") != MATCH_YES)
+ if (gfc_match_char(',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
return MATCH_NO;
/* See if we have a DO WHILE. */
match
gfc_match_exit (void)
{
-
return match_exit_cycle (ST_EXIT, EXEC_EXIT);
}
match
gfc_match_cycle (void)
{
-
return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
}
{
m = gfc_match_small_literal_int (&stop_code, &cnt);
if (m == MATCH_ERROR)
- goto cleanup;
+ goto cleanup;
if (m == MATCH_YES && cnt > 5)
{
}
if (m == MATCH_NO)
- {
- /* Try a character constant. */
- m = gfc_match_expr (&e);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
- if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
- goto syntax;
- }
+ {
+ /* Try a character constant. */
+ m = gfc_match_expr (&e);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ goto syntax;
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+ goto syntax;
+ }
if (gfc_match_eos () != MATCH_YES)
- goto syntax;
+ goto syntax;
}
if (gfc_pure (NULL))
{
gfc_error ("%s statement not allowed in PURE procedure at %C",
- gfc_ascii_statement (st));
+ gfc_ascii_statement (st));
goto cleanup;
}
m = gfc_match_stopcode (ST_PAUSE);
if (m == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: PAUSE statement at %C")
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: PAUSE statement at %C")
== FAILURE)
m = MATCH_ERROR;
}
match
gfc_match_continue (void)
{
-
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_CONTINUE);
if (gfc_match (" %l", &label) == MATCH_YES)
{
if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
- return MATCH_ERROR;
+ return MATCH_ERROR;
if (gfc_match (" to %v%t", &expr) == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: ASSIGN statement at %C")
+ {
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: ASSIGN "
+ "statement at %C")
== FAILURE)
return MATCH_ERROR;
- expr->symtree->n.sym->attr.assign = 1;
+ expr->symtree->n.sym->attr.assign = 1;
- new_st.op = EXEC_LABEL_ASSIGN;
- new_st.label = label;
- new_st.expr = expr;
- return MATCH_YES;
- }
+ new_st.op = EXEC_LABEL_ASSIGN;
+ new_st.label = label;
+ new_st.expr = expr;
+ return MATCH_YES;
+ }
}
return MATCH_NO;
}
if (gfc_match_variable (&expr, 0) == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: Assigned GOTO statement at %C")
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: Assigned GOTO "
+ "statement at %C")
== FAILURE)
return MATCH_ERROR;
if (head == NULL)
{
- gfc_error (
- "Statement label list in GOTO at %C cannot be empty");
+ gfc_error ("Statement label list in GOTO at %C cannot be empty");
goto syntax;
}
new_st.block = head;
/* Frees a list of gfc_alloc structures. */
void
-gfc_free_alloc_list (gfc_alloc * p)
+gfc_free_alloc_list (gfc_alloc *p)
{
gfc_alloc *q;
goto cleanup;
if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ && gfc_impure_variable (tail->expr->symtree->n.sym))
{
gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
"PURE procedure");
{
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
{
- gfc_error
- ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
- "INTENT(IN)", stat->symtree->n.sym->name);
+ gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
+ "be INTENT(IN)", stat->symtree->n.sym->name);
goto cleanup;
}
if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
{
- gfc_error
- ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
- "procedure");
+ gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
+ "for a PURE procedure");
goto cleanup;
}
if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
{
- gfc_error("STAT expression at %C must be a variable");
+ gfc_error ("STAT expression at %C must be a variable");
goto cleanup;
}
if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
{
- gfc_error
- ("Illegal variable in NULLIFY at %C for a PURE procedure");
+ gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
goto cleanup;
}
goto cleanup;
if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error
- ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
- "procedure");
+ gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
+ "for a PURE procedure");
goto cleanup;
}
if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
{
- gfc_error("STAT expression at %C must be a variable");
+ gfc_error ("STAT expression at %C must be a variable");
goto cleanup;
}
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) */
+ RETURN keyword:
+ return+1
+ return(1) */
c = gfc_peek_char ();
if (ISALPHA (c) || ISDIGIT (c))
- return MATCH_NO;
+ return MATCH_NO;
}
m = gfc_match (" %e%t", &e);
gfc_enclosing_unit (&s);
if (s == COMP_PROGRAM
&& gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
- "main program at %C") == FAILURE)
+ "main program at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_RETURN;
new_st.next = c = gfc_get_code ();
c->op = EXEC_SELECT;
- sprintf (name, "_result_%s",sym->name);
+ sprintf (name, "_result_%s", sym->name);
gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */
select_sym = select_st->n.sym;
{
gfc_symtree *st;
static int serial = 0;
- char mangled_name[GFC_MAX_SYMBOL_LEN+1];
+ char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
if (from_module)
{
/* A use associated common block is only needed to correctly layout
the variables it contains. */
- snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
+ snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
}
else
gfc_match_common (void)
{
gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
- char name[GFC_MAX_SYMBOL_LEN+1];
+ char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_common_head *t;
gfc_array_spec *as;
- gfc_equiv * e1, * e2;
+ gfc_equiv *e1, *e2;
match m;
gfc_gsymbol *gsym;
gsym = gfc_get_gsymbol (name);
if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
{
- gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
- name);
+ gfc_error ("Symbol '%s' at %C is already an external symbol that "
+ "is not COMMON", name);
goto cleanup;
}
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;
- head = &t->head;
}
else
{
t = gfc_get_common (name, 0);
- head = &t->head;
}
+ head = &t->head;
if (*head == NULL)
tail = NULL;
/* 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");
+ gfc_error ("Derived type variable in COMMON at %C does not "
+ "have the SEQUENCE attribute");
goto cleanup;
}
tail = sym;
/* Deal with an optional array specification after the
- symbol name. */
+ symbol name. */
m = gfc_match_array_spec (&as);
if (m == MATCH_ERROR)
goto cleanup;
{
if (as->type != AS_EXPLICIT)
{
- gfc_error
- ("Array specification for symbol '%s' in COMMON at %C "
- "must be explicit", sym->name);
+ gfc_error ("Array specification for symbol '%s' in COMMON "
+ "at %C must be explicit", sym->name);
goto cleanup;
}
if (sym->attr.pointer)
{
- gfc_error
- ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
- sym->name);
+ gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
+ "POINTER array", sym->name);
goto cleanup;
}
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)
+ {
+ for (e2 = e1; e2; e2 = e2->eq)
+ if (e2->expr->symtree->n.sym == sym)
goto equiv_found;
continue;
{
other = e2->expr->symtree->n.sym;
if (other->common_head
- && other->common_head != sym->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,
+ sym->name, sym->common_head->name,
other->common_head->name);
goto cleanup;
}
/* Free a namelist structure. */
void
-gfc_free_namelist (gfc_namelist * name)
+gfc_free_namelist (gfc_namelist *name)
{
gfc_namelist *n;
{
if (group_name->ts.type != BT_UNKNOWN)
{
- gfc_error
- ("Namelist group name '%s' at %C already has a basic type "
- "of %s", group_name->name, gfc_typename (&group_name->ts));
+ gfc_error ("Namelist group name '%s' at %C already has a basic "
+ "type of %s", group_name->name,
+ gfc_typename (&group_name->ts));
return MATCH_ERROR;
}
&& gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
"at %C already is USE associated and can"
"not be respecified.", group_name->name)
- == FAILURE)
+ == FAILURE)
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
these are the only errors for the next two lines. */
if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
{
- gfc_error ("Assumed size array '%s' in namelist '%s'at "
- "%C is not allowed.", sym->name, group_name->name);
+ gfc_error ("Assumed size array '%s' in namelist '%s' at "
+ "%C is not allowed", sym->name, group_name->name);
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_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 ();
do this. */
void
-gfc_free_equiv (gfc_equiv * eq)
+gfc_free_equiv (gfc_equiv *eq)
{
-
if (eq == NULL)
return;
gfc_free_equiv (eq->eq);
gfc_free_equiv (eq->next);
-
gfc_free_expr (eq->expr);
gfc_free (eq);
}
for (ref = set->expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
{
- gfc_error
- ("Array reference in EQUIVALENCE at %C cannot be an "
- "array section");
+ gfc_error ("Array reference in EQUIVALENCE at %C cannot "
+ "be an array section");
goto cleanup;
}
sym = set->expr->symtree->n.sym;
- if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
- == FAILURE)
+ if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->attr.in_common)
{
gfc_error ("Attempt to indirectly overlap COMMON "
"blocks %s and %s by EQUIVALENCE at %C",
- sym->common_head->name,
- common_head->name);
+ sym->common_head->name, common_head->name);
goto cleanup;
}
sym->attr.in_common = 1;
return MATCH_ERROR;
}
+
/* 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.
case EXPR_FUNCTION:
for (arg = e->value.function.actual; arg; arg = arg->next)
{
- if (sym->name == arg->name
- || recursive_stmt_fcn (arg->expr, sym))
+ if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
return true;
}
/* 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))
+ && e->symtree->n.sym->value
+ && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
return true;
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
case EXPR_OP:
if (recursive_stmt_fcn (e->value.op.op1, sym)
- || recursive_stmt_fcn (e->value.op.op2, sym))
+ || recursive_stmt_fcn (e->value.op.op2, sym))
return true;
break;
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))
+ || 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))
+ || recursive_stmt_fcn (ref->u.ss.end, sym))
return true;
break;
if (recursive_stmt_fcn (expr, sym))
{
- gfc_error ("Statement function at %L is recursive",
- &expr->where);
+ gfc_error ("Statement function at %L is recursive", &expr->where);
return MATCH_ERROR;
}
/* Free a single case structure. */
static void
-free_case (gfc_case * p)
+free_case (gfc_case *p)
{
if (p->low == p->high)
p->high = NULL;
/* Free a list of case structures. */
void
-gfc_free_case_list (gfc_case * p)
+gfc_free_case_list (gfc_case *p)
{
gfc_case *q;
/* Match a single case selector. */
static match
-match_case_selector (gfc_case ** cp)
+match_case_selector (gfc_case **cp)
{
gfc_case *c;
match m;
if (m == MATCH_ERROR)
goto cleanup;
}
-
else
{
m = gfc_match_init_expr (&c->low);
/* Match a WHERE statement. */
match
-gfc_match_where (gfc_statement * st)
+gfc_match_where (gfc_statement *st)
{
gfc_expr *expr;
match m0, m;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_WHERE_BLOCK;
-
new_st.op = EXEC_WHERE;
new_st.expr = expr;
return MATCH_YES;
/* Free a list of FORALL iterators. */
void
-gfc_free_forall_iterator (gfc_forall_iterator * iter)
+gfc_free_forall_iterator (gfc_forall_iterator *iter)
{
gfc_forall_iterator *next;
while (iter)
{
next = iter->next;
-
gfc_free_expr (iter->var);
gfc_free_expr (iter->start);
gfc_free_expr (iter->end);
gfc_free_expr (iter->stride);
-
gfc_free (iter);
iter = next;
}
<var> = <start>:<end>[:<stride>][, <scalar mask>] */
static match
-match_forall_iterator (gfc_forall_iterator ** result)
+match_forall_iterator (gfc_forall_iterator **result)
{
gfc_forall_iterator *iter;
locus where;
/* Make sure that potential internal function references in the
mask do not get messed up. */
if (iter->var
- && iter->var->expr_type == EXPR_VARIABLE
- && iter->var->symtree->n.sym->refs == 1)
+ && iter->var->expr_type == EXPR_VARIABLE
+ && iter->var->symtree->n.sym->refs == 1)
iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
gfc_current_locus = where;
/* Match the header of a FORALL statement. */
static match
-match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
+match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
{
gfc_forall_iterator *head, *tail, *new;
gfc_expr *msk;
return MATCH_ERROR;
}
-/* Match the rest of a simple FORALL statement that follows an IF statement.
- */
+/* Match the rest of a simple FORALL statement that follows an
+ IF statement. */
static match
match_simple_forall (void)
/* Match a FORALL statement. */
match
-gfc_match_forall (gfc_statement * st)
+gfc_match_forall (gfc_statement *st)
{
gfc_forall_iterator *head;
gfc_expr *mask;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_FORALL_BLOCK;
-
new_st.op = EXEC_FORALL;
new_st.expr = mask;
new_st.ext.forall_iterator = head;
-
return MATCH_YES;
}
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;
OSDN Git Service
