re PR fortran/19239 ([4.0 only] gfortran ICE on vector subscript expressions)

	PR fortran/19239
	* Makefile.in (fortran/trans-expr.o): Depend on dependency.h.
	* dependency.h (gfc_ref_needs_temporary_p): Declare.
	* dependency.c (gfc_ref_needs_temporary_p): New function.
	(gfc_check_fncall_dependency): Use it instead of inlined check.
	By so doing, take advantage of the fact that character substrings
	within an array reference also need a temporary.
	* trans.h (GFC_SS_VECTOR): Adjust comment.
	* trans-array.c (gfc_free_ss): Remove GFC_SS_VECTOR case.
	(gfc_set_vector_loop_bounds): New function.
	(gfc_add_loop_ss_code): Call it after evaluating the subscripts of
	a GFC_SS_SECTION.  Deal with the GFC_SS_VECTOR case by evaluating
	the vector expression and caching its descriptor for use within
	the loop.
	(gfc_conv_array_index_ref, gfc_conv_vector_array_index): Delete.
	(gfc_conv_array_index_offset): Handle scalar, vector and range
	dimensions as separate cases of a switch statement.  In the vector
	case, use the loop variable to calculate a vector index and use the
	referenced element as the dimension's index.  Perform bounds checking
	on this final index.
	(gfc_conv_section_upper_bound): Return null for vector indexes.
	(gfc_conv_section_startstride): Give vector indexes a start value
	of 0 and a stride of 1.
	(gfc_conv_ss_startstride): Adjust for new GFC_SS_VECTOR representation.
	(gfc_conv_expr_descriptor): Expand comments.  Generalize the
	handling of the !want_pointer && !direct_byref case.  Use
	gfc_ref_needs_temporary_p to decide whether the variable case
	needs a temporary.
	(gfc_walk_variable_expr): Handle DIMEN_VECTOR by creating a
	GFC_SS_VECTOR index.
	* trans-expr.c: Include dependency.h.
	(gfc_trans_arrayfunc_assign): Fail if the target needs a temporary.

2005-09-09  Richard Sandiford  <richard@codesourcery.com>

	PR fortran/21104
	* trans.h (gfc_interface_sym_mapping, gfc_interface_mapping): Moved
	from trans-expr.c.
	(gfc_init_interface_mapping, gfc_free_interface_mapping)
	(gfc_add_interface_mapping, gfc_finish_interface_mapping)
	(gfc_apply_interface_mapping): Declare.
	* trans-array.h (gfc_set_loop_bounds_from_array_spec): Declare.
	(gfc_trans_allocate_temp_array): Add pre and post block arguments.
	* trans-array.c (gfc_set_loop_bounds_from_array_spec): New function.
	(gfc_trans_allocate_array_storage): Replace loop argument with
	separate pre and post blocks.
	(gfc_trans_allocate_temp_array): Add pre and post block arguments.
	Update call to gfc_trans_allocate_array_storage.
	(gfc_trans_array_constructor, gfc_conv_loop_setup): Adjust for new
	interface to gfc_trans_allocate_temp_array.
	* trans-expr.c (gfc_interface_sym_mapping, gfc_interface_mapping):
	Moved to trans.h.
	(gfc_init_interface_mapping, gfc_free_interface_mapping)
	(gfc_add_interface_mapping, gfc_finish_interface_mapping)
	(gfc_apply_interface_mapping): Make extern.
	(gfc_conv_function_call): Build an interface mapping for array
	return values too.  Call gfc_set_loop_bounds_from_array_spec.
	Adjust call to gfc_trans_allocate_temp_array so that code is
	added to SE rather than LOOP.

From-SVN: r104077

gcc/fortran/ChangeLog

 2005-09-09  Richard Sandiford  <richard@codesourcery.com>
 
