re PR fortran/48705 ([OOP] ALLOCATE with non-trivial SOURCE)

2012-01-27  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus <burnus@gcc.gnu.org>

	PR fortran/48705
	PR fortran/51870
	PR fortran/51943
	PR fortran/51946
	* trans-array.c (gfc_array_init_size): Add two extra arguments
	to convey the dynamic element size of a calls object and to
	return the number of elements that have been allocated.
	(gfc_array_allocate): Add the same arguments and use them to
	call gfc_array_init_size.  Before the allocation dereference
	the data pointer, if necessary. Set the allocated array to zero
	if the class element size or expr3 are non-null.
	* trans-expr.c (gfc_conv_class_to_class): Give this function
	global scope.
	(get_class_array_ref): New function.
	(gfc_copy_class_to_class): New function.
	* trans-array.h : Update prototype for gfc_array_allocate.
	* trans-stmt.c (gfc_trans_allocate): For non-variable class
	STATUS expressions extract the class object and the dynamic
	element size. Use the latter to call gfc_array_allocate and
	the former for setting the vptr and, via
	gfc_copy_class_to_clasfc_cs, to copy to the allocated data.
	* trans.h : Prototypes for gfc_get_class_array_ref,
	gfc_copy_class_to_class and gfc_conv_class_to_class.
  

2012-01-27  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus <burnus@gcc.gnu.org>

	PR fortran/48705
	* gfortran.dg/class_allocate_11.f03: New.

	PR fortran/51870
	PR fortran/51943
	PR fortran/51946
	* gfortran.dg/class_allocate_7.f03: New.
	* gfortran.dg/class_allocate_8.f03: New.
	* gfortran.dg/class_allocate_9.f03: New.
	* gfortran.dg/class_allocate_10.f03: New.


Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r183613

1 files changed, 61 insertions, 21 deletions

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 16acc33a269..19a8e7af429 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4740,6 +4740,10 @@ gfc_trans_allocate (gfc_code * code)
   stmtblock_t post;
   gfc_expr *sz;
   gfc_se se_sz;
+  tree class_expr;
+  tree nelems;
+  tree memsize = NULL_TREE;
+  tree classexpr = NULL_TREE;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
@@ -4794,13 +4798,39 @@ gfc_trans_allocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
+      /* Evaluate expr3 just once if not a variable.  */
+      if (al == code->ext.alloc.list
+	    && al->expr->ts.type == BT_CLASS
+	    && code->expr3
+	    && code->expr3->ts.type == BT_CLASS
+	    && code->expr3->expr_type != EXPR_VARIABLE)
+	{
+	  gfc_init_se (&se_sz, NULL);
+	  gfc_conv_expr_reference (&se_sz, code->expr3);
+	  gfc_conv_class_to_class (&se_sz, code->expr3,
+				   code->expr3->ts, false);
+	  gfc_add_block_to_block (&se.pre, &se_sz.pre);
+	  gfc_add_block_to_block (&se.post, &se_sz.post);
+	  classexpr = build_fold_indirect_ref_loc (input_location,
+						   se_sz.expr);
+	  classexpr = gfc_evaluate_now (classexpr, &se.pre);
+	  memsize = gfc_vtable_size_get (classexpr);
+	  memsize = fold_convert (sizetype, memsize);
+	}
+
+      memsz = memsize;
+      class_expr = classexpr;
+
+      nelems = NULL_TREE;
       if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
-			       code->expr3))
+			       memsz, &nelems, code->expr3))
 	{
 	  /* A scalar or derived type.  */
 
 	  /* Determine allocate size.  */
-	  if (al->expr->ts.type == BT_CLASS && code->expr3)
+	  if (al->expr->ts.type == BT_CLASS
+		&& code->expr3
+		&& memsz == NULL_TREE)
 	    {
 	      if (code->expr3->ts.type == BT_CLASS)
 		{
@@ -4897,7 +4927,7 @@ gfc_trans_allocate (gfc_code * code)
 	    }
 	  else if (code->ext.alloc.ts.type != BT_UNKNOWN)
 	    memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
-	  else
+	  else if (memsz == NULL_TREE)
 	    memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
 
 	  if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
@@ -4956,13 +4986,23 @@ gfc_trans_allocate (gfc_code * code)
       e = gfc_copy_expr (al->expr);
       if (e->ts.type == BT_CLASS)
 	{
-	  gfc_expr *lhs,*rhs;
+	  gfc_expr *lhs, *rhs;
 	  gfc_se lse;
 
 	  lhs = gfc_expr_to_initialize (e);
 	  gfc_add_vptr_component (lhs);
-	  rhs = NULL;
-	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+
+	  if (class_expr != NULL_TREE)
+	    {
+	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
+	      gfc_init_se (&lse, NULL);
+	      lse.want_pointer = 1;
+	      gfc_conv_expr (&lse, lhs);
+	      tmp = gfc_class_vptr_get (class_expr);
+	      gfc_add_modify (&block, lse.expr,
+			fold_convert (TREE_TYPE (lse.expr), tmp));
+	    }
+	  else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
 	    {
 	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
 	      rhs = gfc_copy_expr (code->expr3);
@@ -5011,7 +5051,14 @@ 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)
+	  if (class_expr != NULL_TREE)
+	    {
+	      tree to;
+	      to = TREE_OPERAND (se.expr, 0);
+
+	      tmp = gfc_copy_class_to_class (class_expr, to, nelems);
+	    }
+	  else if (al->expr->ts.type == BT_CLASS)
 	    {
 	      gfc_actual_arglist *actual;
 	      gfc_expr *ppc;
@@ -5098,25 +5145,18 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_free_expr (rhs);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
-      else if (code->expr3 && code->expr3->mold
+     else if (code->expr3 && code->expr3->mold
 	    && code->expr3->ts.type == BT_CLASS)
 	{
-	  /* Default-initialization via MOLD (polymorphic).  */
-	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
-	  gfc_se dst,src;
-	  gfc_add_vptr_component (rhs);
-	  gfc_add_def_init_component (rhs);
-	  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);
+	  /* Since the _vptr has already been assigned to the allocate
+	     object, we can use gfc_copy_class_to_class in its
+	     initialization mode.  */
+	  tmp = TREE_OPERAND (se.expr, 0);
+	  tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
 	  gfc_add_expr_to_block (&block, tmp);
-	  gfc_free_expr (rhs);
 	}
 
-      gfc_free_expr (expr);
+       gfc_free_expr (expr);
     }
 
   /* STAT.  */