Re: [RFC] Polymorphic deep copy (aka PR46174)

Re: [RFC] Polymorphic deep copy (aka PR46174)

[Janus Weil]

[-- Attachment #1: Type: text/plain, Size: 1606 bytes --]

>> Also I have weeded out a couple of regressions and am left with only a
>> single one: class_defined_operator_1.f03 aborts at run-time. It has
>> several abort()'s and fails already at the first one, where the result
>> is now -42 instead of +42.
>>
>> The reason for this is that the "ALLOCATE with SOURCE" statement now
>> makes use of the defined assignment operator for copying the source,
>> which introduces the additional minus sign. I am not completely sure
>> if this behavior is ok and was not able to pinpoint it in the standard
>> so far. Can anyone tell me if ALLOCATE w/ SOURCE is actually supposed
>> to use the defined OPERATOR(=) or not?
>
> "On successful allocation, if allocate-object and source-expr have the same
> rank the value of allocate-object becomes that of source-expr, otherwise the
> value of each element of allocate-object becomes that of source-expr."
> (F2008, 6.7.1.2)
>
> Thus, ALLOCATE with SOURCE= acts in the same way as an intrinsic assignment
> or a deep-copying memcpy would do. The (unmodified!) test case also succeeds
> with crayftn.

Well, ok.

I think the problem was the following: The assigment in copy$foo, which is just

dst = src      !!! both 'dst' and 'src' being TYPE(foo)

was falsely transformed into a call to the typebound assignment
operator, although no polymorphic pass-object was present. I fixed
this by modifying gfc_extend_assign in interface.c.

Regtesting now. Ok for trunk if successful? (with a ChangeLog and test
case of course)

Btw, I also verified that the patch fixes Salvatore's original test
case in PR 45451.

Cheers,
Janus

[-- Attachment #2: pr46174_copy_v2.diff --]
[-- Type: application/octet-stream, Size: 10132 bytes --]

Index: gcc/testsuite/gfortran.dg/class_19.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_19.f03	(revision 166336)
+++ gcc/testsuite/gfortran.dg/class_19.f03	(working copy)
@@ -39,7 +39,7 @@ program main
 
 end program main
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 
 ! { dg-final { cleanup-modules "foo_mod" } }
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 166336)
+++ gcc/fortran/interface.c	(working copy)
@@ -3143,8 +3143,19 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 
   /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
 
-  if (sym == NULL)
+  if (sym)
     {
+      /* Replace the assignment with the call.  */
+      c->op = EXEC_ASSIGN_CALL;
+      c->symtree = gfc_find_sym_in_symtree (sym);
+      c->expr1 = NULL;
+      c->expr2 = NULL;
+      c->ext.actual = actual;
+      return SUCCESS;
+    }
+  
+  if (lhs->ts.type == BT_CLASS)
+    {
       gfc_typebound_proc* tbo;
       gfc_expr* tb_base;
 
@@ -3167,20 +3178,11 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 
 	  return SUCCESS;
 	}
-
-      gfc_free (actual->next);
-      gfc_free (actual);
-      return FAILURE;
     }
 
-  /* Replace the assignment with the call.  */
-  c->op = EXEC_ASSIGN_CALL;
-  c->symtree = gfc_find_sym_in_symtree (sym);
-  c->expr1 = NULL;
-  c->expr2 = NULL;
-  c->ext.actual = actual;
-
-  return SUCCESS;
+  gfc_free (actual->next);
+  gfc_free (actual);
+  return FAILURE;
 }
 
 
Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(revision 166336)
+++ gcc/fortran/class.c	(working copy)
@@ -39,9 +39,10 @@ along with GCC; see the file COPYING3.  If not see
     * $hash: A hash value serving as a unique identifier for this type.
     * $size: The size in bytes of the derived type.
     * $extends: A pointer to the vtable entry of the parent derived type.
-   In addition to these fields, each vtable entry contains additional procedure
-   pointer components, which contain pointers to the procedures which are bound
-   to the type's "methods" (type-bound procedures).  */
+    * $def_init: A pointer to a default initialized variable of this type.
+    * $copy: A procedure pointer to a copying procedure.
+   After these follow procedure pointer components for the specific
+   type-bound procedures.  */
 
 
 #include "config.h"
@@ -307,19 +308,14 @@ add_procs_to_declared_vtab (gfc_symbol *derived, g
 }
 
 
