re PR fortran/12840 ([4.0 only] Unable to find scalarization loop specifier)

	PR fortran/12840
	* trans.h (gfor_fndecl_internal_realloc): Declare.
	(gfor_fndecl_internal_realloc64): Declare.
	* trans-decl.c (gfor_fndecl_internal_realloc): New variable.
	(gfor_fndecl_internal_realloc64): New variable.
	(gfc_build_builtin_function_decls): Initialize them.
	* trans-array.h (gfc_trans_allocate_temp_array): Add a fourth argument.
	* trans-array.c (gfc_trans_allocate_array_storage): Add an argument
	to say whether the array can grow later.  Don't allocate the array
	on the stack if so.  Don't call malloc for zero-sized arrays.
	(gfc_trans_allocate_temp_array): Add a similar argument here.
	Pass it along to gfc_trans_allocate_array_storage.
	(gfc_get_iteration_count, gfc_grow_array): New functions.
	(gfc_iterator_has_dynamic_bounds): New function.
	(gfc_get_array_constructor_element_size): New function.
	(gfc_get_array_constructor_size): New function.
	(gfc_trans_array_ctor_element): Replace pointer argument with
	a descriptor tree.
	(gfc_trans_array_constructor_subarray): Likewise.  Take an extra
	argument to say whether the variable-sized part of the constructor
	must be allocated using realloc.  Grow the array when this
	argument is true.
	(gfc_trans_array_constructor_value): Likewise.
	(gfc_get_array_cons_size): Delete.
	(gfc_trans_array_constructor): If the loop bound has not been set,
	split the allocation into a static part and a dynamic part.  Set
	loop->to to the bounds for static part before allocating the
	temporary.  Adjust call to gfc_trans_array_constructor_value.
	(gfc_conv_loop_setup): Allow any constructor to determine the
	loop bounds.  Check whether the constructor has a dynamic size
	and prefer to use something else if so.  Expect the loop bound
	to be set later.  Adjust call to gfc_trans_allocate_temp_array.
	* trans-expr.c (gfc_conv_function_call): Adjust another call here.

From-SVN: r104073

gcc/fortran/ChangeLog

+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/12840
+	* trans.h (gfor_fndecl_internal_realloc): Declare.
+	(gfor_fndecl_internal_realloc64): Declare.
+	* trans-decl.c (gfor_fndecl_internal_realloc): New variable.
+	(gfor_fndecl_internal_realloc64): New variable.
+	(gfc_build_builtin_function_decls): Initialize them.
+	* trans-array.h (gfc_trans_allocate_temp_array): Add a fourth argument.
+	* trans-array.c (gfc_trans_allocate_array_storage): Add an argument
+	to say whether the array can grow later.  Don't allocate the array
+	on the stack if so.  Don't call malloc for zero-sized arrays.
+	(gfc_trans_allocate_temp_array): Add a similar argument here.
+	Pass it along to gfc_trans_allocate_array_storage.
+	(gfc_get_iteration_count, gfc_grow_array): New functions.
+	(gfc_iterator_has_dynamic_bounds): New function.
+	(gfc_get_array_constructor_element_size): New function.
+	(gfc_get_array_constructor_size): New function.
+	(gfc_trans_array_ctor_element): Replace pointer argument with
+	a descriptor tree.
+	(gfc_trans_array_constructor_subarray): Likewise.  Take an extra
+	argument to say whether the variable-sized part of the constructor
+	must be allocated using realloc.  Grow the array when this
+	argument is true.
+	(gfc_trans_array_constructor_value): Likewise.
+	(gfc_get_array_cons_size): Delete.
+	(gfc_trans_array_constructor): If the loop bound has not been set,
+	split the allocation into a static part and a dynamic part.  Set
+	loop->to to the bounds for static part before allocating the
+	temporary.  Adjust call to gfc_trans_array_constructor_value.
+	(gfc_conv_loop_setup): Allow any constructor to determine the
+	loop bounds.  Check whether the constructor has a dynamic size
+	and prefer to use something else if so.  Expect the loop bound
+	to be set later.  Adjust call to gfc_trans_allocate_temp_array.
+	* trans-expr.c (gfc_conv_function_call): Adjust another call here.
+
 2005-09-09  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/18878

