re PR fortran/35681 (wrong result for vector subscripted array expression in MVBITS)

2008-11-01  Daniel Kraft  <d@domob.eu>

	PR fortran/35681
	* gfortran.h (struct gfc_code): New field `resolved_isym'.
	* trans.h (gfc_build_memcpy_call): Made public.
	* trans-array.h (gfc_trans_create_temp_array): New argument `initial'.
	* intrinsic.c (gfc_intrinsic_sub_interface): Set resolved_isym.
	* iresolve.c (create_formal_for_intents): New helper method.
	(gfc_resolve_mvbits): Put dummy formal arglist on resolved_sym.
	* resolve.c (resolve_call): Initialize resolved_isym to NULL.
	* trans-array.c (gfc_trans_allocate_array_storage): New argument
	`initial' to allow initializing the allocated storage to some initial
	value copied from another array.
	(gfc_trans_create_temp_array): Allow initialization of the temporary
	with a copy of some other array by using the new extension.
	(gfc_trans_array_constructor): Pass NULL_TREE for initial argument.
	(gfc_conv_loop_setup): Ditto.
	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Ditto.
	* trans-expr.c (gfc_conv_function_call): Ditto.
	(gfc_build_memcpy_call): Made public.
	* trans-stmt.c (gfc_conv_elemental_dependencies): Initialize created
	temporary for INTENT(INOUT) arguments to the value of the mirrored
	array and clean up the temporary as very last intructions in the created
	block.
	* trans.c (gfc_trans_code): For EXEC_CALL, see if we have a MVBITS call
	and enable elemental dependency checking if we have.

2008-11-01  Daniel Kraft  <d@domob.eu>

	PR fortran/35681
	* gfortran.dg/mvbits_4.f90: New test.

From-SVN: r141516

1 files changed, 72 insertions, 23 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5080e0f..db43a40 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -493,14 +493,17 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
    callee will allocate the array.  If DEALLOC is true, also generate code to
    free the array afterwards.
 
+   If INITIAL is not NULL, it is packed using internal_pack and the result used
+   as data instead of allocating a fresh, unitialized area of memory.
+
    Initialization code is added to PRE and finalization code to POST.
    DYNAMIC is true if the caller may want to extend the array later
    using realloc.  This prevents us from putting the array on the stack.  */
 
 static void
 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
-                                  gfc_ss_info * info, tree size, tree nelem,
-                                  bool dynamic, bool dealloc)
+				  gfc_ss_info * info, tree size, tree nelem,
+				  tree initial, bool dynamic, bool dealloc)
 {
   tree tmp;
   tree desc;
@@ -517,7 +520,8 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
   else
     {
       /* Allocate the temporary.  */
-      onstack = !dynamic && gfc_can_put_var_on_stack (size);
+      onstack = !dynamic && initial == NULL_TREE
+			 && gfc_can_put_var_on_stack (size);
 
       if (onstack)
 	{
@@ -534,9 +538,53 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
 	}
       else
 	{
-	  /* Allocate memory to hold the data.  */
-	  tmp = gfc_call_malloc (pre, NULL, size);
-	  tmp = gfc_evaluate_now (tmp, pre);
+	  /* Allocate memory to hold the data or call internal_pack.  */
+	  if (initial == NULL_TREE)
+	    {
+	      tmp = gfc_call_malloc (pre, NULL, size);
+	      tmp = gfc_evaluate_now (tmp, pre);
+	    }
+	  else
+	    {
+	      tree packed;
+	      tree source_data;
+	      tree was_packed;
+	      stmtblock_t do_copying;
+
+	      tmp = TREE_TYPE (initial); /* Pointer to descriptor.  */
+	      gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
+	      tmp = TREE_TYPE (tmp); /* The descriptor itself.  */
+	      tmp = gfc_get_element_type (tmp);
+	      gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
+	      packed = gfc_create_var (build_pointer_type (tmp), "data");
+
+	      tmp = build_call_expr (gfor_fndecl_in_pack, 1, initial);
+	      tmp = fold_convert (TREE_TYPE (packed), tmp);
+	      gfc_add_modify (pre, packed, tmp);
+
+	      tmp = build_fold_indirect_ref (initial);
+	      source_data = gfc_conv_descriptor_data_get (tmp);
+
+	      /* internal_pack may return source->data without any allocation
+		 or copying if it is already packed.  If that's the case, we
+		 need to allocate and copy manually.  */
+
+	      gfc_start_block (&do_copying);
+	      tmp = gfc_call_malloc (&do_copying, NULL, size);
+	      tmp = fold_convert (TREE_TYPE (packed), tmp);
+	      gfc_add_modify (&do_copying, packed, tmp);
+	      tmp = gfc_build_memcpy_call (packed, source_data, size);
+	      gfc_add_expr_to_block (&do_copying, tmp);
+
+	      was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
+					packed, source_data);
+	      tmp = gfc_finish_block (&do_copying);
+	      tmp = build3_v (COND_EXPR, was_packed, tmp, build_empty_stmt ());
+	      gfc_add_expr_to_block (pre, tmp);
+
+	      tmp = fold_convert (pvoid_type_node, packed);
+	    }
+
 	  gfc_conv_descriptor_data_set (pre, desc, tmp);
 	}
     }
@@ -567,14 +615,15 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
    fields of info if known.  Returns the size of the array, or NULL for a
    callee allocated array.
 
-   PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
+   PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
+   gfc_trans_allocate_array_storage.
  */
 
 tree
 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
 			     gfc_loopinfo * loop, gfc_ss_info * info,
-			     tree eltype, bool dynamic, bool dealloc,
-			     bool callee_alloc, locus * where)
+			     tree eltype, tree initial, bool dynamic,
+			     bool dealloc, bool callee_alloc, locus * where)
 {
   tree type;
   tree desc;
@@ -600,8 +649,8 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
       else
 	{
 	  /* Callee allocated arrays may not have a known bound yet.  */
-          if (loop->to[n])
-              loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+	  if (loop->to[n])
+	      loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 					 loop->to[n], loop->from[n]);
 	  loop->from[n] = gfc_index_zero_node;
 	}
@@ -635,7 +684,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
        {
 	 stride[n] = size
 	 delta = ubound[n] + 1 - lbound[n];
-         size = size * delta;
+	 size = size * delta;
        }
      size = size * sizeof(element);
   */
@@ -654,17 +703,17 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
   for (n = 0; n < info->dimen; n++)
      {
       if (size == NULL_TREE)
-        {
+	{
 	  /* For a callee allocated array express the loop bounds in terms
 	     of the descriptor fields.  */
-          tmp =
+	  tmp =
 	    fold_build2 (MINUS_EXPR, gfc_array_index_type,
 			 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
 			 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
-          loop->to[n] = tmp;
-          continue;
-        }
-        
+	  loop->to[n] = tmp;
+	  continue;
+	}
+	
       /* Store the stride and bound components in the descriptor.  */
       tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
       gfc_add_modify (pre, tmp, size);
@@ -712,8 +761,8 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
       size = NULL_TREE;
     }
 
-  gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
-			            dealloc);
+  gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
+				    dynamic, dealloc);
 
   if (info->dimen > loop->temp_dim)
     loop->temp_dim = info->dimen;
@@ -1811,7 +1860,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
     }
 
   gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
-			       type, dynamic, true, false, where);
+			       type, NULL_TREE, dynamic, true, false, where);
 
   desc = ss->data.info.descriptor;
   offset = gfc_index_zero_node;
@@ -3523,8 +3572,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
       loop->temp_ss->type = GFC_SS_SECTION;
       loop->temp_ss->data.info.dimen = n;
       gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
-				   &loop->temp_ss->data.info, tmp, false, true,
-				   false, where);
+				   &loop->temp_ss->data.info, tmp, NULL_TREE,
+				   false, true, false, where);
     }
 
   for (n = 0; n < loop->temp_dim; n++)