+	PR fortran/19239
+	* Makefile.in (fortran/trans-expr.o): Depend on dependency.h.
+	* dependency.h (gfc_ref_needs_temporary_p): Declare.
+	* dependency.c (gfc_ref_needs_temporary_p): New function.
+	(gfc_check_fncall_dependency): Use it instead of inlined check.
+	By so doing, take advantage of the fact that character substrings
+	within an array reference also need a temporary.
+	* trans.h (GFC_SS_VECTOR): Adjust comment.
+	* trans-array.c (gfc_free_ss): Remove GFC_SS_VECTOR case.
+	(gfc_set_vector_loop_bounds): New function.
+	(gfc_add_loop_ss_code): Call it after evaluating the subscripts of
+	a GFC_SS_SECTION.  Deal with the GFC_SS_VECTOR case by evaluating
+	the vector expression and caching its descriptor for use within
+	the loop.
+	(gfc_conv_array_index_ref, gfc_conv_vector_array_index): Delete.
+	(gfc_conv_array_index_offset): Handle scalar, vector and range
+	dimensions as separate cases of a switch statement.  In the vector
+	case, use the loop variable to calculate a vector index and use the
+	referenced element as the dimension's index.  Perform bounds checking
+	on this final index.
+	(gfc_conv_section_upper_bound): Return null for vector indexes.
+	(gfc_conv_section_startstride): Give vector indexes a start value
+	of 0 and a stride of 1.
+	(gfc_conv_ss_startstride): Adjust for new GFC_SS_VECTOR representation.
+	(gfc_conv_expr_descriptor): Expand comments.  Generalize the
+	handling of the !want_pointer && !direct_byref case.  Use
+	gfc_ref_needs_temporary_p to decide whether the variable case
+	needs a temporary.
+	(gfc_walk_variable_expr): Handle DIMEN_VECTOR by creating a
+	GFC_SS_VECTOR index.
+	* trans-expr.c: Include dependency.h.
+	(gfc_trans_arrayfunc_assign): Fail if the target needs a temporary.
+
+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
 	PR fortran/21104
 	* trans.h (gfc_interface_sym_mapping, gfc_interface_mapping): Moved
 	from trans-expr.c.

gcc/fortran/Make-lang.in

@@ -289,7 +289,7 @@ fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \
 fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
   real.h toplev.h $(TARGET_H)
 fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
-fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS)
+fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
 fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS)
 fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h
 fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)

gcc/fortran/dependency.c

@@ -175,6 +175,45 @@ gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
 }
 
 
+/* Return true if the result of reference REF can only be constructed
+   using a temporary array.  */
+
+bool
+gfc_ref_needs_temporary_p (gfc_ref *ref)
+{
+  int n;
+  bool subarray_p;
+
+  subarray_p = false;
+  for (; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+	/* Vector dimensions are generally not monotonic and must be
+	   handled using a temporary.  */
+	if (ref->u.ar.type == AR_SECTION)
+	  for (n = 0; n < ref->u.ar.dimen; n++)
+	    if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+	      return true;
+
+	subarray_p = true;
+	break;
+
+      case REF_SUBSTRING:
+	/* Within an array reference, character substrings generally
+	   need a temporary.  Character array strides are expressed as
+	   multiples of the element size (consistent with other array
+	   types), not in characters.  */
+	return subarray_p;
+
+      case REF_COMPONENT:
+	break;
+      }
+
+  return false;
+}
+
+
 /* Dependency checking for direct function return by reference.
    Returns true if the arguments of the function depend on the
    destination.  This is considerably less conservative than other
@@ -185,9 +224,7 @@ int
 gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall)
 {
   gfc_actual_arglist *actual;
-  gfc_ref *ref;
   gfc_expr *expr;
-  int n;
 
   gcc_assert (dest->expr_type == EXPR_VARIABLE
 	  && fncall->expr_type == EXPR_FUNCTION);
@@ -205,31 +242,8 @@ gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall)
       switch (expr->expr_type)
 	{
 	case EXPR_VARIABLE:
-	  if (expr->rank > 1)
-	    {
-	      /* This is an array section.  */
-	      for (ref = expr->ref; ref; ref = ref->next)
-		{
-		  if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
-		    break;
-		}
-	      gcc_assert (ref);
-	      /* AR_FULL can't contain vector subscripts.  */
-	      if (ref->u.ar.type == AR_SECTION)
-		{
-		  for (n = 0; n < ref->u.ar.dimen; n++)
-		    {
-		      if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
-			break;
-		    }
-		  /* Vector subscript array sections will be copied to a
-		     temporary.  */
-		  if (n != ref->u.ar.dimen)
-		    continue;
-		}
-	    }
-
-	  if (gfc_check_dependency (dest, actual->expr, NULL, 0))
+	  if (!gfc_ref_needs_temporary_p (expr->ref)
+	      && gfc_check_dependency (dest, expr, NULL, 0))
 	    return 1;
 	  break;
 

gcc/fortran/dependency.h

@@ -21,6 +21,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 
 
 
+bool gfc_ref_needs_temporary_p (gfc_ref *);
 int gfc_check_fncall_dependency (gfc_expr *, gfc_expr *);
 int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
 int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int);

gcc/fortran/trans-expr.c

@@ -39,6 +39,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "trans-array.h"
 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
 #include "trans-stmt.h"
+#include "dependency.h"
 
 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
@@ -2575,6 +2576,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   if (expr2->symtree->n.sym->attr.elemental)
     return NULL;
 