-/* Find the symbol for a derived type's vtab.
-   A vtab has the following fields:
-    * $hash	a hash value used to identify the derived type
-    * $size	the size in bytes of the derived type
-    * $extends	a pointer to the vtable of the parent derived type
-   After these follow procedure pointer components for the
-   specific type-bound procedures.  */
+/* Find (or generate) the symbol for a derived type's vtab.  */
 
 gfc_symbol *
 gfc_find_derived_vtab (gfc_symbol *derived)
 {
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
+  gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
   char name[2 * GFC_MAX_SYMBOL_LEN + 8];
   
   /* Find the top-level namespace (MODULE or PROGRAM).  */
@@ -334,9 +330,15 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   if (ns)
     {
       sprintf (name, "vtab$%s", derived->name);
-      gfc_find_symbol (name, ns, 0, &vtab);
 
+      /* Look for the vtab symbol in various namespaces.  */
+      gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
       if (vtab == NULL)
+	gfc_find_symbol (name, ns, 0, &vtab);
+      if (vtab == NULL)
+	gfc_find_symbol (name, derived->ns, 0, &vtab);
+
+      if (vtab == NULL)
 	{
 	  gfc_get_symbol (name, ns, &vtab);
 	  vtab->ts.type = BT_DERIVED;
@@ -361,6 +363,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 				  NULL, &gfc_current_locus) == FAILURE)
 		goto cleanup;
 	      vtype->attr.access = ACCESS_PUBLIC;
+	      vtype->attr.vtype = 1;
 	      gfc_set_sym_referenced (vtype);
 
 	      /* Add component '$hash'.  */
@@ -408,6 +411,14 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  c->initializer = gfc_get_null_expr (NULL);
 		}
 
+	      if (derived->components == NULL && !derived->attr.zero_comp)
+		{
+		  /* At this point an error must have occurred.
+		     Prevent further errors on the vtype components.  */
+		  found_sym = vtab;
+		  goto have_vtype;
+		}
+
 	      /* Add component $def_init.  */
 	      if (gfc_add_component (vtype, "$def_init", &c) == FAILURE)
 		goto cleanup;
@@ -416,7 +427,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->ts.type = BT_DERIVED;
 	      c->ts.u.derived = derived;
 	      if (derived->attr.abstract)
-		c->initializer = NULL;
+		c->initializer = gfc_get_null_expr (NULL);
 	      else
 		{
 		  /* Construct default initialization variable.  */
@@ -434,11 +445,60 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  c->initializer = gfc_lval_expr_from_sym (def_init);
 		}
 
+	      /* Add component $copy.  */
+	      if (gfc_add_component (vtype, "$copy", &c) == FAILURE)
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+	      if (derived->attr.abstract)
+		c->initializer = gfc_get_null_expr (NULL);
+	      else
+		{
+		  /* Set up namespace.  */
+		  gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
+		  sub_ns->sibling = ns->contained;
+		  ns->contained = sub_ns;
+		  /* Set up procedure symbol.  */
+		  sprintf (name, "copy$%s", derived->name);
+		  gfc_get_symbol (name, sub_ns, &copy);
+		  sub_ns->proc_name = copy;
+		  copy->attr.flavor = FL_PROCEDURE;
+		  copy->attr.if_source = IFSRC_DECL;
+		  gfc_set_sym_referenced (copy);
+		  /* Set up formal arguments.  */
+		  gfc_get_symbol ("src", sub_ns, &src);
+		  src->ts.type = BT_DERIVED;
+		  src->ts.u.derived = derived;
+		  src->attr.flavor = FL_VARIABLE;
+		  src->attr.dummy = 1;
+		  gfc_set_sym_referenced (src);
+		  copy->formal = gfc_get_formal_arglist ();
+		  copy->formal->sym = src;
+		  gfc_get_symbol ("dst", sub_ns, &dst);
+		  dst->ts.type = BT_DERIVED;
+		  dst->ts.u.derived = derived;
+		  dst->attr.flavor = FL_VARIABLE;
+		  dst->attr.dummy = 1;
+		  gfc_set_sym_referenced (dst);
+		  copy->formal->next = gfc_get_formal_arglist ();
+		  copy->formal->next->sym = dst;
+		  /* Set up code.  */
+		  sub_ns->code = gfc_get_code ();
+		  sub_ns->code->op = EXEC_ASSIGN;
+		  sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
+		  sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
+		  /* Set initializer.  */
+		  c->initializer = gfc_lval_expr_from_sym (copy);
+		  c->ts.interface = copy;
+		}
+
 	      /* Add procedure pointers for type-bound procedures.  */
 	      add_procs_to_declared_vtab (derived, vtype);
