re PR fortran/44541 ([OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD)

2010-09-01  Janus Weil  <janus@gcc.gnu.org>

	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  <janus@gcc.gnu.org>

	PR fortran/44541
	* gfortran.dg/allocate_alloc_opt_10.f90: Extended.
	* gfortran.dg/class_dummy_1.f03: New.

From-SVN: r163744

1 files changed, 12 insertions, 35 deletions

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))