+  /* Fail if EXPR1 can't be expressed as a descriptor.  */
+  if (gfc_ref_needs_temporary_p (expr1->ref))
+    return NULL;
+
   /* Check for a dependency.  */
   if (gfc_check_fncall_dependency (expr1, expr2))
     return NULL;

gcc/fortran/trans.h

@@ -138,8 +138,8 @@ typedef enum
      uses this temporary inside the scalarization loop.  */
   GFC_SS_CONSTRUCTOR,
 
-  /* A vector subscript.  Only used as the SS chain for a subscript.
-     Similar int format to a GFC_SS_SECTION.  */
+  /* A vector subscript.  The vector's descriptor is cached in the
+     "descriptor" field of the associated gfc_ss_info.  */
   GFC_SS_VECTOR,
 
   /* A temporary array allocated by the scalarizer.  Its rank can be less

gcc/testsuite/ChangeLog

 2005-09-09  Richard Sandiford  <richard@codesourcery.com>
 
+	PR fortran/19239
+	* gfortran.fortran-torture/execute/pr19239-1.f90,
+	* gfortran.fortran-torture/execute/pr19239-2.f90: New tests
+
+2005-09-09  Richard Sandiford  <richard@codesourcery.com>
+
 	PR fortran/21104
 	* gfortran.dg/array_alloc_1.f90,
 	* gfortran.dg/array_alloc_2.f90,

gcc/testsuite/gfortran.dg/vector_subscript_1.f90

+! PR 19239.  Check for various kinds of vector subscript.  In this test,
+! all vector subscripts are indexing single-dimensional arrays.
+! { dg-do run }
+program main
+  implicit none
+  integer, parameter :: n = 10
+  integer :: i, j, calls
+  integer, dimension (n) :: a, b, idx, id
+
+  idx = (/ 3, 1, 5, 2, 4, 10, 8, 7, 6, 9 /)
+  id = (/ (i, i = 1, n) /)
+  b = (/ (i * 100, i = 1, n) /)
+
+  !------------------------------------------------------------------
+  ! Tests for a simple variable subscript
+  !------------------------------------------------------------------
+
+  a (idx) = b
+  call test (idx, id)
+
+  a = b (idx)
+  call test (id, idx)
+
+  a (idx) = b (idx)
+  call test (idx, idx)
+
+  !------------------------------------------------------------------
+  ! Tests for constant ranges with non-default stride
+  !------------------------------------------------------------------
+
+  a (idx (1:7:3)) = b (10:6:-2)
+  call test (idx (1:7:3), id (10:6:-2))
+
+  a (10:6:-2) = b (idx (1:7:3))
+  call test (id (10:6:-2), idx (1:7:3))
+
+  a (idx (1:7:3)) = b (idx (1:7:3))
+  call test (idx (1:7:3), idx (1:7:3))
+
+  a (idx (1:7:3)) = b (idx (10:6:-2))
+  call test (idx (1:7:3), idx (10:6:-2))
+
+  a (idx (10:6:-2)) = b (idx (10:6:-2))
+  call test (idx (10:6:-2), idx (10:6:-2))
+
+  a (idx (10:6:-2)) = b (idx (1:7:3))
+  call test (idx (10:6:-2), idx (1:7:3))
+
+  !------------------------------------------------------------------
+  ! Tests for subscripts of the form CONSTRANGE + CONST
+  !------------------------------------------------------------------
+
+  a (idx (1:5) + 1) = b (1:5)
+  call test (idx (1:5) + 1, id (1:5))
+
+  a (1:5) = b (idx (1:5) + 1)
+  call test (id (1:5), idx (1:5) + 1)
+
+  a (idx (6:10) - 1) = b (idx (1:5) + 1)
+  call test (idx (6:10) - 1, idx (1:5) + 1)
+
+  !------------------------------------------------------------------
+  ! Tests for variable subranges
+  !------------------------------------------------------------------
+
+  do j = 5, 10
+    a (idx (2:j:2)) = b (3:2+j/2)
+    call test (idx (2:j:2), id (3:2+j/2))
+
+    a (3:2+j/2) = b (idx (2:j:2))
+    call test (id (3:2+j/2), idx (2:j:2))
+
+    a (idx (2:j:2)) = b (idx (2:j:2))
+    call test (idx (2:j:2), idx (2:j:2))
+  end do
+
+  !------------------------------------------------------------------
+  ! Tests for function vectors
+  !------------------------------------------------------------------
+
+  calls = 0
+
+  a (foo (5, calls)) = b (2:10:2)
+  call test (foo (5, calls), id (2:10:2))
+
+  a (2:10:2) = b (foo (5, calls))
+  call test (id (2:10:2), foo (5, calls))
+
+  a (foo (5, calls)) = b (foo (5, calls))
+  call test (foo (5, calls), foo (5, calls))
+
+  if (calls .ne. 8) call abort
+
+  !------------------------------------------------------------------
+  ! Tests for constant vector constructors
+  !------------------------------------------------------------------
+
+  a ((/ 1, 5, 3, 9 /)) = b (1:4)
+  call test ((/ 1, 5, 3, 9 /), id (1:4))
+
+  a (1:4) = b ((/ 1, 5, 3, 9 /))
+  call test (id (1:4), (/ 1, 5, 3, 9 /))
+
+  a ((/ 1, 5, 3, 9 /)) = b ((/ 2, 5, 3, 7 /))
+  call test ((/ 1, 5, 3, 9 /), (/ 2, 5, 3, 7 /))
+
+  !------------------------------------------------------------------
+  ! Tests for variable vector constructors
+  !------------------------------------------------------------------
+
+  do j = 1, 5
+    a ((/ 1, (i + 3, i = 2, j) /)) = b (1:j)
+    call test ((/ 1, (i + 3, i = 2, j) /), id (1:j))
+
+    a (1:j) = b ((/ 1, (i + 3, i = 2, j) /))
+    call test (id (1:j), (/ 1, (i + 3, i = 2, j) /))
+
+    a ((/ 1, (i + 3, i = 2, j) /)) = b ((/ 8, (i + 2, i = 2, j) /))
+    call test ((/ 1, (i + 3, i = 2, j) /), (/ 8, (i + 2, i = 2, j) /))
+  end do
+
+  !------------------------------------------------------------------
+  ! Tests in which the vector dimension is partnered by a temporary
+  !------------------------------------------------------------------
+
+  calls = 0
+  a (idx (1:6)) = foo (6, calls)
+  if (calls .ne. 1) call abort
+  do i = 1, 6
+    if (a (idx (i)) .ne. i + 3) call abort
+  end do
+  a = 0
+
+  calls = 0
+  a (idx (1:6)) = foo (6, calls) * 100
+  if (calls .ne. 1) call abort
+  do i = 1, 6
+    if (a (idx (i)) .ne. (i + 3) * 100) call abort
+  end do
+  a = 0
+
+  a (idx) = id + 100
+  do i = 1, n
+    if (a (idx (i)) .ne. i + 100) call abort
+  end do
+  a = 0
+
+  a (idx (1:10:3)) = (/ 20, 10, 9, 11 /)
+  if (a (idx (1)) .ne. 20) call abort
+  if (a (idx (4)) .ne. 10) call abort
+  if (a (idx (7)) .ne. 9) call abort
+  if (a (idx (10)) .ne. 11) call abort
+  a = 0
+
+contains
+  subroutine test (lhs, rhs)
+    integer, dimension (:) :: lhs, rhs
+    integer :: i
+
+    if (size (lhs, 1) .ne. size (rhs, 1)) call abort
+    do i = 1, size (lhs, 1)
+      if (a (lhs (i)) .ne. b (rhs (i))) call abort
+    end do
+    a = 0
+  end subroutine test
+
+  function foo (n, calls)
+    integer :: i, n, calls
+    integer, dimension (n) :: foo
+
+    calls = calls + 1
+    foo = (/ (i + 3, i = 1, n) /)
+  end function foo
+end program main

gcc/testsuite/gfortran.dg/vector_subscript_2.f90

+! Like vector_subscript_1.f90, but check subscripts in multi-dimensional
+! arrays.
+! { dg-do run }
+program main
+  implicit none
+  integer, parameter :: n = 5
+  integer :: i1, i2, i3
+  integer, dimension (n, n, n) :: a, b
+  integer, dimension (n) :: idx, id
+
+  idx = (/ 3, 1, 5, 2, 4 /)
+  id = (/ (i1, i1 = 1, n) /)
+  forall (i1 = 1:n, i2 = 1:n, i3 = 1:n)
+    b (i1, i2, i3) = i1 + i2 * 10 + i3 * 100
+  end forall
+
+  i1 = 5
+  a (foo (i1), 1, :) = b (2, :, foo (i1))
+  do i1 = 1, 5
+    do i2 = 1, 5
+      if (a (idx (i1), 1, i2) .ne. b (2, i1, idx (i2))) call abort
+    end do
+  end do
+  a = 0
+
+  a (1, idx (1:4), 2:4) = b (2:5, idx (3:5), 2)
+  do i1 = 1, 4
+    do i2 = 1, 3
+      if (a (1, idx (i1), 1 + i2) .ne. b (1 + i1, idx (i2 + 2), 2)) call abort
+    end do
+  end do
+  a = 0
+contains
+  function foo (n)
+    integer :: n
+    integer, dimension (n) :: foo
+    foo = idx (1:n)
+  end function foo
+end program main