-	      vtype->attr.vtype = 1;
 	    }
 
+have_vtype:
 	  vtab->ts.u.derived = vtype;
 	  vtab->value = gfc_default_initializer (&vtab->ts);
 	}
@@ -456,6 +516,12 @@ cleanup:
 	gfc_commit_symbol (vtype);
       if (def_init)
 	gfc_commit_symbol (def_init);
+      if (copy)
+	gfc_commit_symbol (copy);
+      if (src)
+	gfc_commit_symbol (src);
+      if (dst)
+	gfc_commit_symbol (dst);
     }
   else
     gfc_undo_symbols ();
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 166336)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -4487,21 +4487,33 @@ gfc_trans_allocate (gfc_code * code)
 	  /* Initialization via SOURCE block
 	     (or static default initializer).  */
 	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
-	  if (al->expr->ts.type == BT_CLASS && rhs->expr_type == EXPR_VARIABLE
-	      && rhs->ts.type != BT_CLASS)
-	    tmp = gfc_trans_assignment (expr, rhs, false, false);
-	  else if (al->expr->ts.type == BT_CLASS)
+	  if (al->expr->ts.type == BT_CLASS)
 	    {
-	      /* TODO: One needs to do a deep-copy for BT_CLASS; cf. PR 46174.  */
-	      gfc_se dst,src;
+	      gfc_se call;
+	      gfc_actual_arglist *actual;
+	      gfc_expr *ppc;
+	      gfc_init_se (&call, NULL);
+	      /* Do a polymorphic deep copy.  */
+	      actual = gfc_get_actual_arglist ();
+	      actual->expr = gfc_copy_expr (rhs);
 	      if (rhs->ts.type == BT_CLASS)
-		gfc_add_component_ref (rhs, "$data");
-	      gfc_init_se (&dst, NULL);
-	      gfc_init_se (&src, NULL);
-	      gfc_conv_expr (&dst, expr);
-	      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_component_ref (actual->expr, "$data");
+	      actual->next = gfc_get_actual_arglist ();
+	      actual->next->expr = gfc_copy_expr (al->expr);
+	      gfc_add_component_ref (actual->next->expr, "$data");
+	      if (rhs->ts.type == BT_CLASS)
+		{
+		  ppc = gfc_copy_expr (rhs);
+		  gfc_add_component_ref (ppc, "$vptr");
+		}
+	      else
+		ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived));
+	      gfc_add_component_ref (ppc, "$copy");
+	      gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual,
+					ppc, NULL);
+	      gfc_add_expr_to_block (&call.pre, call.expr);
+	      gfc_add_block_to_block (&call.pre, &call.post);
+	      tmp = gfc_finish_block (&call.pre);
 	    }
 	  else
 	    tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 166336)
+++ gcc/fortran/expr.c	(working copy)
@@ -3457,6 +3457,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
       return FAILURE;
     }
 
