trans-array.c (gfc_trans_allocate_array_storage, [...]): For functions...

	* trans-array.c (gfc_trans_allocate_array_storage,
	gfc_trans_allocate_temp_array, gfc_add_loop_ss_code,
	gfc_conv_loop_setup):
	For functions, if the shape of the result is not known
	in compile-time, generate an empty array descriptor for
	the result and let the callee to allocate the memory.
	(gfc_trans_dummy_array_bias): Do nothing for pointers.
	(gfc_conv_expr_descriptor): Use function return values directly.
	* trans-expr.c (gfc_conv_function_call): Always add byref call
	insn to pre chain.
	(gfc_trans_pointer_assignment): Add comments.
	(gfc_trans_arrayfunc_assign): Don't chain on expression.
testsuite/
	* gfortran.dg/ret_array_1.f90: New test.
	* gfortran.dg/ret_pointer_1.f90: New test.

From-SVN: r85642

gcc/fortran/ChangeLog

+2004-08-06  Victor Leikehman  <lei@il.ibm.com>
+	Paul Brook  <paul@codesourcery.com>
+
+	* trans-array.c (gfc_trans_allocate_array_storage,
+	gfc_trans_allocate_temp_array, gfc_add_loop_ss_code,
+	gfc_conv_loop_setup): For functions, if the shape of the result
+	is not known in compile-time, generate an empty array descriptor for
+	the result and let the callee to allocate the memory.
+	(gfc_trans_dummy_array_bias): Do nothing for pointers.
+	(gfc_conv_expr_descriptor): Use function return values directly.
+	* trans-expr.c (gfc_conv_function_call): Always add byref call
+	insn to pre chain.
+	(gfc_trans_pointer_assignment): Add comments.
+	(gfc_trans_arrayfunc_assign): Don't chain on expression.
+
 2004-08-01  Roger Sayle  <roger@eyesopen.com>
 
 	* options.c (gfc_init_options): Don't warn about the use GNU

gcc/fortran/trans-array.c

@@ -436,7 +436,9 @@ gfc_trans_static_array_pointer (gfc_symbol * sym)
 
 
 /* Generate code to allocate an array temporary, or create a variable to
-   hold the data.  */
+   hold the data.  If size is NULL zero the descriptor so that so that the
+   callee will allocate the array.  Also generates code to free the array
+   afterwards.  */
 
 static void
 gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
@@ -450,38 +452,54 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
 
   desc = info->descriptor;
   data = gfc_conv_descriptor_data (desc);
-  onstack = gfc_can_put_var_on_stack (size);
-  if (onstack)
+  if (size == NULL_TREE)
     {
-      /* Make a temporary variable to hold the data.  */
-      tmp = fold (build (MINUS_EXPR, TREE_TYPE (nelem), nelem,
-			 integer_one_node));
-      tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
-      tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), tmp);
-      tmp = gfc_create_var (tmp, "A");
-      tmp = gfc_build_addr_expr (TREE_TYPE (data), tmp);
-      gfc_add_modify_expr (&loop->pre, data, tmp);
+      /* A callee allocated array.  */
+      gfc_add_modify_expr (&loop->pre, data, convert (TREE_TYPE (data), 
+                                                      gfc_index_zero_node));
       info->data = data;
       info->offset = gfc_index_zero_node;
-
+      onstack = FALSE;
     }
   else
     {
-      /* Allocate memory to hold the data.  */
-      args = gfc_chainon_list (NULL_TREE, size);
+      /* Allocate the temporary.  */
+      onstack = gfc_can_put_var_on_stack (size);
+
+      if (onstack)
+	{
+	  /* Make a temporary variable to hold the data.  */
+	  tmp = fold (build (MINUS_EXPR, TREE_TYPE (nelem), nelem,
+			     integer_one_node));
+	  tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+				  tmp);
+	  tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
+				  tmp);
+	  tmp = gfc_create_var (tmp, "A");
+	  tmp = gfc_build_addr_expr (TREE_TYPE (data), tmp);
+	  gfc_add_modify_expr (&loop->pre, data, tmp);
+	  info->data = data;
+	  info->offset = gfc_index_zero_node;
 