gcc/fortran/trans-array.h

@@ -27,7 +27,7 @@ tree gfc_array_deallocate (tree, tree);
 void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
 
 /* Generate code to allocate a temporary array.  */
-tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree);
+tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree, bool);
 
 /* Generate function entry code for allocation of compiler allocated array
    variables.  */

gcc/fortran/trans-decl.c

@@ -73,6 +73,8 @@ tree gfc_static_ctors;
 
 tree gfor_fndecl_internal_malloc;
 tree gfor_fndecl_internal_malloc64;
+tree gfor_fndecl_internal_realloc;
+tree gfor_fndecl_internal_realloc64;
 tree gfor_fndecl_internal_free;
 tree gfor_fndecl_allocate;
 tree gfor_fndecl_allocate64;
@@ -1891,6 +1893,18 @@ gfc_build_builtin_function_decls (void)
 				     pvoid_type_node, 1, gfc_int8_type_node);
   DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
 
+  gfor_fndecl_internal_realloc =
+    gfc_build_library_function_decl (get_identifier
+				     (PREFIX("internal_realloc")),
+				     pvoid_type_node, 2, pvoid_type_node,
+				     gfc_int4_type_node);
+
+  gfor_fndecl_internal_realloc64 =
+    gfc_build_library_function_decl (get_identifier
+				     (PREFIX("internal_realloc64")),
+				     pvoid_type_node, 2, pvoid_type_node,
+				     gfc_int8_type_node);
+
   gfor_fndecl_internal_free =
     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
 				     void_type_node, 1, pvoid_type_node);

gcc/fortran/trans-expr.c

@@ -1694,7 +1694,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	  info->dimen = se->loop->dimen;
 
 	  /* Allocate a temporary to store the result.  */
-	  gfc_trans_allocate_temp_array (se->loop, info, tmp);
+	  gfc_trans_allocate_temp_array (se->loop, info, tmp, false);
 
 	  /* Zero the first stride to indicate a temporary.  */
 	  tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);

gcc/fortran/trans.h

