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-array.c

@@ -361,7 +361,6 @@ gfc_free_ss (gfc_ss * ss)
   switch (ss->type)
     {
     case GFC_SS_SECTION:
-    case GFC_SS_VECTOR:
       for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
 	{
 	  if (ss->data.info.subscript[n])
@@ -1355,6 +1354,47 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
 }
 
 
+/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
+   called after evaluating all of INFO's vector dimensions.  Go through
+   each such vector dimension and see if we can now fill in any missing
+   loop bounds.  */
+
+static void
+gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
+{
+  gfc_se se;
+  tree tmp;
+  tree desc;
+  tree zero;
+  int n;
+  int dim;
+
+  for (n = 0; n < loop->dimen; n++)
+    {
+      dim = info->dim[n];
+      if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
+	  && loop->to[n] == NULL)
+	{
+	  /* Loop variable N indexes vector dimension DIM, and we don't
+	     yet know the upper bound of loop variable N.  Set it to the
+	     difference between the vector's upper and lower bounds.  */
+	  gcc_assert (loop->from[n] == gfc_index_zero_node);
+	  gcc_assert (info->subscript[dim]
+		      && info->subscript[dim]->type == GFC_SS_VECTOR);
+
+	  gfc_init_se (&se, NULL);
+	  desc = info->subscript[dim]->data.info.descriptor;
+	  zero = gfc_rank_cst[0];
+	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_ubound (desc, zero),
+			     gfc_conv_descriptor_lbound (desc, zero));
+	  tmp = gfc_evaluate_now (tmp, &loop->pre);
+	  loop->to[n] = tmp;
+	}
+    }
+}
+
+
 /* 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.  */
@@ -1410,14 +1450,21 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
 	  break;
 
 	case GFC_SS_SECTION:
-	case GFC_SS_VECTOR:
-	  /* Scalarized expression.  Evaluate any scalar subscripts.  */
+	  /* Add the expressions for scalar and vector subscripts.  */
 	  for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
-	    {
-	      /* Add the expressions for scalar subscripts.  */
-	      if (ss->data.info.subscript[n])
-		gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
-	    }
+	    if (ss->data.info.subscript[n])
+	      gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
+
+	  gfc_set_vector_loop_bounds (loop, &ss->data.info);
+	  break;
+
+	case GFC_SS_VECTOR:
+	  /* Get the vector's descriptor and store it in SS.  */
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
+	  gfc_add_block_to_block (&loop->pre, &se.pre);
+	  gfc_add_block_to_block (&loop->post, &se.post);
+	  ss->data.info.descriptor = se.expr;
 	  break;
 
 	case GFC_SS_INTRINSIC:
@@ -1620,41 +1667,6 @@ gfc_conv_array_ubound (tree descriptor, int dim)
 }
 
 
-/* Translate an array reference.  The descriptor should be in se->expr.
-   Do not use this function, it wil be removed soon.  */
-/*GCC ARRAYS*/
-
-static void
-gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
-                         tree offset, int dimen)
-{
-  tree array;
-  tree tmp;
-  tree index;
-  int n;
-
-  array = gfc_build_indirect_ref (pointer);
-
-  index = offset;
-  for (n = 0; n < dimen; n++)
-    {
-      /* index = index + stride[n]*indices[n] */
-      tmp = gfc_conv_array_stride (se->expr, n);
-      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
-
-      index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
-    }
-
-  /* Result = data[index].  */
-  tmp = gfc_build_array_ref (array, index);
-
-  /* Check we've used the correct number of dimensions.  */
-  gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
-
-  se->expr = tmp;
-}
-
-
 /* Generate code to perform an array index bound check.  */
 
 static tree
@@ -1682,61 +1694,6 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
 }
 
 
