This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[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
+ 

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]