From 50f308010c3fabfd87f32576b44220469196de1d Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Wed, 1 Sep 2010 22:50:46 +0200 Subject: re PR fortran/44541 ([OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD) 2010-09-01 Janus Weil PR fortran/44541 * class.c (gfc_find_derived_vtab): Add component '$def_init'. * resolve.c (resolve_allocate_expr): Defer handling of default initialization to 'gfc_trans_allocate'. (apply_default_init,resolve_symbol): Handle polymorphic dummies. (resolve_fl_derived): Suppress error messages for vtypes. * trans-stmt.c (gfc_trans_allocate): Handle initialization via polymorphic MOLD expression. * trans-expr.c (gfc_trans_class_init_assign): Now only used for dummy initialization. 2010-09-01 Janus Weil PR fortran/44541 * gfortran.dg/allocate_alloc_opt_10.f90: Extended. * gfortran.dg/class_dummy_1.f03: New. From-SVN: r163744 --- gcc/fortran/resolve.c | 47 ++++++++++++----------------------------------- 1 file changed, 12 insertions(+), 35 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 45696ab..b6980a6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6710,37 +6710,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) sym->name, &e->where); goto failure; } - - if (!code->expr3 || code->expr3->mold) - { - /* Add default initializer for those derived types that need them. */ - 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; - 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; - } - } if (e->ts.type == BT_CLASS) { @@ -9503,7 +9472,7 @@ apply_default_init (gfc_symbol *sym) if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) init = gfc_default_initializer (&sym->ts); - if (init == NULL) + if (init == NULL && sym->ts.type != BT_CLASS) return; build_init_assign (sym, init); @@ -11429,7 +11398,7 @@ resolve_fl_derived (gfc_symbol *sym) } /* Check type-spec if this is not the parent-type component. */ - if ((!sym->attr.extension || c != sym->components) + if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE) return FAILURE; @@ -11488,8 +11457,8 @@ resolve_fl_derived (gfc_symbol *sym) } } - if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer - && c->ts.u.derived->components == NULL + if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype + && c->attr.pointer && c->ts.u.derived->components == NULL && !c->ts.u.derived->attr.zero_comp) { gfc_error ("The pointer component '%s' of '%s' at %L is a type " @@ -12194,6 +12163,14 @@ resolve_symbol (gfc_symbol *sym) apply_default_init (sym); } + if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns + && sym->attr.dummy && sym->attr.intent == INTENT_OUT + && !sym->attr.pointer && !sym->attr.allocatable) + { + apply_default_init (sym); + gfc_set_sym_referenced (sym); + } + /* If this symbol has a type-spec, check it. */ if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)) -- cgit v1.1