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

gcc/fortran/ChangeLog

+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  Tobias Burnus  <burnus@net-b.de>
 
 	* gfortran.texi (preprocessing): Update URL to COCO.

gcc/fortran/class.c

@@ -319,7 +319,7 @@ gfc_symbol *
 gfc_find_derived_vtab (gfc_symbol *derived)
 {
   gfc_namespace *ns;
-  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
+  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
   char name[2 * GFC_MAX_SYMBOL_LEN + 8];
   
   /* Find the top-level namespace (MODULE or PROGRAM).  */
@@ -408,6 +408,33 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  c->initializer = gfc_get_null_expr (NULL);
 		}
 
+	      /* Add component $def_init.  */
+	      if (gfc_add_component (vtype, "$def_init", &c) == FAILURE)
+		goto cleanup;
+	      c->attr.pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->ts.type = BT_DERIVED;
+	      c->ts.u.derived = derived;
+	      if (derived->attr.abstract)
+		c->initializer = NULL;
+	      else
+		{
+		  /* Construct default initialization variable.  */
+		  sprintf (name, "def_init$%s", derived->name);
+		  gfc_get_symbol (name, ns, &def_init);
+		  def_init->attr.target = 1;
+		  def_init->attr.save = SAVE_EXPLICIT;
+		  def_init->attr.access = ACCESS_PUBLIC;
+		  def_init->attr.flavor = FL_VARIABLE;
+		  gfc_set_sym_referenced (def_init);
+		  def_init->ts.type = BT_DERIVED;
+		  def_init->ts.u.derived = derived;
+		  def_init->value = gfc_default_initializer (&def_init->ts);
+
+		  c->initializer = gfc_lval_expr_from_sym (def_init);
+		}
+
+	      /* Add procedure pointers for type-bound procedures.  */
 	      add_procs_to_declared_vtab (derived, vtype);
 	      vtype->attr.vtype = 1;
 	    }
@@ -427,6 +454,8 @@ cleanup:
       gfc_commit_symbol (vtab);
       if (vtype)
 	gfc_commit_symbol (vtype);
+      if (def_init)
+	gfc_commit_symbol (def_init);
     }
   else
     gfc_undo_symbols ();

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

gcc/fortran/trans-expr.c

@@ -5760,27 +5760,39 @@ gfc_trans_assign (gfc_code * code)
 }
 
 
