diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2010-06-15 20:33:58 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2010-06-15 20:33:58 +0200 |
| commit | 94bff63216c58605147ef22357d3bb48eee999ae (patch) | |
| tree | 9b84864e2b7463fd00877080c1437f80e8b9b59e /gcc/fortran/resolve.c | |
| parent | 8e9287111fb40ceacaeb85c30ce66ffb9728ec0f (diff) | |
| download | gcc-94bff63216c58605147ef22357d3bb48eee999ae.zip gcc-94bff63216c58605147ef22357d3bb48eee999ae.tar.gz gcc-94bff63216c58605147ef22357d3bb48eee999ae.tar.bz2 | |
re PR fortran/43388 ([F2008][OOP] ALLOCATE with MOLD=)
2010-06-15 Janus Weil <janus@gcc.gnu.org>
PR fortran/43388
* gfortran.h (gfc_expr): Add new member 'mold'.
* match.c (gfc_match_allocate): Implement the MOLD tag.
* resolve.c (resolve_allocate_expr): Ditto.
* trans-stmt.c (gfc_trans_allocate): Ditto.
2010-06-15 Janus Weil <janus@gcc.gnu.org>
PR fortran/43388
* gfortran.dg/allocate_alloc_opt_8.f90: New.
* gfortran.dg/allocate_alloc_opt_9.f90: New.
* gfortran.dg/allocate_alloc_opt_10.f90: New.
* gfortran.dg/class_allocate_2.f03: Modified an error message.
From-SVN: r160801
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 43 |
1 files changed, 23 insertions, 20 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d5fa370..7e6b75a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6268,7 +6268,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; - gfc_expr *init_e; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -6401,11 +6400,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } } - else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) + + /* Check F08:C629. */ + if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN + && !code->expr3) { 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); + "type-spec or source-expr", sym->name, &e->where); goto failure; } @@ -6416,25 +6418,26 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } - if (!code->expr3) + if (!code->expr3 || code->expr3->mold) { /* Add default initializer for those derived types that need them. */ - if (e->ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&e->ts))) - { - gfc_code *init_st = gfc_get_code (); - init_st->loc = code->loc; - init_st->op = EXEC_INIT_ASSIGN; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->expr2 = init_e; - init_st->next = code->next; - code->next = init_st; - } - else if (e->ts.type == BT_CLASS - && ((code->ext.alloc.ts.type == BT_UNKNOWN - && (init_e = gfc_default_initializer (&CLASS_DATA (e)->ts))) - || (code->ext.alloc.ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) + gfc_expr *init_e = NULL; + gfc_typespec ts; + + if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + else if (code->expr3) + ts = code->expr3->ts; + else + ts = e->ts; + + if (ts.type == BT_DERIVED) + init_e = gfc_default_initializer (&ts); + /* FIXME: Use default init of dynamic type (cf. PR 44541). */ + else if (e->ts.type == BT_CLASS) + init_e = gfc_default_initializer (&ts.u.derived->components->ts); + + if (init_e) { gfc_code *init_st = gfc_get_code (); init_st->loc = code->loc; |