-/* A reference to an array vector subscript.  Uses recursion to handle nested
-   vector subscripts.  */
-
-static tree
-gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
-{
-  tree descsave;
-  tree indices[GFC_MAX_DIMENSIONS];
-  gfc_array_ref *ar;
-  gfc_ss_info *info;
-  int n;
-
-  gcc_assert (ss && ss->type == GFC_SS_VECTOR);
-
-  /* Save the descriptor.  */
-  descsave = se->expr;
-  info = &ss->data.info;
-  se->expr = info->descriptor;
-
-  ar = &info->ref->u.ar;
-  for (n = 0; n < ar->dimen; n++)
-    {
-      switch (ar->dimen_type[n])
-	{
-	case DIMEN_ELEMENT:
-	  gcc_assert (info->subscript[n] != gfc_ss_terminator
-		  && info->subscript[n]->type == GFC_SS_SCALAR);
-	  indices[n] = info->subscript[n]->data.scalar.expr;
-	  break;
-
-	case DIMEN_RANGE:
-	  indices[n] = index;
-	  break;
-
-	case DIMEN_VECTOR:
-	  index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
-
-	  indices[n] =
-	    gfc_trans_array_bound_check (se, info->descriptor, index, n);
-	  break;
-
-	default:
-	  gcc_unreachable ();
-	}
-    }
-  /* Get the index from the vector.  */
-  gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
-  index = se->expr;
-  /* Put the descriptor back.  */
-  se->expr = descsave;
-
-  return index;
-}
-
-
 /* Return the offset for an index.  Performs bound checking for elemental
    dimensions.  Single element references are processed separately.  */
 
@@ -1745,25 +1702,52 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
 			     gfc_array_ref * ar, tree stride)
 {
   tree index;
+  tree desc;
+  tree data;
 
   /* Get the index into the array for this dimension.  */
   if (ar)
     {
       gcc_assert (ar->type != AR_ELEMENT);
-      if (ar->dimen_type[dim] == DIMEN_ELEMENT)
+      switch (ar->dimen_type[dim])
 	{
+	case DIMEN_ELEMENT:
 	  gcc_assert (i == -1);
 	  /* Elemental dimension.  */
 	  gcc_assert (info->subscript[dim]
-		  && info->subscript[dim]->type == GFC_SS_SCALAR);
+		      && info->subscript[dim]->type == GFC_SS_SCALAR);
 	  /* We've already translated this value outside the loop.  */
 	  index = info->subscript[dim]->data.scalar.expr;
 
 	  index =
 	    gfc_trans_array_bound_check (se, info->descriptor, index, dim);
-	}
-      else
-	{
+	  break;
+
+	case DIMEN_VECTOR:
+	  gcc_assert (info && se->loop);
+	  gcc_assert (info->subscript[dim]
+		      && info->subscript[dim]->type == GFC_SS_VECTOR);
+	  desc = info->subscript[dim]->data.info.descriptor;
+
+	  /* Get a zero-based index into the vector.  */
+	  index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			       se->loop->loopvar[i], se->loop->from[i]);
+
+	  /* Multiply the index by the stride.  */
+	  index = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			       index, gfc_conv_array_stride (desc, 0));
+
+	  /* Read the vector to get an index into info->descriptor.  */
+	  data = gfc_build_indirect_ref (gfc_conv_array_data (desc));
+	  index = gfc_build_array_ref (data, index);
+	  index = gfc_evaluate_now (index, &se->pre);
+
+	  /* Do any bounds checking on the final info->descriptor index.  */
+	  index = gfc_trans_array_bound_check (se, info->descriptor,
+					       index, dim);
+	  break;
+
+	case DIMEN_RANGE:
 	  /* Scalarized dimension.  */
 	  gcc_assert (info && se->loop);
 
@@ -1773,18 +1757,10 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
 			       info->stride[i]);
 	  index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
 			       info->delta[i]);
+	  break;
 
-	  if (ar->dimen_type[dim] == DIMEN_VECTOR)
-	    {
-              /* Handle vector subscripts.  */
-	      index = gfc_conv_vector_array_index (se, index,
-						   info->subscript[dim]);
-	      index =
-		gfc_trans_array_bound_check (se, info->descriptor, index,
-					     dim);
-	    }
-	  else
-	    gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
+	default:
+	  gcc_unreachable ();
 	}
     }
   else
