aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/resolve.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/resolve.c')
-rw-r--r--gcc/fortran/resolve.c127
1 files changed, 86 insertions, 41 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 81d5ed8..4ab9df6 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2034,16 +2034,16 @@ is_scalar_expr_ptr (gfc_expr *expr)
}
else
{
- /* We have constant lower and upper bounds. If the
- difference between is 1, it can be considered a
- scalar. */
- start = (int) mpz_get_si
- (ref->u.ar.as->lower[0]->value.integer);
- end = (int) mpz_get_si
- (ref->u.ar.as->upper[0]->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
+ /* We have constant lower and upper bounds. If the
+ difference between is 1, it can be considered a
+ scalar. */
+ start = (int) mpz_get_si
+ (ref->u.ar.as->lower[0]->value.integer);
+ end = (int) mpz_get_si
+ (ref->u.ar.as->upper[0]->value.integer);
+ if (end - start + 1 != 1)
+ retval = FAILURE;
+ }
}
else
retval = FAILURE;
@@ -5181,8 +5181,8 @@ resolve_deallocate_expr (gfc_expr *e)
if (allocatable == 0 && attr.pointer == 0)
{
bad:
- gfc_error ("Expression in DEALLOCATE statement at %L must be "
- "ALLOCATABLE or a POINTER", &e->where);
+ gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+ &e->where);
}
if (check_intent_in
@@ -5267,11 +5267,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
- if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
- sym = code->expr->symtree->n.sym;
- else
- sym = NULL;
-
/* Make sure the expression is allocatable or a pointer. If it is
pointer, the next-to-last reference must be a pointer. */
@@ -5290,14 +5285,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
pointer = e->symtree->n.sym->attr.pointer;
dimension = e->symtree->n.sym->attr.dimension;
- if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
- {
- gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
- "not be allocated in the same statement at %L",
- sym->name, &e->where);
- return FAILURE;
- }
-
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
if (pointer)
@@ -5328,8 +5315,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (allocatable == 0 && pointer == 0)
{
- gfc_error ("Expression in ALLOCATE statement at %L must be "
- "ALLOCATABLE or a POINTER", &e->where);
+ gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+ &e->where);
return FAILURE;
}
@@ -5424,26 +5411,83 @@ check_symbols:
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
- gfc_symbol *s = NULL;
- gfc_alloc *a;
+ gfc_expr *stat, *errmsg, *pe, *qe;
+ gfc_alloc *a, *p, *q;
+
+ stat = code->expr ? code->expr : NULL;
- if (code->expr)
- s = code->expr->symtree->n.sym;
+ errmsg = code->expr2 ? code->expr2 : NULL;
- if (s)
+ /* Check the stat variable. */
+ if (stat)
{
- if (s->attr.intent == INTENT_IN)
- gfc_error ("STAT variable '%s' of %s statement at %C cannot "
- "be INTENT(IN)", s->name, fcn);
+ if (stat->symtree->n.sym->attr.intent == INTENT_IN)
+ gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
+ stat->symtree->n.sym->name, &stat->where);
- if (gfc_pure (NULL) && gfc_impure_variable (s))
- gfc_error ("Illegal STAT variable in %s statement at %C "
- "for a PURE procedure", fcn);
+ if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
+ gfc_error ("Illegal stat-variable at %L for a PURE procedure",
+ &stat->where);
+
+ if (stat->ts.type != BT_INTEGER
+ && !(stat->ref && (stat->ref->type == REF_ARRAY
+ || stat->ref->type == REF_COMPONENT)))
+ gfc_error ("Stat-variable at %L must be a scalar INTEGER "
+ "variable", &stat->where);
+
+ for (p = code->ext.alloc_list; p; p = p->next)
+ if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
+ gfc_error ("Stat-variable at %L shall not be %sd within "
+ "the same %s statement", &stat->where, fcn, fcn);
}
- if (s && code->expr->ts.type != BT_INTEGER)
- gfc_error ("STAT tag in %s statement at %L must be "
- "of type INTEGER", fcn, &code->expr->where);
+ /* Check the errmsg variable. */
+ if (errmsg)
+ {
+ if (!stat)
+ gfc_warning ("ERRMSG at %L is useless without a STAT tag",
+ &errmsg->where);
+
+ if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
+ gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
+ errmsg->symtree->n.sym->name, &errmsg->where);
+
+ if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
+ gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
+ &errmsg->where);
+
+ if (errmsg->ts.type != BT_CHARACTER
+ && !(errmsg->ref
+ && (errmsg->ref->type == REF_ARRAY
+ || errmsg->ref->type == REF_COMPONENT)))
+ gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
+ "variable", &errmsg->where);
+
+ for (p = code->ext.alloc_list; p; p = p->next)
+ if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
+ gfc_error ("Errmsg-variable at %L shall not be %sd within "
+ "the same %s statement", &errmsg->where, fcn, fcn);
+ }
+
+ /* Check that an allocate-object appears only once in the statement.
+ FIXME: Checking derived types is disabled. */
+ for (p = code->ext.alloc_list; p; p = p->next)
+ {
+ pe = p->expr;
+ if ((pe->ref && pe->ref->type != REF_COMPONENT)
+ && (pe->symtree->n.sym->ts.type != BT_DERIVED))
+ {
+ for (q = p->next; q; q = q->next)
+ {
+ qe = q->expr;
+ if ((qe->ref && qe->ref->type != REF_COMPONENT)
+ && (qe->symtree->n.sym->ts.type != BT_DERIVED)
+ && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
+ gfc_error ("Allocate-object at %L also appears at %L",
+ &pe->where, &qe->where);
+ }
+ }
+ }
if (strcmp (fcn, "ALLOCATE") == 0)
{
@@ -5457,6 +5501,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
}
}
+
/************ SELECT CASE resolution subroutines ************/
/* Callback function for our mergesort variant. Determines interval
generated by cgit v1.1 at 2025-05-29 07:52:47 +0000