re PR fortran/45451 ([OOP] Inconsistent status of ALLOCATABLE components inside CLASS variables.)

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

	PR fortran/45451
	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/45451
	PR fortran/46174
	* gfortran.dg/class_19.f03: Modified.
	* gfortran.dg/class_allocate_6.f03: New.

From-SVN: r166368

gcc/fortran/ChangeLog

+2010-11-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45451
+	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-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
 	    Paul Thomas  <pault@gcc.gnu.org>
 

gcc/fortran/class.c

@@ -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, gfc_symbol *vtype)
 }
 
 
-/* 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,7 +330,13 @@ 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)
 	{
@@ -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 ();

gcc/fortran/expr.c

@@ -3457,6 +3457,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       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)
     {

gcc/fortran/resolve.c

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

gcc/fortran/trans-stmt.c

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

gcc/testsuite/ChangeLog

+2010-11-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45451
+	PR fortran/46174
+	* gfortran.dg/class_19.f03: Modified.
+	* gfortran.dg/class_allocate_6.f03: New.
+
 2010-11-05  H.J. Lu  <hongjiu.lu@intel.com>
 
 	* gcc.target/i386/avx-vzeroupper-19.c: New.

gcc/testsuite/gfortran.dg/class_19.f03

@@ -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" } }

gcc/testsuite/gfortran.dg/class_allocate_6.f03

+! { 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