@@ -2195,27 +2171,25 @@ static tree
 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
 {
   int dim;
-  gfc_ss *vecss;
   gfc_expr *end;
   tree desc;
   tree bound;
   gfc_se se;
+  gfc_ss_info *info;
 
   gcc_assert (ss->type == GFC_SS_SECTION);
 
-  /* For vector array subscripts we want the size of the vector.  */
-  dim = ss->data.info.dim[n];
-  vecss = ss;
-  while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
-    {
-      vecss = vecss->data.info.subscript[dim];
-      gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
-      dim = vecss->data.info.dim[0];
-    }
+  info = &ss->data.info;
+  dim = info->dim[n];
 
-  gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
-  end = vecss->data.info.ref->u.ar.end[dim];
-  desc = vecss->data.info.descriptor;
+  if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+    /* We'll calculate the upper bound once we have access to the
+       vector's descriptor.  */
+    return NULL;
+
+  gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
+  desc = info->descriptor;
+  end = info->ref->u.ar.end[dim];
 
   if (end)
     {
@@ -2242,32 +2216,28 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
 {
   gfc_expr *start;
   gfc_expr *stride;
-  gfc_ss *vecss;
   tree desc;
   gfc_se se;
   gfc_ss_info *info;
   int dim;
 
-  info = &ss->data.info;
+  gcc_assert (ss->type == GFC_SS_SECTION);
 
+  info = &ss->data.info;
   dim = info->dim[n];
 
-  /* For vector array subscripts we want the size of the vector.  */
-  vecss = ss;
-  while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+  if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
     {
-      vecss = vecss->data.info.subscript[dim];
-      gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
-      /* Get the descriptors for the vector subscripts as well.  */
-      if (!vecss->data.info.descriptor)
-	gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
-      dim = vecss->data.info.dim[0];
+      /* We use a zero-based index to access the vector.  */
+      info->start[n] = gfc_index_zero_node;
+      info->stride[n] = gfc_index_one_node;
+      return;
     }
 
-  gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
-  start = vecss->data.info.ref->u.ar.start[dim];
-  stride = vecss->data.info.ref->u.ar.stride[dim];
-  desc = vecss->data.info.descriptor;
+  gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
+  desc = info->descriptor;
+  start = info->ref->u.ar.start[dim];
+  stride = info->ref->u.ar.stride[dim];
 
   /* Calculate the start of the range.  For vector subscripts this will
      be the range of the vector.  */
@@ -2309,7 +2279,6 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
   int n;
   tree tmp;
   gfc_ss *ss;
-  gfc_ss *vecss;
   tree desc;
 
   loop->dimen = 0;
@@ -2390,22 +2359,15 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	  /* TODO: range checking for mapped dimensions.  */
 	  info = &ss->data.info;
 
-	  /* This only checks scalarized dimensions, elemental dimensions are
-	     checked later.  */
+	  /* This code only checks ranges.  Elemental and vector
+	     dimensions are checked later.  */
 	  for (n = 0; n < loop->dimen; n++)
 	    {
 	      dim = info->dim[n];
-	      vecss = ss;
-	      while (vecss->data.info.ref->u.ar.dimen_type[dim]
-		     == DIMEN_VECTOR)
-		{
-		  vecss = vecss->data.info.subscript[dim];
-		  gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
-		  dim = vecss->data.info.dim[0];
-		}
-	      gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
-		      == DIMEN_RANGE);
-	      desc = vecss->data.info.descriptor;
+	      if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
+		continue;
+
+	      desc = ss->data.info.descriptor;
 
 	      /* Check lower bound.  */
 	      bound = gfc_conv_array_lbound (desc, dim);
@@ -3662,11 +3624,28 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 }
 
 
-/* Convert an array for passing as an actual parameter.  Expressions and
+/* Convert an array for passing as an actual argument.  Expressions and
    vector subscripts are evaluated and stored in a temporary, which is then
    passed.  For whole arrays the descriptor is passed.  For array sections
    a modified copy of the descriptor is passed, but using the original data.
-   Also used for array pointer assignments by setting se->direct_byref.  */
+
+   This function is also used for array pointer assignments, and there
+   are three cases:
+
+     - want_pointer && !se->direct_byref
+	 EXPR is an actual argument.  On exit, se->expr contains a
+	 pointer to the array descriptor.
+
+     - !want_pointer && !se->direct_byref
+	 EXPR is an actual argument to an intrinsic function or the
+	 left-hand side of a pointer assignment.  On exit, se->expr
+	 contains the descriptor for EXPR.
+
+     - !want_pointer && se->direct_byref
+	 EXPR is the right-hand side of a pointer assignment and
+	 se->expr is the descriptor for the previously-evaluated
+	 left-hand side.  The function creates an assignment from
+	 EXPR to se->expr.  */
 
 void
 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
@@ -3682,7 +3661,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
   tree start;
   tree offset;
   int full;
-  gfc_ss *vss;
   gfc_ref *ref;
 
   gcc_assert (ss != gfc_ss_terminator);
@@ -3701,21 +3679,16 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	secss = secss->next;
 
       gcc_assert (secss != gfc_ss_terminator);
-
-      need_tmp = 0;
-      for (n = 0; n < secss->data.info.dimen; n++)
-	{
-	  vss = secss->data.info.subscript[secss->data.info.dim[n]];
-	  if (vss && vss->type == GFC_SS_VECTOR)
-	    need_tmp = 1;
-	}
-
       info = &secss->data.info;
 
       /* Get the descriptor for the array.  */
       gfc_conv_ss_descriptor (&se->pre, secss, 0);
       desc = info->descriptor;
-      if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+
+      need_tmp = gfc_ref_needs_temporary_p (expr->ref);
+      if (need_tmp)
+	full = 0;
+      else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
 	{
 	  /* Create a new descriptor if the array doesn't have one.  */
 	  full = 0;
@@ -3745,23 +3718,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	    }
 	}
 
-      /* Check for substring references.  */
-      ref = expr->ref;
-      if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
-	{
-	  while (ref->next)
-	    ref = ref->next;
-	  if (ref->type == REF_SUBSTRING)
-	    {
-	      /* In general character substrings need a copy.  Character
-		 array strides are expressed as multiples of the element
-		 size (consistent with other array types), not in
-		 characters.  */
-	      full = 0;
-	      need_tmp = 1;
-	    }
-	}
-
       if (full)
 	{
 	  if (se->direct_byref)
@@ -3841,7 +3797,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
   if (!need_tmp)
     loop.array_parameter = 1;
   else
-    gcc_assert (se->want_pointer && !se->direct_byref);
+    /* The right-hand side of a pointer assignment mustn't use a temporary.  */
+    gcc_assert (!se->direct_byref);
 
   /* Setup the scalarizing loops and bounds.  */
   gfc_conv_ss_startstride (&loop);
@@ -3922,17 +3879,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
 
       gcc_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;
     }
@@ -4083,15 +4034,16 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	  tmp = gfc_conv_descriptor_offset (parm);
 	  gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
 	}
