[gfortran] patch for pr16597

[Bud Davis]

we were reading back a record before it was physically written to the
disk.

added code to detect a write then read on a given unit, in which case we
flush the unit.

tested i686/gnu/linux FC1. also fixes one NIST F77 test, and transitions
another from "run-time abort" to "fail".


--bud


2004-08-25  Bud Davis  <bdavis9659@comcast.net>

	PR fortran/16597
	* io/io.h (gfc_unit): added mode to unit structure.
	* io/transfer.c (data_transfer_init): flush if a write then
 	read is done on a unit (direct access files).


!pr 16597
      program gfbug4
      implicit none

      integer      strlen
      parameter    (strlen = 4)

      integer      iunit 
      character    string *4

      iunit = 99
      open (UNIT=iunit,FORM='unformatted',ACCESS='direct',RECL=strlen)
      write (iunit, rec=1) 'ABCD'
      read (iunit, rec=1) string
      close (iunit)
      if (string.ne.'ABCD') call abort

      open (UNIT=iunit,FORM='unformatted',ACCESS='direct',
     $      STATUS='scratch',RECL=strlen)
      write (iunit, rec=1) 'ABCD'
      read (iunit, rec=1) string
      close (iunit)
      if (string.ne.'ABCD') call abort
      end

Index: gcc/libgfortran/io/io.h
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/io.h,v
retrieving revision 1.8
diff -c -3 -p -r1.8 io.h
*** gcc/libgfortran/io/io.h	23 Aug 2004 14:28:31 -0000	1.8
--- gcc/libgfortran/io/io.h	26 Aug 2004 02:18:07 -0000
*************** typedef struct gfc_unit
*** 271,276 ****
--- 271,277 ----
    { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
    endfile;
  
+   int mode;
    unit_flags flags;
    gfc_offset recl, last_record, maxrec, bytes_left;
  
Index: gcc/libgfortran/io/transfer.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.12
diff -c -3 -p -r1.12 transfer.c
*** gcc/libgfortran/io/transfer.c	23 Aug 2004 14:28:31 -0000	1.12
--- gcc/libgfortran/io/transfer.c	26 Aug 2004 02:18:07 -0000
*************** data_transfer_init (int read_flag)
*** 1044,1056 ****
  	  return;
  	}
  
!       /* Position the file.  */
  
        if (sseek (current_unit->s,
                 (ioparm.rec - 1) * current_unit->recl) == FAILURE)
  	generate_error (ERROR_OS, NULL);
      }
  
    /* Set the initial value of flags.  */
  
    g.blank_status = current_unit->flags.blank;
--- 1044,1062 ----
  	  return;
  	}
  
!       /* Check to see if we might be reading what we wrote before  */
! 
!       if (g.mode == READING && current_unit->mode  == WRITING)
!          flush(current_unit->s);
  
+       /* Position the file.  */
        if (sseek (current_unit->s,
                 (ioparm.rec - 1) * current_unit->recl) == FAILURE)
  	generate_error (ERROR_OS, NULL);
      }
  
+   current_unit->mode = g.mode;
+ 
    /* Set the initial value of flags.  */
  
    g.blank_status = current_unit->flags.blank;