From 25d7376aeee486ab6fb19b956ecfe953da8e0ce8 Mon Sep 17 00:00:00 2001 From: pault Date: Tue, 22 Jan 2008 21:22:13 +0000 Subject: [PATCH] 2008-01-22 Paul Thomas 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 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 --- gcc/fortran/ChangeLog | 7 ++++ gcc/fortran/trans-io.c | 26 ++++++++++++-- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/vector_subscript_3.f90 | 45 ++++++++++++++++++++++++ 4 files changed, 80 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/vector_subscript_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 134c0c4e669..35fd98e4158 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2008-01-22 Paul Thomas + + 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 PR fortran/34848 diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 70a4b3781d2..1e124154a4a 100644 --- 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 7dcbbcb768a..31d39534dfa 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2008-01-22 Paul Thomas + + PR fortran/34875 + * gfortran.dg/vector_subscript_3.f90: New test. + 2008-01-22 Tobias Burnus 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 index 00000000000..974ee4be392 --- /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 +! +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 + -- 2.11.4.GIT