/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
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"
minit (".gt.", INTRINSIC_GT),
minit (">", INTRINSIC_GT),
minit (".not.", INTRINSIC_NOT),
+ minit ("parens", INTRINSIC_PARENTHESES),
minit (NULL, INTRINSIC_NONE)
};
/* Match a literal integer on the input, setting the value on
MATCH_YES. Literal ints occur in kind-parameters as well as
- old-style character length specifications. */
+ old-style character length specifications. If cnt is non-NULL it
+ will be set to the number of digits. */
match
-gfc_match_small_literal_int (int *value)
+gfc_match_small_literal_int (int *value, int *cnt)
{
locus old_loc;
char c;
- int i;
+ int i, j;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
+ if (cnt)
+ *cnt = 0;
if (!ISDIGIT (c))
{
}
i = c - '0';
+ j = 1;
for (;;)
{
break;
i = 10 * i + c - '0';
+ j++;
if (i > 99999999)
{
gfc_current_locus = old_loc;
*value = i;
+ if (cnt)
+ *cnt = j;
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;
+ int i, cnt;
old_loc = gfc_current_locus;
- m = gfc_match_small_literal_int (&i);
+ m = gfc_match_small_literal_int (&i, &cnt);
if (m != MATCH_YES)
return m;
- if (((i == 0) && allow_zero) || i <= 99999)
+ if (cnt > 5)
{
- *label = gfc_get_st_label (i);
- return MATCH_YES;
+ gfc_error ("Too many digits in statement label at %C");
+ goto cleanup;
+ }
+
+ if (i == 0)
+ {
+ gfc_error ("Statement label at %C is zero");
+ goto cleanup;
}
- gfc_error ("Statement label at %C is out of range");
+ *label = gfc_get_st_label (i);
+ return MATCH_YES;
+
+cleanup:
+
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;
}
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':
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;
case 'l':
case 'n':
case 's':
- (void)va_arg (argp, void **);
+ (void) va_arg (argp, void **);
break;
case 'e':
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;
old_loc = gfc_current_locus;
- lvalue = rvalue = NULL;
+ lvalue = NULL;
m = gfc_match (" %v =", &lvalue);
if (m != MATCH_YES)
- goto cleanup;
+ {
+ gfc_current_locus = old_loc;
+ gfc_free_expr (lvalue);
+ return MATCH_NO;
+ }
- if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ if (lvalue->symtree->n.sym->attr.protected
+ && lvalue->symtree->n.sym->attr.use_assoc)
{
- gfc_error ("Cannot assign to a PARAMETER variable at %C");
- m = MATCH_ERROR;
- goto cleanup;
+ 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)
- goto cleanup;
+ {
+ gfc_current_locus = old_loc;
+ gfc_free_expr (lvalue);
+ gfc_free_expr (rvalue);
+ return m;
+ }
gfc_set_sym_referenced (lvalue->symtree->n.sym);
gfc_check_do_variable (lvalue->symtree);
return MATCH_YES;
-
-cleanup:
- gfc_current_locus = old_loc;
- gfc_free_expr (lvalue);
- gfc_free_expr (rvalue);
- return m;
}
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;
}
+/* 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.
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;
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;
}
gfc_undo_symbols ();
gfc_current_locus = old_loc;
+ /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
+ assignment was found. For MATCH_NO, continue to call the various
+ matchers. */
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
m = gfc_match_pointer_assignment ();
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 ("continue", gfc_match_continue, ST_CONTINUE)
- match ("cycle", gfc_match_cycle, ST_CYCLE)
- match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
- match ("end file", gfc_match_endfile, ST_END_FILE)
- match ("exit", gfc_match_exit, ST_EXIT)
- match ("forall", match_simple_forall, ST_FORALL)
- match ("go to", gfc_match_goto, ST_GOTO)
- match ("inquire", gfc_match_inquire, ST_INQUIRE)
- match ("nullify", gfc_match_nullify, ST_NULLIFY)
- match ("open", gfc_match_open, ST_OPEN)
- match ("pause", gfc_match_pause, ST_NONE)
- match ("print", gfc_match_print, ST_WRITE)
- match ("read", gfc_match_read, ST_READ)
- match ("return", gfc_match_return, ST_RETURN)
- match ("rewind", gfc_match_rewind, ST_REWIND)
- match ("stop", gfc_match_stop, ST_STOP)
- match ("where", match_simple_where, ST_WHERE)
- match ("write", gfc_match_write, ST_WRITE)
+ 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 ("continue", gfc_match_continue, ST_CONTINUE)
+ match ("cycle", gfc_match_cycle, ST_CYCLE)
+ match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
+ match ("end file", gfc_match_endfile, ST_END_FILE)
+ match ("exit", gfc_match_exit, ST_EXIT)
+ 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 ("pause", gfc_match_pause, ST_NONE)
+ match ("print", gfc_match_print, ST_WRITE)
+ match ("read", gfc_match_read, ST_READ)
+ match ("return", gfc_match_return, ST_RETURN)
+ match ("rewind", gfc_match_rewind, ST_REWIND)
+ match ("stop", gfc_match_stop, ST_STOP)
+ match ("where", match_simple_where, ST_WHERE)
+ match ("write", gfc_match_write, ST_WRITE)
+
+ /* The gfc_match_assignment() above may have returned a MATCH_NO
+ where the assignment was to a named constant. Check that
+ special case here. */
+ m = gfc_match_assignment ();
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Cannot assign to a named constant at %C");
+ gfc_free_expr (expr);
+ gfc_undo_symbols ();
+ gfc_current_locus = old_loc;
+ 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;
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;
}
/* 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. */
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);
static match
match_exit_cycle (gfc_statement st, gfc_exec_op op)
{
- gfc_state_data *p;
+ gfc_state_data *p, *o;
gfc_symbol *sym;
match m;
/* Find the loop mentioned specified by the label (or lack of a
label). */
- for (p = gfc_state_stack; p; p = p->previous)
+ for (o = NULL, p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
break;
+ else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
+ o = p;
if (p == NULL)
{
return MATCH_ERROR;
}
+ if (o != NULL)
+ {
+ gfc_error ("%s statement at %C leaving OpenMP structured block",
+ gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
+ else if (st == ST_EXIT
+ && p->previous != NULL
+ && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
+ && (p->previous->head->op == EXEC_OMP_DO
+ || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
+ {
+ gcc_assert (p->previous->head->next != NULL);
+ gcc_assert (p->previous->head->next->op == EXEC_DO
+ || p->previous->head->next->op == EXEC_DO_WHILE);
+ gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
+ return MATCH_ERROR;
+ }
+
/* Save the first statement in the loop - needed by the backend. */
new_st.ext.whichloop = p->head;
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);
}
int stop_code;
gfc_expr *e;
match m;
+ int cnt;
- stop_code = 0;
+ stop_code = -1;
e = NULL;
if (gfc_match_eos () != MATCH_YES)
{
- m = gfc_match_small_literal_int (&stop_code);
+ m = gfc_match_small_literal_int (&stop_code, &cnt);
if (m == MATCH_ERROR)
- goto cleanup;
+ goto cleanup;
- if (m == MATCH_YES && stop_code > 99999)
- {
- gfc_error ("STOP code out of range at %C");
- goto cleanup;
- }
+ if (m == MATCH_YES && cnt > 5)
+ {
+ gfc_error ("Too many digits in STOP code at %C");
+ goto cleanup;
+ }
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;
- 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;
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;
do
{
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
/* 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");
goto cleanup;
}
+ if (tail->expr->ts.type == BT_DERIVED)
+ tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
+
if (gfc_match_char (',') != MATCH_YES)
break;
{
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;
}
gfc_syntax_error (ST_NULLIFY);
cleanup:
- gfc_free_statements (tail);
+ gfc_free_statements (new_st.next);
return MATCH_ERROR;
}
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;
}
gfc_expr *e;
match m;
gfc_compile_state s;
-
- 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;
+ 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)
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
match
gfc_match_common (void)
{
- gfc_symbol *sym, **head, *tail, *old_blank_common;
- char name[GFC_MAX_SYMBOL_LEN+1];
+ 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;
+ gfc_gsymbol *gsym;
old_blank_common = gfc_current_ns->blank_common.head;
if (old_blank_common)
as = NULL;
- if (gfc_match_eos () == MATCH_YES)
- goto syntax;
-
for (;;)
{
m = match_common_name (name);
if (m == MATCH_ERROR)
goto cleanup;
+ 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);
+ goto cleanup;
+ }
+
+ if (gsym->type == GSYM_UNKNOWN)
+ {
+ gsym->type = GSYM_COMMON;
+ gsym->where = gfc_current_locus;
+ gsym->defined = 1;
+ }
+
+ gsym->used = 1;
+
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;
}
/* Grab the list of symbols. */
- if (gfc_match_eos () == MATCH_YES)
- goto done;
-
for (;;)
{
m = gfc_match_symbol (&sym, 0);
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. */
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 (gfc_add_dimension (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
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;
}
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_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;
/* 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;
}
+ if (group_name->attr.flavor == FL_NAMELIST
+ && group_name->attr.use_assoc
+ && 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)
+ return MATCH_ERROR;
+
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. */
+ /* Use gfc_error_check here, rather than goto error, so that this
+ 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_check ();
+ }
+
+ if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
+ && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
+ "namelist '%s' at %C is an extension.",
+ sym->name, group_name->name) == FAILURE)
+ gfc_error_check ();
nl = gfc_get_namelist ();
nl->sym = sym;
+ sym->refs++;
if (group_name->namelist == NULL)
group_name->namelist = group_name->namelist_tail = nl;
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;
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);
}
{
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)
{
- 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)
+ 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)
}
+/* 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.
+ 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 *e, gfc_symbol *sym)
+{
+ 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;
+
+ /* Check the name before testing for nested recursion! */
+ if (sym->name == e->symtree->n.sym->name)
+ 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))
+ return true;
+
+ if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+ gfc_set_default_type (e->symtree->n.sym, 0, NULL);
+
+ break;
+
+ case EXPR_VARIABLE:
+ if (e->symtree && sym->name == e->symtree->n.sym->name)
+ return true;
+
+ if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+ 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;
+
+ break;
+
+ default:
+ break;
+ }
+ }
+ }
+ return false;
+}
+
+
/* 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. */
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)
m = gfc_match (" = %e%t", &expr);
if (m == MATCH_NO)
goto undo_error;
+
+ gfc_free_error (&old_error);
if (m == MATCH_ERROR)
return m;
+ if (recursive_stmt_fcn (expr, sym))
+ {
+ gfc_error ("Statement function at %L is recursive", &expr->where);
+ return MATCH_ERROR;
+ }
+
sym->value = expr;
return MATCH_YES;
/* 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);
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
+ /* If the case construct doesn't have a case-construct-name, we
+ should have matched the EOS. */
+ if (!gfc_current_block ())
+ {
+ gfc_error ("Expected the name of the select case construct at %C");
+ return MATCH_ERROR;
+ }
+
gfc_gobble_whitespace ();
m = gfc_match_name (name);
/* 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;
}
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)
goto cleanup;
}
+ /* Mark the iteration variable's symbol as used as a FORALL index. */
+ iter->var->symtree->n.sym->forall_index = true;
+
*result = iter;
return MATCH_YES;
m = MATCH_ERROR;
cleanup:
+ /* 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->symtree->n.sym->attr.flavor = FL_UNKNOWN;
+
gfc_current_locus = where;
gfc_free_forall_iterator (iter);
return m;
/* 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;
match m;
gfc_gobble_whitespace ();
head = tail = NULL;
- *mask = NULL;
+ msk = NULL;
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
m = match_forall_iterator (&new);
if (m == MATCH_ERROR)
goto cleanup;
+
if (m == MATCH_YES)
{
tail->next = new;
/* Have to have a mask expression */
- m = gfc_match_expr (mask);
+ m = gfc_match_expr (&msk);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto syntax;
*phead = head;
+ *mask = msk;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_FORALL);
cleanup:
- gfc_free_expr (*mask);
+ gfc_free_expr (msk);
gfc_free_forall_iterator (head);
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;
}
c = gfc_get_code ();
*c = new_st;
-
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
+ c->loc = gfc_current_locus;
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;
OSDN Git Service
