re PR fortran/34875 (read into vector-valued section doesn't transfer any values)

2008-01-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34875
	* trans-io.c (gfc_trans_transfer): If the array reference in a
	read has a vector subscript, use gfc_conv_subref_array_arg to
	copy back the temporary.

2008-01-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34875
	* gfortran.dg/vector_subscript_3.f90: New test.

From-SVN: r131742

gcc/fortran/ChangeLog

+2008-01-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34875
+	* trans-io.c (gfc_trans_transfer): If the array reference in a
+	read has a vector subscript, use gfc_conv_subref_array_arg to
+	copy back the temporary.
+
 2008-01-22  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34848

gcc/fortran/trans-io.c

@@ -1972,6 +1972,7 @@ gfc_trans_transfer (gfc_code * code)
   gfc_ss *ss;
   gfc_se se;
   tree tmp;
+  int n;
 
   gfc_start_block (&block);
   gfc_init_block (&body);
@@ -2004,9 +2005,28 @@ gfc_trans_transfer (gfc_code * code)
 	    && ref && ref->next == NULL
 	    && !is_subref_array (expr))
 	{
-	  /* Get the descriptor.  */
-	  gfc_conv_expr_descriptor (&se, expr, ss);
-	  tmp = build_fold_addr_expr (se.expr);
+	  bool seen_vector = false;
+
+	  if (ref && ref->u.ar.type == AR_SECTION)
+	    {
+	      for (n = 0; n < ref->u.ar.dimen; n++)
+		if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+		  seen_vector = true;
+	    }
+
+	  if (seen_vector && last_dt == READ)
+	    {
+	      /* Create a temp, read to that and copy it back.  */
+	      gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT);
+	      tmp =  se.expr;
+	    }
+	  else
+	    {
+	      /* Get the descriptor.  */
+	      gfc_conv_expr_descriptor (&se, expr, ss);
+	      tmp = build_fold_addr_expr (se.expr);
+	    }
+
 	  transfer_array_desc (&se, &expr->ts, tmp);
 	  goto finish_block_label;
 	}

gcc/testsuite/ChangeLog

+2008-01-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34875
+	* gfortran.dg/vector_subscript_3.f90: New test.
+
 2008-01-22  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34848

gcc/testsuite/gfortran.dg/vector_subscript_3.f90

+! { dg-do run }
+!
+! Test the fix for PR34875, in which the read with a vector index
+! used to do nothing.
+!
+! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+!
+Program QH0008
+
+  REAL(4) QDA(10)
+  REAL(4) QDA1(10)
+! Scramble the vector up a bit to make the test more interesting
+  integer, dimension(10) ::  nfv1 = (/9,2,1,3,5,4,6,8,7,10/)
+! Set qda1 in ordinal order
+  qda1(nfv1) = nfv1
+  qda = -100
+  OPEN (UNIT = 47,                &
+        STATUS = 'SCRATCH',       &
+        FORM = 'UNFORMATTED',     &
+        ACTION = 'READWRITE')
+  ISTAT = -314
+  REWIND (47, IOSTAT = ISTAT)
+  IF (ISTAT .NE. 0) call abort ()
+  ISTAT = -314
+! write qda1
+  WRITE (47,IOSTAT = ISTAT) QDA1
+  IF (ISTAT .NE. 0) call abort ()
+  ISTAT = -314
+  REWIND (47, IOSTAT = ISTAT)
+  IF (ISTAT .NE. 0) call abort ()
+! Do the vector index read that used to fail
+  READ (47,IOSTAT = ISTAT) QDA(NFV1)
+  IF (ISTAT .NE. 0) call abort ()
+! Unscramble qda using the vector index
+  IF (ANY (QDA(nfv1) .ne. QDA1) ) print *, qda, qda1
+  ISTAT = -314
+  REWIND (47, IOSTAT = ISTAT)
+  IF (ISTAT .NE. 0) call abort ()
+  qda = -200
+! Do the subscript read that was OK
+  READ (47,IOSTAT = ISTAT) QDA(1:10)
+  IF (ISTAT .NE. 0) call abort ()
+  IF (ANY (QDA .ne. QDA1) ) call abort ()
+END
+