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, 13 insertions, 5 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b4ed58f..b8516af 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4719,7 +4719,7 @@ static tree
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
 		     stmtblock_t * descriptor_block, tree * overflow,
-		     gfc_expr *expr3)
+		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
 {
   tree type;
   tree tmp;
@@ -4876,7 +4876,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
   /* The stride is the number of elements in the array, so multiply by the
      size of an element to get the total size.  Obviously, if there ia a
      SOURCE expression (expr3) we must use its element size.  */
-  if (expr3 != NULL)
+  if (expr3_elem_size != NULL_TREE)
+    tmp = expr3_elem_size;
+  else if (expr3 != NULL)
     {
       if (expr3->ts.type == BT_CLASS)
 	{
@@ -4904,6 +4906,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
   if (rank == 0)
     return element_size;
 
+  *nelems = gfc_evaluate_now (stride, pblock);
   stride = fold_convert (size_type_node, stride);
 
   /* First check for overflow. Since an array of type character can
@@ -4962,7 +4965,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
-		    tree errlen, tree label_finish, gfc_expr *expr3)
+		    tree errlen, tree label_finish, tree expr3_elem_size,
+		    tree *nelems, gfc_expr *expr3)
 {
   tree tmp;
   tree pointer;
@@ -5047,7 +5051,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3);
+			      expr3_elem_size, nelems, expr3);
 
   if (dimension)
     {
@@ -5078,6 +5082,9 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   gfc_start_block (&elseblock);
 
   /* Allocate memory to store the data.  */
+  if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+    se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
   pointer = gfc_conv_descriptor_data_get (se->expr);
   STRIP_NOPS (pointer);
 
@@ -5104,7 +5111,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 
   gfc_add_expr_to_block (&se->pre, tmp);
 
-  if (expr->ts.type == BT_CLASS && expr3)
+  if (expr->ts.type == BT_CLASS
+	&& (expr3_elem_size != NULL_TREE || expr3))
     {
       tmp = build_int_cst (unsigned_char_type_node, 0);
       /* With class objects, it is best to play safe and null the