This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ptach, fortran] PR34875 - read into vector-valued section doesn't transfer any values
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 22 Jan 2008 20:46:45 +0100
- Subject: [Ptach, fortran] PR34875 - read into vector-valued section doesn't transfer any values
:ADDPATCH fortran:
This patch is not quite obvious but it is self-explanatory.
Bootstraps and regtests on x86_ia64/FC8 - OK for trunk?
Paul
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.
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 131688)
--- gcc/fortran/trans-io.c (working copy)
*************** gfc_trans_transfer (gfc_code * code)
*** 1972,1977 ****
--- 1972,1978 ----
gfc_ss *ss;
gfc_se se;
tree tmp;
+ int n;
gfc_start_block (&block);
gfc_init_block (&body);
*************** gfc_trans_transfer (gfc_code * code)
*** 2004,2012 ****
&& 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);
transfer_array_desc (&se, &expr->ts, tmp);
goto finish_block_label;
}
--- 2005,2032 ----
&& ref && ref->next == NULL
&& !is_subref_array (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;
}
Index: gcc/testsuite/gfortran.dg/vector_subscript_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/vector_subscript_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/vector_subscript_3.f90 (revision 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
+