procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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
This commit is contained in:
Paul Thomas 2008-01-22 21:22:13 +00:00
parent 1a23970d0e
commit c63173ddb0
4 changed files with 80 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View file

@ -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

26
gcc/fortran/trans-io.c
View file

@ -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;
}

5
gcc/testsuite/ChangeLog
View file

@ -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

45
gcc/testsuite/gfortran.dg/vector_subscript_3.f90 Normal file
View file

@ -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