@@ -443,6 +443,8 @@ tree builtin_function (const char *, tree, int, enum built_in_class,
 /* Runtime library function decls.  */
 extern GTY(()) tree gfor_fndecl_internal_malloc;
 extern GTY(()) tree gfor_fndecl_internal_malloc64;
+extern GTY(()) tree gfor_fndecl_internal_realloc;
+extern GTY(()) tree gfor_fndecl_internal_realloc64;
 extern GTY(()) tree gfor_fndecl_internal_free;
 extern GTY(()) tree gfor_fndecl_allocate;
 extern GTY(()) tree gfor_fndecl_allocate64;

gcc/testsuite/ChangeLog

+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/12840
+	* gfortran.dg/array_constructor_6.f90
+	* gfortran.dg/array_constructor_7.f90
+	* gfortran.dg/array_constructor_8.f90
+	* gfortran.dg/array_constructor_9.f90
+	* gfortran.dg/array_constructor_10.f90
+	* gfortran.dg/array_constructor_11.f90
+	* gfortran.dg/array_constructor_12.f90: New tests.
+
 2005-09-08  Josh Conner  <jconner@apple.com>
 
 	PR c++/23180

gcc/testsuite/gfortran.dg/array_constructor_10.f90

+! Like array_constructor_6.f90, but check constructors that apply
+! an elemental function to an array.
+! { dg-do run }
+program main
+  implicit none
+  call build (200)
+contains
+  subroutine build (order)
+    integer :: order, i
+
+    call test (order, (/ (abs ((/ i, -i, -i * 2 /)), i = 1, order) /))
+    call test (order, abs ((/ ((/ -i, -i, i * 2 /), i = 1, order) /)))
+    call test (order, (/ abs ((/ ((/ i, i, -i * 2 /), i = 1, order) /)) /))
+  end subroutine build
+
+  subroutine test (order, values)
+    integer, dimension (3:) :: values
+    integer :: order, i
+
+    if (size (values, dim = 1) .ne. order * 3) call abort
+    do i = 1, order
+      if (values (i * 3) .ne. i) call abort
+      if (values (i * 3 + 1) .ne. i) call abort
+      if (values (i * 3 + 2) .ne. i * 2) call abort
+    end do
+  end subroutine test
+end program main

gcc/testsuite/gfortran.dg/array_constructor_11.f90

+! Like array_constructor_6.f90, but check iterators with non-default stride,
+! including combinations which lead to zero-length vectors.
+! { dg-do run }
+program main
+  implicit none
+  call build (77)
+contains
+  subroutine build (order)
+    integer :: order, i, j
+
+    call test (1, 11, 3, (/ (i, i = 1, 11, 3) /))
+    call test (3, 20, 2, (/ (i, i = 3, 20, 2) /))
+    call test (4, 0, 11, (/ (i, i = 4, 0, 11) /))
+
+    call test (110, 10, -3,  (/ (i, i = 110, 10, -3) /))
+    call test (200, 20, -12, (/ (i, i = 200, 20, -12) /))
+    call test (29, 30, -6,   (/ (i, i = 29, 30, -6) /))
+
+    call test (1, order, 3,  (/ (i, i = 1, order, 3) /))
+    call test (order, 1, -3, (/ (i, i = order, 1, -3) /))
+
+    ! Triggers compile-time iterator calculations in trans-array.c
+    call test (1, 1000, 2,   (/ (i, i = 1, 1000, 2),   (i, i = order, 0, 1) /))
+    call test (1, 0, 3,      (/ (i, i = 1, 0, 3),      (i, i = order, 0, 1) /))
+    call test (1, 2000, -5,  (/ (i, i = 1, 2000, -5),  (i, i = order, 0, 1) /))
+    call test (3000, 99, 4,  (/ (i, i = 3000, 99, 4),  (i, i = order, 0, 1) /))
+    call test (400, 77, -39, (/ (i, i = 400, 77, -39), (i, i = order, 0, 1) /))
+
+    do j = -10, 10
+      call test (order + j, order, 5,  (/ (i, i = order + j, order, 5) /))
+      call test (order + j, order, -5, (/ (i, i = order + j, order, -5) /))
+    end do
+
+  end subroutine build
+
+  subroutine test (from, to, step, values)
+    integer, dimension (:) :: values
+    integer :: from, to, step, last, i
+
+    last = 0
+    do i = from, to, step
+      last = last + 1
+      if (values (last) .ne. i) call abort
+    end do
+    if (size (values, dim = 1) .ne. last) call abort
+  end subroutine test
+end program main

gcc/testsuite/gfortran.dg/array_constructor_12.f90

+! Like array_constructor_6.f90, but check integer(8) iterators.
+! { dg-do run }
+program main
+  integer (kind = 8) :: i, l8, u8, step8
+  integer (kind = 4) :: l4, step4
+  integer (kind = 8), parameter :: big = 10000000000_8
+
+  l4 = huge (1)
+  u8 = l4 + 10_8
+  step4 = 2
+  call test ((/ (i, i = l4, u8, step4) /), l4 + 0_8, u8, step4 + 0_8)
+
+  l8 = big
+  u8 = big * 20
+  step8 = big
+  call test ((/ (i, i = l8, u8, step8) /), l8, u8, step8)
+
+  u8 = big + 100
+  l8 = big
+  step4 = -20
+  call test ((/ (i, i = u8, l8, step4) /), u8, l8, step4 + 0_8)
+
+  u8 = big * 40
+  l8 = big * 20
+  step8 = -big * 2
+  call test ((/ (i, i = u8, l8, step8) /), u8, l8, step8)
+
+  u8 = big
+  l4 = big / 100
+  step4 = -big / 500
+  call test ((/ (i, i = u8, l4, step4) /), u8, l4 + 0_8, step4 + 0_8)
+
+  u8 = big * 40 + 200
+  l4 = 200
+  step8 = -big
+  call test ((/ (i, i = u8, l4, step8) /), u8, l4 + 0_8, step8)
+contains
+  subroutine test (a, l, u, step)
+    integer (kind = 8), dimension (:), intent (in) :: a
+    integer (kind = 8), intent (in) :: l, u, step
+    integer (kind = 8) :: i
+    integer :: j
+
+    j = 1
+    do i = l, u, step
+      if (a (j) .ne. i) call abort
+      j = j + 1
+    end do
+    if (size (a, 1) .ne. j - 1) call abort
+  end subroutine test
+end program main

gcc/testsuite/gfortran.dg/array_constructor_6.f90

+! PR 12840.  Make sure that array constructors can be used to determine
+! the bounds of a scalarization loop.
+! { dg-do run }
+program main
+  implicit none
+  call build (11)
+contains
+  subroutine build (order)
+    integer :: order, i
+
+    call test (order, (/ (i * 2, i = 1, order) /))
+    call test (17, (/ (i * 2, i = 1, 17) /))
+    call test (5, (/ 2, 4, 6, 8, 10 /))
+  end subroutine build
+
+  subroutine test (order, values)
+    integer, dimension (:) :: values
+    integer :: order, i
+
+    if (size (values, dim = 1) .ne. order) call abort
+    do i = 1, order
+      if (values (i) .ne. i * 2) call abort
+    end do
+  end subroutine test
+end program main

gcc/testsuite/gfortran.dg/array_constructor_7.f90

+! Like array_constructor_6.f90, but test for nested iterators.
+! { dg-do run }
+program main
+  implicit none
+  call build (17)
+contains
+  subroutine build (order)
+    integer :: order, i, j
+
+    call test (order, (/ (((j + 100) * i, j = 1, i), i = 1, order) /))
+    call test (9, (/ (((j + 100) * i, j = 1, i), i = 1, 9) /))
+    call test (3, (/ 101, 202, 204, 303, 306, 309 /))
+  end subroutine build
+
+  subroutine test (order, values)
+    integer, dimension (:) :: values
+    integer :: order, i, j
+
+    if (size (values, dim = 1) .ne. order * (order + 1) / 2) call abort
+    do i = 1, order
+      do j = 1, i
+        if (values (i * (i - 1) / 2 + j) .ne. (j + 100) * i) call abort
+      end do
+    end do
+  end subroutine test
+end program main

gcc/testsuite/gfortran.dg/array_constructor_8.f90

+! Like array_constructor_6.f90, but check constructors that mix iterators
+! and individual scalar elements.
+! { dg-do run }
+program main
+  implicit none
+  call build (42)
+contains
+  subroutine build (order)
+    integer :: order, i
+
+    call test (order, 8, 5, (/ ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), i = 1, order), &
+                               100, 200, 300, 400, 500 /))
+
+    call test (order, 2, 3, (/ ((/ 1, 2 /), i = 1, order), &
+                               100, 200, 300 /))
+
+    call test (order, 3, 5, (/ ((/ 1, 2, 3 /), i = 1, order), &
+                               100, 200, 300, 400, 500 /))
+
+    call test (order, 6, 1, (/ ((/ 1, 2, 3, 4, 5, 6 /), i = 1, order), &
+                               100 /))
+
+    call test (order, 5, 0, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, order) /))
+
+    call test (order, 0, 4, (/ 100, 200, 300, 400 /))
+
+    call test (11, 5, 2, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, 11), &
+                            100, 200 /))
+
+    call test (6, 2, order, (/ ((/ 1, 2 /), i = 1, 6), &
+                               (i * 100, i = 1, order) /))
+  end subroutine build
+
+  subroutine test (order, repeat, trail, values)
+    integer, dimension (:) :: values
+    integer :: order, repeat, trail, i
+
+    if (size (values, dim = 1) .ne. order * repeat + trail) call abort
+    do i = 1, order * repeat
+      if (values (i) .ne. mod (i - 1, repeat) + 1) call abort
+    end do
+    do i = 1, trail
+      if (values (i + order * repeat) .ne. i * 100) call abort
+    end do
+  end subroutine test
+end program main