+      desc = parm;
+    }
 
-      if (!se->direct_byref)
-	{
-	  /* Get a pointer to the new descriptor.  */
-          if (se->want_pointer)
-	    se->expr = gfc_build_addr_expr (NULL, parm);
-          else
-            se->expr = parm;
-	}
+  if (!se->direct_byref)
+    {
+      /* Get a pointer to the new descriptor.  */
+      if (se->want_pointer)
+	se->expr = gfc_build_addr_expr (NULL, desc);
+      else
+	se->expr = desc;
     }
 
   gfc_add_block_to_block (&se->pre, &loop.pre);
@@ -4383,24 +4335,14 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
 		  break;
 
 		case DIMEN_VECTOR:
-		  /* Get a SS for the vector.  This will not be added to the
-		     chain directly.  */
-		  indexss = gfc_walk_expr (ar->start[n]);
-		  if (indexss == gfc_ss_terminator)
-		    internal_error ("scalar vector subscript???");
-
-                  /* We currently only handle really simple vector
-                     subscripts.  */
-		  if (indexss->next != gfc_ss_terminator)
-		    gfc_todo_error ("vector subscript expressions");
-		  indexss->loop_chain = gfc_ss_terminator;
-
-		  /* Mark this as a vector subscript.  We don't add this
-                     directly into the chain, but as a subscript of the
-                     existing SS for this term.  */
+		  /* Create a GFC_SS_VECTOR index in which we can store
+		     the vector's descriptor.  */
+		  indexss = gfc_get_ss ();
 		  indexss->type = GFC_SS_VECTOR;
+		  indexss->expr = ar->start[n];
+		  indexss->next = gfc_ss_terminator;
+		  indexss->loop_chain = gfc_ss_terminator;
 		  newss->data.info.subscript[n] = indexss;
-                  /* Also remember this dimension.  */
 		  newss->data.info.dim[newss->data.info.dimen] = n;
 		  newss->data.info.dimen++;
 		  break;

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