-      if (gfc_index_integer_kind == 4)
-	tmp = gfor_fndecl_internal_malloc;
-      else if (gfc_index_integer_kind == 8)
-	tmp = gfor_fndecl_internal_malloc64;
+	}
       else
-	abort ();
-      tmp = gfc_build_function_call (tmp, args);
-      tmp = convert (TREE_TYPE (data), tmp);
-      gfc_add_modify_expr (&loop->pre, data, tmp);
+	{
+	  /* Allocate memory to hold the data.  */
+	  args = gfc_chainon_list (NULL_TREE, size);
 
-      info->data = data;
-      info->offset = gfc_index_zero_node;
+	  if (gfc_index_integer_kind == 4)
+	    tmp = gfor_fndecl_internal_malloc;
+	  else if (gfc_index_integer_kind == 8)
+	    tmp = gfor_fndecl_internal_malloc64;
+	  else
+	    abort ();
+	  tmp = gfc_build_function_call (tmp, args);
+	  tmp = convert (TREE_TYPE (data), tmp);
+	  gfc_add_modify_expr (&loop->pre, data, tmp);
+
+	  info->data = data;
+	  info->offset = gfc_index_zero_node;
+	}
     }
 
   /* The offset is zero because we create temporaries with a zero
@@ -501,9 +519,11 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
 
 
 /* Generate code to allocate and initialize the descriptor for a temporary
-   array.  Fills in the descriptor, data and offset fields of info.  Also
-   adjusts the loop variables to be zero-based.  Returns the size of the
-   array.  */
+   array.  This is used for both temporaries needed by the scaparizer, and
+   functions returning arrays.  Adjusts the loop variables to be zero-based,
+   and calculates the loop bounds for callee allocated arrays.
+   Also fills in the descriptor, data and offset fields of info if known.
+   Returns the size of the array, or NULL for a callee allocated array.  */
 
 tree
 gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
@@ -526,7 +546,9 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
 	assert (integer_zerop (loop->from[n]));
       else
 	{
-	  loop->to[n] = fold (build (MINUS_EXPR, gfc_array_index_type,
+	  /* Callee allocated arrays may not have a known bound yet.  */
+          if (loop->to[n])
+              loop->to[n] = fold (build (MINUS_EXPR, gfc_array_index_type,
 				     loop->to[n], loop->from[n]));
 	  loop->from[n] = gfc_index_zero_node;
 	}
@@ -566,6 +588,18 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
 
   for (n = 0; n < info->dimen; n++)
     {
+      if (loop->to[n] == NULL_TREE)
+        {
+	  /* For a callee allocated array express the loop bounds in terms
+	     of the descriptor fields.  */
+          tmp = build (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;
+          size = NULL_TREE;
+          continue;
+        }
+        
       /* Store the stride and bound components in the descriptor.  */
       tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
       gfc_add_modify_expr (&loop->pre, tmp, size);
@@ -589,7 +623,8 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
 
   /* Get the size of the array.  */
   nelem = size;
-  size = fold (build (MULT_EXPR, gfc_array_index_type, size,
+  if (size)
+    size = fold (build (MULT_EXPR, gfc_array_index_type, size,
 		      TYPE_SIZE_UNIT (gfc_get_element_type (type))));
 
   gfc_trans_allocate_array_storage (loop, info, size, nelem);
@@ -985,7 +1020,6 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
 /* Add the pre and post chains for all the scalar expressions in a SS chain
    to loop.  This is called after the loop parameters have been calculated,
    but before the actual scalarizing loops.  */
-/*GCC ARRAYS*/
 
 static void
 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
@@ -1065,6 +1099,10 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
 	  gfc_trans_array_constructor (loop, ss);
 	  break;
 
+        case GFC_SS_TEMP:
+          /* Do nothing.  This will be handled later.  */
+          break;
+
 	default:
 	  abort ();
 	}
@@ -2256,8 +2294,14 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
 	      continue;
 	    }
 
-	  /* We don't know how to handle functions yet.
-	     This may not be possible in all cases.  */
+	  /* TODO: Pick the best bound if we have a choice between a
+	     functions and something else.  */
+          if (ss->type == GFC_SS_FUNCTION)
+            {
+              loopspec[n] = ss;
+              continue;
+            }
+
 	  if (ss->type != GFC_SS_SECTION)
 	    continue;
 
@@ -2333,6 +2377,11 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
 							  &loop->pre);
 	      break;
 
+            case GFC_SS_FUNCTION:
+	      /* The loop bound will be set when we generate the call.  */
+              assert (loop->to[n] == NULL_TREE);
+              break;
+
 	    default:
 	      abort ();
 	    }
@@ -2359,6 +2408,11 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
 	}
     }
 