gcc/testsuite/gfortran.dg/array_constructor_9.f90

+! Like array_constructor_6.f90, but check constructors in which the length
+! of each subarray can only be determined at run time.
+! { dg-do run }
+program main
+  implicit none
+  call build (9)
+contains
+  function gen (order)
+    real, dimension (:, :), pointer :: gen
+    integer :: order, i, j
+
+    allocate (gen (order, order + 1))
+    forall (i = 1 : order, j = 1 : order + 1) gen (i, j) = i * i + j
+  end function gen
+
+  ! Deliberately leaky!
+  subroutine build (order)
+    integer :: order, i
+
+    call test (order, 0, (/ (gen (i), i = 1, order) /))
+    call test (3, 2, (/ ((/ 1.5, 1.5, gen (i) /), i = 1, 3) /))
+  end subroutine build
+
+  subroutine test (order, prefix, values)
+    real, dimension (:) :: values
+    integer :: order, prefix, last, i, j, k
+
+    last = 0
+    do i = 1, order
+      do j = 1, prefix
+        last = last + 1
+        if (values (last) .ne. 1.5) call abort
+      end do
+      do j = 1, i + 1
+        do k = 1, i
+          last = last + 1
+          if (values (last) .ne. j + k * k) call abort
+        end do
+      end do
+    end do
+    if (size (values, dim = 1) .ne. last) call abort
+  end subroutine test
+end program main