+  if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
+    /* Make sure the vtab is present.  */
+    gfc_find_derived_vtab (rvalue->ts.u.derived);
+
   /* Check rank remapping.  */
   if (rank_remap)
     {

Re: [RFC] Polymorphic deep copy (aka PR46174)

[Tobias Burnus]

On 11/05/2010 10:56 AM, Janus Weil wrote:
> I think the problem was the following: The assigment in copy$foo, which is just
>    dst = src      !!! both 'dst' and 'src' being TYPE(foo)
> was falsely transformed into a call to the typebound assignment
> operator, although no polymorphic pass-object was present. I fixed
> this by modifying gfc_extend_assign in interface.c.

I am not 100% sure about the code in gfc_extend_assign. In particular, I 
wonder whether

   if (lhs->ts.type == BT_CLASS)
     {

should not also have "|| lhs->ts.type == BT_TYPE". Though, that probably 
would just undo what you did in the patch.

I think the following program is valid and now rejected with your patch:

------------------------------------
module m
type t
   integer :: ij
contains
   procedure :: my_assign
   generic :: assignment(=) => my_assign
end type t
contains
   SUBROUTINE my_assign (dest, from)
     CLASS(t), INTENT(INOUT) :: dest
     integer, INTENT(IN) :: from
     dest%ij = -from
   END SUBROUTINE
end module m

use m
type(t) :: x

x = 4
print *, x%ij
end
------------------------------------

Tobias

Re: [RFC] Polymorphic deep copy (aka PR46174)

[Janus Weil]

[-- Attachment #1: Type: text/plain, Size: 1715 bytes --]

>> I think the problem was the following: The assigment in copy$foo, which is
>> just
>>   dst = src      !!! both 'dst' and 'src' being TYPE(foo)
>> was falsely transformed into a call to the typebound assignment
>> operator, although no polymorphic pass-object was present. I fixed
>> this by modifying gfc_extend_assign in interface.c.
>
> I am not 100% sure about the code in gfc_extend_assign. In particular, I
> wonder whether
>
>  if (lhs->ts.type == BT_CLASS)
>    {
>
> should not also have "|| lhs->ts.type == BT_TYPE". Though, that probably
> would just undo what you did in the patch.
>
> I think the following program is valid and now rejected with your patch:

Of course you're right. I was on the wrong track here.

So I removed this piece again and instead marked the namespace of
'copy$...' as resolved, which prevents the intrinsic assign from being
replaced during resolution.

The attached new version of the patch finally is free of regressions
(on x86_64-unknown-linux-gnu). Ok for trunk?

Cheers,
Janus


2010-11-05  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46174
	* class.c (gfc_find_derived_vtab): Improved search for existing vtab.
	Add component '$copy' to vtype symbol for polymorphic deep copying.
	* expr.c (gfc_check_pointer_assign): Make sure the vtab is generated
	during resolution stage.
	* resolve.c (resolve_codes): Don't resolve code if namespace is already
	resolved.
	* trans-stmt.c (gfc_trans_allocate): Call '$copy' procedure for
	polymorphic ALLOCATE statements with SOURCE.

2010-11-05  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46174
	* gfortran.dg/class_19.f03: Modified.
	* gfortran.dg/class_allocate_6.f03: New.

[-- Attachment #2: pr46174_copy_v3.diff --]
[-- Type: application/octet-stream, Size: 9367 bytes --]

Index: gcc/testsuite/gfortran.dg/class_19.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_19.f03	(revision 166357)
+++ gcc/testsuite/gfortran.dg/class_19.f03	(working copy)
@@ -39,7 +39,7 @@ program main
 
 end program main
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 
 ! { dg-final { cleanup-modules "foo_mod" } }
Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(revision 166357)
+++ gcc/fortran/class.c	(working copy)
@@ -39,9 +39,10 @@ along with GCC; see the file COPYING3.  If not see
     * $hash: A hash value serving as a unique identifier for this type.
     * $size: The size in bytes of the derived type.
     * $extends: A pointer to the vtable entry of the parent derived type.
-   In addition to these fields, each vtable entry contains additional procedure
-   pointer components, which contain pointers to the procedures which are bound
-   to the type's "methods" (type-bound procedures).  */
+    * $def_init: A pointer to a default initialized variable of this type.
+    * $copy: A procedure pointer to a copying procedure.
+   After these follow procedure pointer components for the specific
+   type-bound procedures.  */
 
 
 #include "config.h"
@@ -307,19 +308,14 @@ add_procs_to_declared_vtab (gfc_symbol *derived, g
 }
 
 
-/* Find the symbol for a derived type's vtab.
-   A vtab has the following fields:
-    * $hash	a hash value used to identify the derived type
-    * $size	the size in bytes of the derived type
-    * $extends	a pointer to the vtable of the parent derived type
-   After these follow procedure pointer components for the
-   specific type-bound procedures.  */
+/* Find (or generate) the symbol for a derived type's vtab.  */
 
 gfc_symbol *
 gfc_find_derived_vtab (gfc_symbol *derived)
 {
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
+  gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
   char name[2 * GFC_MAX_SYMBOL_LEN + 8];
   
   /* Find the top-level namespace (MODULE or PROGRAM).  */
@@ -334,9 +330,15 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   if (ns)
     {
       sprintf (name, "vtab$%s", derived->name);
-      gfc_find_symbol (name, ns, 0, &vtab);
 
+      /* Look for the vtab symbol in various namespaces.  */
+      gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
       if (vtab == NULL)
+	gfc_find_symbol (name, ns, 0, &vtab);
+      if (vtab == NULL)
+	gfc_find_symbol (name, derived->ns, 0, &vtab);
+
+      if (vtab == NULL)
 	{
 	  gfc_get_symbol (name, ns, &vtab);
 	  vtab->ts.type = BT_DERIVED;
@@ -361,6 +363,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 				  NULL, &gfc_current_locus) == FAILURE)
 		goto cleanup;
 	      vtype->attr.access = ACCESS_PUBLIC;
+	      vtype->attr.vtype = 1;
 	      gfc_set_sym_referenced (vtype);
 
 	      /* Add component '$hash'.  */
@@ -408,6 +411,14 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  c->initializer = gfc_get_null_expr (NULL);
 		}
 
+	      if (derived->components == NULL && !derived->attr.zero_comp)
+		{
+		  /* At this point an error must have occurred.
+		     Prevent further errors on the vtype components.  */
+		  found_sym = vtab;
+		  goto have_vtype;
+		}
+
 	      /* Add component $def_init.  */
 	      if (gfc_add_component (vtype, "$def_init", &c) == FAILURE)
 		goto cleanup;
@@ -416,7 +427,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->ts.type = BT_DERIVED;
 	      c->ts.u.derived = derived;
 	      if (derived->attr.abstract)
-		c->initializer = NULL;
+		c->initializer = gfc_get_null_expr (NULL);
 	      else
 		{
 		  /* Construct default initialization variable.  */
@@ -434,11 +445,61 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  c->initializer = gfc_lval_expr_from_sym (def_init);
 		}
 
+	      /* Add component $copy.  */
+	      if (gfc_add_component (vtype, "$copy", &c) == FAILURE)
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+	      if (derived->attr.abstract)
+		c->initializer = gfc_get_null_expr (NULL);
+	      else
+		{
+		  /* Set up namespace.  */
+		  gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
+		  sub_ns->sibling = ns->contained;
+		  ns->contained = sub_ns;
+		  sub_ns->resolved = 1;
+		  /* Set up procedure symbol.  */
+		  sprintf (name, "copy$%s", derived->name);
+		  gfc_get_symbol (name, sub_ns, &copy);
+		  sub_ns->proc_name = copy;
+		  copy->attr.flavor = FL_PROCEDURE;
+		  copy->attr.if_source = IFSRC_DECL;
+		  gfc_set_sym_referenced (copy);
+		  /* Set up formal arguments.  */
+		  gfc_get_symbol ("src", sub_ns, &src);
+		  src->ts.type = BT_DERIVED;
+		  src->ts.u.derived = derived;
+		  src->attr.flavor = FL_VARIABLE;
+		  src->attr.dummy = 1;
+		  gfc_set_sym_referenced (src);
+		  copy->formal = gfc_get_formal_arglist ();
+		  copy->formal->sym = src;
+		  gfc_get_symbol ("dst", sub_ns, &dst);
+		  dst->ts.type = BT_DERIVED;
+		  dst->ts.u.derived = derived;
+		  dst->attr.flavor = FL_VARIABLE;
+		  dst->attr.dummy = 1;
+		  gfc_set_sym_referenced (dst);
+		  copy->formal->next = gfc_get_formal_arglist ();
+		  copy->formal->next->sym = dst;
+		  /* Set up code.  */
+		  sub_ns->code = gfc_get_code ();
+		  sub_ns->code->op = EXEC_ASSIGN;
+		  sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
+		  sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
+		  /* Set initializer.  */
+		  c->initializer = gfc_lval_expr_from_sym (copy);
+		  c->ts.interface = copy;
+		}
+
 	      /* Add procedure pointers for type-bound procedures.  */
 	      add_procs_to_declared_vtab (derived, vtype);
-	      vtype->attr.vtype = 1;
 	    }
 
+have_vtype:
 	  vtab->ts.u.derived = vtype;
 	  vtab->value = gfc_default_initializer (&vtab->ts);
 	}
@@ -456,6 +517,12 @@ cleanup:
 	gfc_commit_symbol (vtype);
       if (def_init)
 	gfc_commit_symbol (def_init);
+      if (copy)
+	gfc_commit_symbol (copy);
+      if (src)
+	gfc_commit_symbol (src);
+      if (dst)
+	gfc_commit_symbol (dst);
     }
   else
     gfc_undo_symbols ();
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 166357)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -4487,21 +4487,33 @@ gfc_trans_allocate (gfc_code * code)
 	  /* Initialization via SOURCE block
 	     (or static default initializer).  */
 	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
-	  if (al->expr->ts.type == BT_CLASS && rhs->expr_type == EXPR_VARIABLE
-	      && rhs->ts.type != BT_CLASS)
-	    tmp = gfc_trans_assignment (expr, rhs, false, false);
-	  else if (al->expr->ts.type == BT_CLASS)
+	  if (al->expr->ts.type == BT_CLASS)
 	    {
-	      /* TODO: One needs to do a deep-copy for BT_CLASS; cf. PR 46174.  */
-	      gfc_se dst,src;
+	      gfc_se call;
+	      gfc_actual_arglist *actual;
+	      gfc_expr *ppc;
+	      gfc_init_se (&call, NULL);
+	      /* Do a polymorphic deep copy.  */
+	      actual = gfc_get_actual_arglist ();
+	      actual->expr = gfc_copy_expr (rhs);
 	      if (rhs->ts.type == BT_CLASS)
-		gfc_add_component_ref (rhs, "$data");
-	      gfc_init_se (&dst, NULL);
-	      gfc_init_se (&src, NULL);
-	      gfc_conv_expr (&dst, expr);
-	      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_component_ref (actual->expr, "$data");
+	      actual->next = gfc_get_actual_arglist ();
+	      actual->next->expr = gfc_copy_expr (al->expr);
+	      gfc_add_component_ref (actual->next->expr, "$data");
+	      if (rhs->ts.type == BT_CLASS)
+		{
+		  ppc = gfc_copy_expr (rhs);
+		  gfc_add_component_ref (ppc, "$vptr");
+		}
+	      else
+		ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived));
+	      gfc_add_component_ref (ppc, "$copy");
+	      gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual,
+					ppc, NULL);
+	      gfc_add_expr_to_block (&call.pre, call.expr);
+	      gfc_add_block_to_block (&call.pre, &call.post);
+	      tmp = gfc_finish_block (&call.pre);
 	    }
 	  else
 	    tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 166357)
