summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog10
-rw-r--r--gcc/fortran/match.c76
-rw-r--r--gcc/fortran/resolve.c83
3 files changed, 93 insertions, 76 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6a440800fa0..0668a68305c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2009-10-23 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41758
+ * match.c (conformable_arrays): Move to resolve.c.
+ (gfc_match_allocate): Don't resolve SOURCE expr yet, and move some
+ checks to resolve_allocate_expr.
+ * resolve.c (conformable_arrays): Moved here from match.c.
+ (resolve_allocate_expr): Moved some checks here from gfc_match_allocate.
+ (resolve_code): Resolve SOURCE tag for ALLOCATE expressions.
+
2009-10-22 Janus Weil <janus@gcc.gnu.org>
PR fortran/41781
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0a418c8a449..24e292bd4d6 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2388,58 +2388,6 @@ char_selector:
}
-/* Used in gfc_match_allocate to check that a allocation-object and
- a source-expr are conformable. This does not catch all possible
- cases; in particular a runtime checking is needed. */
-
-static gfc_try
-conformable_arrays (gfc_expr *e1, gfc_expr *e2)
-{
- /* First compare rank. */
- if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
- {
- gfc_error ("Source-expr at %L must be scalar or have the "
- "same rank as the allocate-object at %L",
- &e1->where, &e2->where);
- return FAILURE;
- }
-
- if (e1->shape)
- {
- int i;
- mpz_t s;
-
- mpz_init (s);
-
- for (i = 0; i < e1->rank; i++)
- {
- if (e2->ref->u.ar.end[i])
- {
- mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
- mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
- mpz_add_ui (s, s, 1);
- }
- else
- {
- mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
- }
-
- if (mpz_cmp (e1->shape[i], s) != 0)
- {
- gfc_error ("Source-expr at %L and allocate-object at %L must "
- "have the same shape", &e1->where, &e2->where);
- mpz_clear (s);
- return FAILURE;
- }
- }
-
- mpz_clear (s);
- }
-
- return SUCCESS;
-}
-
-
/* Match an ALLOCATE statement. */
match
@@ -2620,7 +2568,7 @@ alloc_opt_list:
goto cleanup;
}
- /* The next 3 conditionals check C631. */
+ /* The next 2 conditionals check C631. */
if (ts.type != BT_UNKNOWN)
{
gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
@@ -2635,28 +2583,6 @@ alloc_opt_list:
goto cleanup;
}
- gfc_resolve_expr (tmp);
-
- if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
- {
- gfc_error ("Type of entity at %L is type incompatible with "
- "source-expr at %L", &head->expr->where, &tmp->where);
- goto cleanup;
- }
-
- /* Check C633. */
- if (tmp->ts.kind != head->expr->ts.kind)
- {
- gfc_error ("The allocate-object at %L and the source-expr at %L "
- "shall have the same kind type parameter",
- &head->expr->where, &tmp->where);
- goto cleanup;
- }
-
- /* Check C632 and restriction following Note 6.18. */
- if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
- goto cleanup;
-
source = tmp;
saw_source = true;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4c10a0cc1d6..b17e8fef182 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5958,6 +5958,58 @@ gfc_expr_to_initialize (gfc_expr *e)
}
+/* Used in resolve_allocate_expr to check that a allocation-object and
+ a source-expr are conformable. This does not catch all possible
+ cases; in particular a runtime checking is needed. */
+
+static gfc_try
+conformable_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+ /* First compare rank. */
+ if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+ {
+ gfc_error ("Source-expr at %L must be scalar or have the "
+ "same rank as the allocate-object at %L",
+ &e1->where, &e2->where);
+ return FAILURE;
+ }
+
+ if (e1->shape)
+ {
+ int i;
+ mpz_t s;
+
+ mpz_init (s);
+
+ for (i = 0; i < e1->rank; i++)
+ {
+ if (e2->ref->u.ar.end[i])
+ {
+ mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
+ mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
+ mpz_add_ui (s, s, 1);
+ }
+ else
+ {
+ mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+ }
+
+ if (mpz_cmp (e1->shape[i], s) != 0)
+ {
+ gfc_error ("Source-expr at %L and allocate-object at %L must "
+ "have the same shape", &e1->where, &e2->where);
+ mpz_clear (s);
+ return FAILURE;
+ }
+ }
+
+ mpz_clear (s);
+ }
+
+ return SUCCESS;
+}
+
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
@@ -6057,7 +6109,32 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
return FAILURE;
}
- if (is_abstract && !code->expr3 && code->ext.alloc.ts.type == BT_UNKNOWN)
+ /* Some checks for the SOURCE tag. */
+ if (code->expr3)
+ {
+ /* Check F03:C631. */
+ if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
+ {
+ gfc_error ("Type of entity at %L is type incompatible with "
+ "source-expr at %L", &e->where, &code->expr3->where);
+ return FAILURE;
+ }
+
+ /* Check F03:C632 and restriction following Note 6.18. */
+ if (code->expr3->rank > 0
+ && conformable_arrays (code->expr3, e) == FAILURE)
+ return FAILURE;
+
+ /* Check F03:C633. */
+ if (code->expr3->ts.kind != e->ts.kind)
+ {
+ gfc_error ("The allocate-object at %L and the source-expr at %L "
+ "shall have the same kind type parameter",
+ &e->where, &code->expr3->where);
+ return FAILURE;
+ }
+ }
+ else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
{
gcc_assert (e->ts.type == BT_CLASS);
gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
@@ -7734,6 +7811,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
+ if (code->op == EXEC_ALLOCATE
+ && gfc_resolve_expr (code->expr3) == FAILURE)
+ t = FAILURE;
+
switch (code->op)
{
case EXEC_NOP:
View Lorry Controller Status