Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 153446) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -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,8 +6109,33 @@ 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 " "type-spec or SOURCE=", sym->name, &e->where); @@ -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: Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (Revision 153445) +++ gcc/fortran/match.c (Arbeitskopie) @@ -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;