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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@131742 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 134c0c4..35fd98e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+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

diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 70a4b37..1e12415 100644 (file)
--- a/gcc/fortran/trans-io.c
+++ b/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;
        }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7dcbbcb..31d3953 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/vector_subscript_3.f90 b/gcc/testsuite/gfortran.dg/vector_subscript_3.f90
new file mode 100644 (file)
index 0000000..974ee4b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/vector_subscript_3.f90
@@ -0,0 +1,45 @@
+! { 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
+