libgfortran/ChangeLog

+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
+	PR fortran/12840
+	* runtime/memory.c (internal_malloc_size): Return a null pointer
+	if the size is zero.
+	(internal_free): Do nothing if the pointer is null.
+	(internal_realloc_size, internal_realloc, internal_realloc64): New.
+
 2005-09-07  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	PR libfortran/23262

libgfortran/runtime/memory.c

@@ -141,6 +141,9 @@ internal_malloc_size (size_t size)
 {
   malloc_t *newmem;
 
+  if (size == 0)
+    return 0;
+
   newmem = malloc_with_header (size);
 
   if (!newmem)
@@ -195,7 +198,7 @@ internal_free (void *mem)
   malloc_t *m;
 
   if (!mem)
-    runtime_error ("Internal: Possible double free of temporary.");
+    return;
 
   m = DATA_HEADER (mem);
 
@@ -213,6 +216,67 @@ internal_free (void *mem)
 }
 iexport(internal_free);
 
+/* Reallocate internal memory MEM so it has SIZE bytes of data.
+   Allocate a new block if MEM is zero, and free the block if
+   SIZE is 0.  */
+
+static void *
+internal_realloc_size (void *mem, size_t size)
+{
+  malloc_t *m;
+
+  if (size == 0)
+    {
+      if (mem)
+	internal_free (mem);
+      return 0;
+    }
+
+  if (mem == 0)
+    return internal_malloc (size);
+
+  m = DATA_HEADER (mem);
+  if (m->magic != GFC_MALLOC_MAGIC)
+    runtime_error ("Internal: No magic memblock marker.  "
+		   "Possible memory corruption");
+
+  m = realloc (m, size + HEADER_SIZE);
+  if (!m)
+    os_error ("Out of memory.");
+
+  m->prev->next = m;
+  m->next->prev = m;
+  return DATA_POINTER (m);
+}
+
+extern void *internal_realloc (void *, GFC_INTEGER_4);
+export_proto(internal_realloc);
+
+void *
+internal_realloc (void *mem, GFC_INTEGER_4 size)
+{
+#ifdef GFC_CHECK_MEMORY
+  /* Under normal circumstances, this is _never_ going to happen!  */
+  if (size < 0)
+    runtime_error ("Attempt to allocate a negative amount of memory.");
+#endif
+  return internal_realloc_size (mem, (size_t) size);
+}
+
+extern void *internal_realloc64 (void *, GFC_INTEGER_8);
+export_proto(internal_realloc64);
+
+void *
+internal_realloc64 (void *mem, GFC_INTEGER_8 size)
+{
+#ifdef GFC_CHECK_MEMORY
+  /* Under normal circumstances, this is _never_ going to happen!  */
+  if (size < 0)
+    runtime_error ("Attempt to allocate a negative amount of memory.");
+#endif
+  return internal_realloc_size (mem, (size_t) size);
+}
+
 
 /* User-allocate, one call for each member of the alloc-list of an
    ALLOCATE statement. */