+  /* Add all the scalar code that can be taken out of the loops.
+     This may include calculating the loop bounds, so do it before
+     allocating the temporary.  */
+  gfc_add_loop_ss_code (loop, loop->ss, false);
+
   /* If we want a temporary then create it.  */
   if (loop->temp_ss != NULL)
     {
@@ -2373,9 +2427,6 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
 				     tmp, len);
     }
 
-  /* Add all the scalar code that can be taken out of the loops.  */
-  gfc_add_loop_ss_code (loop, loop->ss, false);
-
   for (n = 0; n < loop->temp_dim; n++)
     loopspec[loop->order[n]] = NULL;
 
@@ -3012,6 +3063,10 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
   int checkparm;
   int no_repack;
 
+  /* Do nothing for pointer and allocatable arrays.  */
+  if (sym->attr.pointer || sym->attr.allocatable)
+    return body;
+
   if (sym->attr.dummy && gfc_is_nodesc_array (sym))
     return gfc_trans_g77_array (sym, body);
 
@@ -3284,15 +3339,17 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
   tree start;
   tree offset;
   int full;
+  gfc_ss *vss;
 
   assert (ss != gfc_ss_terminator);
 
   /* TODO: Pass constant array constructors without a temporary.  */
-  /* If we have a linear array section, we can pass it directly.  Otherwise
-     we need to copy it into a temporary.  */
-  if (expr->expr_type == EXPR_VARIABLE)
+  /* Special case things we know we can pass easily.  */
+  switch (expr->expr_type)
     {
-      gfc_ss *vss;
+    case EXPR_VARIABLE:
+      /* If we have a linear array section, we can pass it directly.
+	 Otherwise we need to copy it into a temporary.  */
 
       /* Find the SS for the array section.  */
       secss = ss;
@@ -3352,8 +3409,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	  else if (se->want_pointer)
 	    {
 	      /* We pass full arrays directly.  This means that pointers and
-	         allocatable arrays should also work.  */
-	      se->expr = gfc_build_addr_expr (NULL, desc);
+		 allocatable arrays should also work.  */
+	      se->expr = gfc_build_addr_expr (NULL_TREE, desc);
 	    }
 	  else
 	    {
@@ -3363,14 +3420,53 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	    se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
 	  return;
 	}
-    }
-  else
-    {
+      break;
+      
+    case EXPR_FUNCTION:
+      /* A transformational function return value will be a temporary
+	 array descriptor.  We still need to go through the scalarizer
+	 to create the descriptor.  Elemental functions ar handled as
+	 arbitary expressions, ie. copy to a temporary.  */
+      secss = ss;
+      /* Look for the SS for this function.  */
+      while (secss != gfc_ss_terminator
+	     && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
+      	secss = secss->next;
+
+      if (se->direct_byref)
+	{
+	  assert (secss != gfc_ss_terminator);
+
+	  /* For pointer assignments pass the descriptor directly.  */
+	  se->ss = secss;
+	  se->expr = gfc_build_addr_expr (NULL, se->expr);
+	  gfc_conv_expr (se, expr);
+	  return;
+	}
+
+      if (secss == gfc_ss_terminator)
+	{
+	  /* Elemental function.  */
+	  need_tmp = 1;
+	  info = NULL;
+	}
+      else
+	{
+	  /* Transformational function.  */
+	  info = &secss->data.info;
+	  need_tmp = 0;
+	}
+      break;
+
+    default:
+      /* Something complicated.  Copy it into a temporary.  */
       need_tmp = 1;
       secss = NULL;
       info = NULL;
+      break;
     }
 
+
   gfc_init_loopinfo (&loop);
 
   /* Associate the SS with the loop.  */
@@ -3445,11 +3541,25 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       assert (is_gimple_lvalue (desc));
       se->expr = gfc_build_addr_expr (NULL, desc);
     }