-/* Special case for initializing a CLASS variable on allocation.
-   A MEMCPY is needed to copy the full data of the dynamic type,
-   which may be different from the declared type.  */
+/* Special case for initializing a polymorphic dummy with INTENT(OUT).
+   A MEMCPY is needed to copy the full data from the default initializer
+   of the dynamic type.  */
 
 tree
 gfc_trans_class_init_assign (gfc_code *code)
 {
   stmtblock_t block;
-  tree tmp, memsz;
-  gfc_se dst,src;
-  
+  tree tmp;
+  gfc_se dst,src,memsz;
+  gfc_expr *lhs,*rhs,*sz;
+
   gfc_start_block (&block);
-  
+
+  lhs = gfc_copy_expr (code->expr1);
+  gfc_add_component_ref (lhs, "$data");
+
+  rhs = gfc_copy_expr (code->expr1);
+  gfc_add_component_ref (rhs, "$vptr");
+  gfc_add_component_ref (rhs, "$def_init");
+
+  sz = gfc_copy_expr (code->expr1);
+  gfc_add_component_ref (sz, "$vptr");
+  gfc_add_component_ref (sz, "$size");
+
   gfc_init_se (&dst, NULL);
   gfc_init_se (&src, NULL);
-  gfc_add_component_ref (code->expr1, "$data");
-  gfc_conv_expr (&dst, code->expr1);
-  gfc_conv_expr (&src, code->expr2);
+  gfc_init_se (&memsz, NULL);
+  gfc_conv_expr (&dst, lhs);
+  gfc_conv_expr (&src, rhs);
+  gfc_conv_expr (&memsz, sz);
   gfc_add_block_to_block (&block, &src.pre);
-  memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
-  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
   gfc_add_expr_to_block (&block, tmp);
   
   return gfc_finish_block (&block);

gcc/fortran/trans-stmt.c

@@ -4399,6 +4399,54 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_free_expr (rhs);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
+      else
+	{
+	  /* Add default initializer for those derived types that need them.  */
+	  gfc_expr *rhs = 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 = expr->ts;
+
+	  if (ts.type == BT_DERIVED)
+	    {
+	      rhs = gfc_default_initializer (&ts);
+	      gfc_resolve_expr (rhs);
+	    }
+	  else if (ts.type == BT_CLASS)
+	    {
+	      rhs = gfc_copy_expr (code->expr3);
+	      gfc_add_component_ref (rhs, "$vptr");
+	      gfc_add_component_ref (rhs, "$def_init");
+	    }
+
+	  if (rhs)
+	    {
+	      gfc_expr *lhs = gfc_expr_to_initialize (expr);
+	      if (al->expr->ts.type == BT_DERIVED)
+		{
+		  tmp = gfc_trans_assignment (lhs, rhs, true, false);
+		  gfc_add_expr_to_block (&block, tmp);
+		}
+	      else if (al->expr->ts.type == BT_CLASS)
+		{
+		  gfc_se dst,src;
+		  gfc_init_se (&dst, NULL);
+		  gfc_init_se (&src, NULL);
+		  gfc_conv_expr (&dst, lhs);
+		  gfc_conv_expr (&src, rhs);
+		  gfc_add_block_to_block (&block, &src.pre);
+		  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+		  gfc_add_expr_to_block (&block, tmp);
+		}
+	      gfc_free_expr (lhs);
+	      gfc_free_expr (rhs);
+	    }
+	}
 
       /* Allocation of CLASS entities.  */
       gfc_free_expr (expr);

gcc/testsuite/ChangeLog

+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.
+
 2010-09-01  Jakub Jelinek  <jakub@redhat.com>
 
 	PR middle-end/45458

gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90

@@ -16,7 +16,7 @@ class(t1),allocatable :: x,y
 type(t2) :: z
 
 
-!!! first example (works)
+!!! first example (static)
 
 z%j = 5
 allocate(x,MOLD=z)
@@ -25,22 +25,22 @@ select type (x)
 type is (t2)
   print *,x%j
   if (x%j/=4) call abort
+  x%j = 5
 class default
   call abort()
 end select
 
 
-!!! second example (fails)
-!!! FIXME: uncomment once implemented (cf. PR 44541)
+!!! second example (dynamic, PR 44541)
 
-! allocate(y,MOLD=x)
-! 
-! select type (y)
-! type is (t2)
-!   print *,y%j
-!   if (y%j/=4) call abort
-! class default
-!   call abort()
-! end select
+allocate(y,MOLD=x)
+
+select type (y)
+type is (t2)
+  print *,y%j
+  if (y%j/=4) call abort
+class default
+  call abort()
+end select
 
 end

gcc/testsuite/gfortran.dg/class_dummy_1.f03

+! { dg-do run }
+!
+! PR 44541: [OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+  implicit none
+
+  type t
+    integer :: a = 1
+  end type t
+
+  type, extends(t) :: t2
+    integer :: b = 3
+  end type t2
+
+  type(t2) :: y
+
+  y%a = 44
+  y%b = 55
+  call intent_out (y)
+  if (y%a/=1 .or. y%b/=3) call abort()
+
+  y%a = 66
+  y%b = 77
+  call intent_out_unused (y)
+  if (y%a/=1 .or. y%b/=3) call abort()
+
+contains
+
+  subroutine intent_out(x)
+    class(t), intent(out) :: x
+    select type (x)
+      type is (t2)
+      if (x%a/=1 .or. x%b/=3) call abort()
+    end select
+  end subroutine
+
+   subroutine intent_out_unused(x)
+     class(t), intent(out) :: x
+   end subroutine
+
+end