trans-array.c (gfc_trans_create_temp_array): In the case of a class array temporary...

2012-01-16  Paul Thomas  <pault@gcc.gnu.org>

	* trans-array.c (gfc_trans_create_temp_array): In the case of a
	class array temporary, detect a null 'eltype' on entry and use 
	'initial' to provde the class reference and so, through the
	vtable, the element size for the dynamic type.
	* trans-stmt.c (gfc_conv_elemental_dependencies): For class
	expressions, set 'eltype' to null and pass the values via the
	'initial' expression.

2012-01-16  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/class_array_3.f03: Remove the explicit loop in
	subroutine 'qsort' and use index array to assign the result.

From-SVN: r183216

gcc/fortran/ChangeLog

+2012-01-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-array.c (gfc_trans_create_temp_array): In the case of a
+	class array temporary, detect a null 'eltype' on entry and use 
+	'initial' to provde the class reference and so, through the
+	vtable, the element size for the dynamic type.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): For class
+	expressions, set 'eltype' to null and pass the values via the
+	'initial' expression.
+
 2012-01-14  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/51800

gcc/fortran/trans-array.c

@@ -971,6 +971,11 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
    fields of info if known.  Returns the size of the array, or NULL for a
    callee allocated array.
 
+   'eltype' == NULL signals that the temporary should be a class object.
+   The 'initial' expression is used to obtain the size of the dynamic
+   type; otehrwise the allocation and initialisation proceeds as for any
+   other expression
+
    PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
    gfc_trans_allocate_array_storage.  */
 
@@ -990,9 +995,23 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   tree nelem;
   tree cond;
   tree or_expr;
+  tree class_expr = NULL_TREE;
   int n, dim, tmp_dim;
   int total_dim = 0;
 
+  /* This signals a class array for which we need the size of the
+     dynamic type.  Generate an eltype and then the class expression.  */
+  if (eltype == NULL_TREE && initial)
+    {
+      if (POINTER_TYPE_P (TREE_TYPE (initial)))
+	class_expr = build_fold_indirect_ref_loc (input_location, initial);
+      eltype = TREE_TYPE (class_expr);
+      eltype = gfc_get_element_type (eltype);
+      /* Obtain the structure (class) expression.  */
+      class_expr = TREE_OPERAND (class_expr, 0);
+      gcc_assert (class_expr);
+    }
+
   memset (from, 0, sizeof (from));
   memset (to, 0, sizeof (to));
 
@@ -1133,16 +1152,21 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   /* Get the size of the array.  */
   if (size && !callee_alloc)
     {
+      tree elemsize;
       /* If or_expr is true, then the extent in at least one
 	 dimension is zero and the size is set to zero.  */
       size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
 			      or_expr, gfc_index_zero_node, size);
 
       nelem = size;
+      if (class_expr == NULL_TREE)
+	elemsize = fold_convert (gfc_array_index_type,
+			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      else
+	elemsize = gfc_vtable_size_get (class_expr);
+
       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-		size,
-		fold_convert (gfc_array_index_type,
-			      TYPE_SIZE_UNIT (gfc_get_element_type (type))));
+			      size, elemsize);
     }
   else
     {
@@ -5083,9 +5107,9 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   if (expr->ts.type == BT_CLASS && expr3)
     {
       tmp = build_int_cst (unsigned_char_type_node, 0);
-      /* For class objects we need to nullify the memory in case they have
-	 allocatable components; the reason is that _copy, which is used for
-	 initialization, first frees the destination.  */
+      /* With class objects, it is best to play safe and null the 
+	 memory because we cannot know if dynamic types have allocatable
+	 components or not.  */
       tmp = build_call_expr_loc (input_location,
 				 builtin_decl_explicit (BUILT_IN_MEMSET),
 				 3, pointer, tmp,  size);

gcc/fortran/trans-stmt.c

@@ -282,19 +282,31 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 		|| (fsym->ts.type ==BT_DERIVED
 		      && fsym->attr.intent == INTENT_OUT))
 	    initial = parmse.expr;
+	  /* For class expressions, we always initialize with the copy of
+	     the values.  */
+	  else if (e->ts.type == BT_CLASS)
+	    initial = parmse.expr;
 	  else
 	    initial = NULL_TREE;
 
-	  /* Find the type of the temporary to create; we don't use the type
-	     of e itself as this breaks for subcomponent-references in e (where
-	     the type of e is that of the final reference, but parmse.expr's
-	     type corresponds to the full derived-type).  */
-	  /* TODO: Fix this somehow so we don't need a temporary of the whole
-	     array but instead only the components referenced.  */
-	  temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor.  */
-	  gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
-	  temptype = TREE_TYPE (temptype);
-	  temptype = gfc_get_element_type (temptype);
+	  if (e->ts.type != BT_CLASS)
+	    {
+	     /* Find the type of the temporary to create; we don't use the type
+		of e itself as this breaks for subcomponent-references in e
+		(where the type of e is that of the final reference, but
+		parmse.expr's type corresponds to the full derived-type).  */
+	     /* TODO: Fix this somehow so we don't need a temporary of the whole
+		array but instead only the components referenced.  */
+	      temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor.  */
+	      gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
+	      temptype = TREE_TYPE (temptype);
+	      temptype = gfc_get_element_type (temptype);
+	    }
+
+	  else
+	    /* For class arrays signal that the size of the dynamic type has to
+	       be obtained from the vtable, using the 'initial' expression.  */
+	    temptype = NULL_TREE;
 
 	  /* Generate the temporary.  Cleaning up the temporary should be the
 	     very last thing done, so we add the code to a new block and add it
@@ -312,9 +324,20 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 	  /* Update other ss' delta.  */
 	  gfc_set_delta (loopse->loop);
 
-	  /* Copy the result back using unpack.  */
-	  tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_in_unpack, 2, parmse.expr, data);
+	  /* Copy the result back using unpack.....  */
+	  if (e->ts.type != BT_CLASS)
+	    tmp = build_call_expr_loc (input_location,
+			gfor_fndecl_in_unpack, 2, parmse.expr, data);
+	  else
+	    {
+	      /* ... except for class results where the copy is
+		 unconditional.  */
+	      tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
+	      tmp = gfc_conv_descriptor_data_get (tmp);
+	      tmp = build_call_expr_loc (input_location,
+					 builtin_decl_explicit (BUILT_IN_MEMCPY),
+					 3, tmp, data, size);
+	    }
 	  gfc_add_expr_to_block (&se->post, tmp);
 
 	  /* parmse.pre is already added above.  */

gcc/testsuite/ChangeLog

+2012-01-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	* gfortran.dg/class_array_3.f03: Remove the explicit loop in
+	subroutine 'qsort' and use index array to assign the result.
+
 2012-01-16  Jakub Jelinek  <jakub@redhat.com>
 
 	PR tree-optimization/51865

gcc/testsuite/gfortran.dg/class_array_3.f03

@@ -45,10 +45,7 @@ contains
    allocate (tmp(size (a, 1)), source = a)
    index_array = [(i, i = 1, size (a, 1))]
    call internal_qsort (tmp, index_array)   ! Do not move class elements around until end
-   do i = 1, size (a, 1)                    ! Since they can be of arbitrary size.
-     a(i) = tmp(index_array(i))             ! Vector index array would be neater
-   end do
-!    a = tmp(index_array)                    ! Like this - TODO: fixme
+   a = tmp(index_array)
  end subroutine qsort
 
  recursive subroutine internal_qsort (x, iarray)