+  else if (expr->expr_type == EXPR_FUNCTION)
+    {
+      desc = info->descriptor;
+
+      if (se->want_pointer)
+	se->expr = gfc_build_addr_expr (NULL_TREE, desc);
+      else
+	se->expr = desc;
+
+      if (expr->ts.type == BT_CHARACTER)
+	se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
+    }
   else
     {
-      /* We pass sections without copying to a temporary.  A function may
-         decide to repack the array to speed up access, but we're not
-         bothered about that here.  */
+      /* We pass sections without copying to a temporary.  Make a new
+	 descriptor and point it at the section we want.  The loop variable
+	 limits will be the limits of the section.
+	 A function may decide to repack the array to speed up access, but
+	 we're not bothered about that here.  */
       int dim;
       tree parm;
       tree parmtype;
@@ -3458,13 +3568,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       tree to;
       tree base;
 
-      /* set the string_length for a character array.  */
+      /* Set the string_length for a character array.  */
       if (expr->ts.type == BT_CHARACTER)
 	se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
 
-      /* Otherwise make a new descriptor and point it at the section we
-         want.  The loop variable limits will be the limits of the section.
-       */
       desc = info->descriptor;
       assert (secss && secss != gfc_ss_terminator);
       if (se->direct_byref)

gcc/fortran/trans-expr.c

@@ -1171,29 +1171,34 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
     TREE_SIDE_EFFECTS (se->expr) = 1;
 #endif
 
-  if (byref && !se->direct_byref)
+  if (byref)
     {
+      /* Add the function call to the pre chain.  There is no expression.  */
       gfc_add_expr_to_block (&se->pre, se->expr);
+      se->expr = NULL_TREE;
 
-      if (sym->result->attr.dimension)
+      if (!se->direct_byref)
 	{
-	  if (flag_bounds_check)
+	  if (sym->result->attr.dimension)
 	    {
-	      /* Check the data pointer hasn't been modified.  This would happen
-	         in a function returning a pointer.  */
-	      tmp = gfc_conv_descriptor_data (info->descriptor);
-	      tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
-	      gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+	      if (flag_bounds_check)
+		{
+		  /* Check the data pointer hasn't been modified.  This would
+		     happen in a function returning a pointer.  */
+		  tmp = gfc_conv_descriptor_data (info->descriptor);
+		  tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
+		  gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+		}
+	      se->expr = info->descriptor;
 	    }
-	  se->expr = info->descriptor;
-	}
-      else if (sym->ts.type == BT_CHARACTER)
-	{
-	  se->expr = var;
-	  se->string_length = len;
+	  else if (sym->ts.type == BT_CHARACTER)
+	    {
+	      se->expr = var;
+	      se->string_length = len;
+	    }
+	  else
+	    abort ();
 	}
-      else
-	abort ();
     }
 }
 
@@ -1637,6 +1642,8 @@ gfc_trans_pointer_assign (gfc_code * code)
 }
 
 