+++ gcc/fortran/expr.c	(working copy)
@@ -3457,6 +3457,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
       return FAILURE;
     }
 
+  if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
+    /* Make sure the vtab is present.  */
+    gfc_find_derived_vtab (rvalue->ts.u.derived);
+
   /* Check rank remapping.  */
   if (rank_remap)
     {
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 166357)
+++ gcc/fortran/resolve.c	(working copy)
@@ -13331,6 +13331,9 @@ resolve_codes (gfc_namespace *ns)
   gfc_namespace *n;
   bitmap_obstack old_obstack;
 
+  if (ns->resolved == 1)
+    return;
+
   for (n = ns->contained; n; n = n->sibling)
     resolve_codes (n);
 

[-- Attachment #3: class_allocate_6.f03 --]
[-- Type: application/octet-stream, Size: 736 bytes --]

! { dg-do run }
!
! PR 46174: [OOP] ALLOCATE with SOURCE: Deep copy missing
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>

implicit none
type t
end type t

type, extends(t) :: t2
  integer, allocatable :: a(:)
end type t2

class(t), allocatable :: x, y
integer :: i

allocate(t2 :: x)
select type(x)
 type is (t2)
   allocate(x%a(10))
   x%a = [ (i, i = 1,10) ]
   print '(*(i3))', x%a
 class default
   call abort()
end select

allocate(y, source=x)

select type(x)
 type is (t2)
   x%a = [ (i, i = 11,20) ]
   print '(*(i3))', x%a
 class default
   call abort()
end select

select type(y)
 type is (t2)
   print '(*(i3))', y%a
   if (any (y%a /= [ (i, i = 1,10) ])) call abort()
 class default
   call abort()
end select

end

Re: [RFC] Polymorphic deep copy (aka PR46174)

[Tobias Burnus]

On 11/05/2010 03:01 PM, Janus Weil wrote:
>> I think the following program is valid and now rejected with your patch:

Can we add that program or turn one of the type-bound operator test 
cases from dg-do compile to dg-do run? Seemingly, we lack such a test case.

  * * *

Regarding the generate code, I have a RFC: Currently, gfortran assume 
that all code is old and uses no polymorphic data types. Only few newer 
code exists which does. A consequence of that is that the vtable is 
always populated per translation unit. For instance, the 
"copy$<dt_name>" exists in every file which uses CLASS(t). (As function 
which is not externally visible.) That works and is fine; however, if 
one has a program which heavily uses polymorphic types, the size could 
be significantly reduced by generating the function only once at the 
place where the TYPE is defined.

Current version:
+ No OOP penalty for code which never uses CLASS
+ Local scope which makes inlining even without LTO easier
- Larger files due to duplicated code

Single-occurence:
+ Generated only once, smaller files
- Also generated if CLASS is not used

Comments? We don't have to decide now, but if we change the ABI, it has 
either to be in 4.6 or in the ABI-breaking version (4.7?). 4.6 is OK 
because in 4.5 the polymorphism support was very experimental.
See also PR 46313 (part c)  for another reason to break the ABI.

  * * *

> The attached new version of the patch finally is free of regressions
> (on x86_64-unknown-linux-gnu). Ok for trunk?

OK; but please add (or "dg-do run" enable) a test case for the 
user-defined assignment.

You could also add PR 45451 to the changelog as the patch seemingly 
fixes the last remaining issue of that PR.

Tobias

PS: The next step logically following this patch is to add deep-"free$" 
support (cf. comment 2 of this PR 46174) and - in relation with 
automatic (re)allocation on assignment - to add support for an 
assignment to a polymorphic variable.

Re: [RFC] Polymorphic deep copy (aka PR46174)

[Janus Weil]

Hi Tobias,

> Regarding the generate code, I have a RFC: Currently, gfortran assume that
> all code is old and uses no polymorphic data types. Only few newer code
> exists which does. A consequence of that is that the vtable is always
> populated per translation unit. For instance, the "copy$<dt_name>" exists in
> every file which uses CLASS(t).(As function which is not externally
> visible.) That works and is fine; however, if one has a program which
> heavily uses polymorphic types, the size could be significantly reduced by
> generating the function only once at the place where the TYPE is defined.

well, actually it's not that bad. One has to distinguish two cases:

1) The module where the derived type is defined contains polymorphic
code. Then the vtab symbol is generated already in this base module,
and is use-associated by all other modules using the type, which means
we only have one unique instance of the vtab.

