/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
+ Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
/* 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;
}
- gfc_error ("Statement label at %C is out of range");
+ if (i == 0)
+ {
+ gfc_error ("Statement label at %C is zero");
+ goto cleanup;
+ }
+
+ *label = gfc_get_st_label (i);
+ return MATCH_YES;
+
+cleanup:
+
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
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 (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;
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);
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;
- 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)
{
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;
gfc_syntax_error (ST_NULLIFY);
cleanup:
- gfc_free_statements (tail);
+ gfc_free_statements (new_st.next);
return MATCH_ERROR;
}
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)
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",
+ sym->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')
{
t = &gfc_current_ns->blank_common;
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,
group_name->name, NULL) == FAILURE)
&& gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
goto error;
+ /* 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;
match m;
gfc_common_head *common_head = NULL;
bool common_flag;
+ int cnt;
tail = NULL;
set = eq;
common_flag = FALSE;
+ cnt = 0;
for (;;)
{
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 "
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
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. */
+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;
+
+ break;
+
+ case EXPR_VARIABLE:
+ if (e->symtree && sym->name == e->symtree->n.sym->name)
+ return true;
+ 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
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;
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;
OSDN Git Service