+/* Generate code for a pointer assignment.  */
+
 tree
 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 {
@@ -1654,6 +1661,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
   rss = gfc_walk_expr (expr2);
   if (lss == gfc_ss_terminator)
     {
+      /* Scalar pointers.  */
       lse.want_pointer = 1;
       gfc_conv_expr (&lse, expr1);
       assert (rss == gfc_ss_terminator);
@@ -1669,6 +1677,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
     }
   else
     {
+      /* Array pointer.  */
       gfc_conv_expr_descriptor (&lse, expr1, lss);
       /* Implement Nullify.  */
       if (expr2->expr_type == EXPR_NULL)
@@ -1796,7 +1805,6 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   se.ss = gfc_walk_expr (expr2);
   assert (se.ss != gfc_ss_terminator);
   gfc_conv_function_expr (&se, expr2);
-  gfc_add_expr_to_block (&se.pre, se.expr);
   gfc_add_block_to_block (&se.pre, &se.post);
 
   return gfc_finish_block (&se.pre);

gcc/testsuite/ChangeLog

+2004-08-06  Paul Brook  <paul@codesourcery.com>
+
+	* gfortran.dg/ret_array_1.f90: New test.
+	* gfortran.dg/ret_pointer_1.f90: New test.
+
 2004-08-06  Richard Sandiford  <rsandifo@redhat.com>
 
 	* gcc.dg/missing-field-init-[12].c: New tests.

gcc/testsuite/gfortran.dg/ret_array_1.f90

+! { dg-do run }
+! Test functions returning arrays of indeterminate size.
+program ret_array_1
+  integer, dimension(:, :), allocatable :: a
+  integer, dimension(2) :: b
+
+  allocate (a(2, 3))
+  a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/))
+  
+  ! Using the return value as an actual argument
+  b = 0;
+  b = sum (transpose (a), 1);
+  if (any (b .ne. (/9, 12/))) call abort ()
+
+  ! Using the return value in an expression
+  b = 0;
+  b = sum (transpose (a) + 1, 1);
+  if (any (b .ne. (/12, 15/))) call abort ()
+
+  ! Same again testing a user function
+! TODO: enable these once this is implemented
+!  b = 0;
+!  b = sum (my_transpose (a), 1);
+!  if (any (b .ne. (/9, 12/))) call abort ()
+!
+!  ! Using the return value in an expression
+!  b = 0;
+!  b = sum (my_transpose (a) + 1, 1);
+!  if (any (b .ne. (/12, 15/))) call abort ()
+contains
+subroutine test(x, n)
+  integer, dimension (:, :) :: x
+  integer n
+
+  if (any (shape (x) .ne. (/3, 2/))) call abort
+  if (any (x .ne. (n + reshape((/1, 4, 2, 5, 3, 6/), (/3, 2/))))) call abort
+end subroutine
+
+function my_transpose (x) result (r)
+  interface
+    pure function obfuscate (i)
+      integer obfuscate
+      integer, intent(in) :: i
+    end function
+  end interface
+  integer, dimension (:, :) :: x
+  integer, dimension (obfuscate(ubound(x, 2)), &
+                      obfuscate(ubound(x, 1))) :: r
+  integer i
+
+  do i = 1, ubound(x, 1)
+    r(:, i) = x(i, :)
+  end do
+end function
+end program
+
+pure function obfuscate (i)
+  integer obfuscate
+  integer, intent(in) :: i
+
+  obfuscate = i
+end function
+

gcc/testsuite/gfortran.dg/ret_pointer_1.f90

+! PR16898 : XFAILed because of problems with aliasing of array descriptors.
+!  Basically a and r get put in different alias sets, then the rtl optimizars
+!  wreak havoc when foo is inlined.
+! { dg-do run { xfail *-*-* } }
+! Test functions returning array pointers
+program ret_pointer_1
+  integer, pointer, dimension(:) :: a
+  integer, target, dimension(2) :: b
+  integer, pointer, dimension (:) :: p
+
+  a => NULL()
+  a => foo()
+  p => b
+  if (.not. associated (a, p)) call abort
+contains
+subroutine bar(p)
+  integer, pointer, dimension(:) :: p
+end subroutine
+function foo() result(r)
+  integer, pointer, dimension(:) :: r
+
+  r => b
+end function
+end program
+