2) The module where the derived type is defined does *not* contain
polymorphic code. Then we generate no vtab symbol for the type in the
base module, and every other module using the derived type
(polymorphically) will generate it's own vtab (i.e. we can have
several instances).

I would regard case #1 as the standard case for real polymorphic code
(e.g. as soon as your module includes TBPs with 'pass'-arguments, the
vtab is being created in the base module), and for this case we are
doing fine and don't generate duplicate vtabs. The second case is more
problematic, but it is also more rare I think. Therefore I'd say our
approach is good for the most common usage scenarios. Also I don't
know how to do it better (without clobbering non-OOP programs with
vtabs).


>> The attached new version of the patch finally is free of regressions
>> (on x86_64-unknown-linux-gnu). Ok for trunk?
>
> OK; but please add (or "dg-do run" enable) a test case for the user-defined
> assignment.
>
> You could also add PR 45451 to the changelog as the patch seemingly fixes
> the last remaining issue of that PR.

Thanks for the review. I'll make the changes you propose and commit tonight.

Cheers,
Janus

Re: [RFC] Polymorphic deep copy (aka PR46174)

[Janus Weil]

>>> I think the following program is valid and now rejected with your patch:
>
> Can we add that program or turn one of the type-bound operator test cases
> from dg-do compile to dg-do run? Seemingly, we lack such a test case.

In fact my previous patch also failed on typebound_operator_{3,4}
which contain this type of checking. Therefore I think an additional
test case is not needed.

Cheers,
Janus

Re: [RFC] Polymorphic deep copy (aka PR46174)

[Janus Weil]

>>> The attached new version of the patch finally is free of regressions
>>> (on x86_64-unknown-linux-gnu). Ok for trunk?
>>
>> OK; but please add (or "dg-do run" enable) a test case for the user-defined
>> assignment.
>>
>> You could also add PR 45451 to the changelog as the patch seemingly fixes
>> the last remaining issue of that PR.
>
> Thanks for the review. I'll make the changes you propose and commit tonight.

Committed as r166368.

I'll open a follow-up PR for the $free case (i.e. polymorphic
deallocation), which is really a separate issue.

Cheers,
Janus