[gfortran] patch to fix PR 16908, segfault on direct access I/O

[Bud Davis]

This patch corrects the problem in the PR as well as NIST F77 tests
FM917.FOR and FM921.FOR. (and it doesn't break any new NIST F77 tests
either:)
 
we were padding the record with blanks, which is not what g77 does. 

after removing the padding, some testsuite failures showed up which were
caused by the calculation for NEXTREC, fixed by accounting for records
that are not a full reclen long.


Here is a test suite file, which is exactly as submitted with the PR.
This test aborts before and passes after the patch is applied.

! pr 16908
! segfaults on second set of writes
   program synsig
 
   implicit none
 
   integer n, nt, mt, m
   real dt, tm, w
   real, allocatable :: p(:)
 
   nt =  2049 ! if nt < 2049, then everything works.
  
   allocate(p(nt))
   p  = 0.e0
 
   inquire(iolength=mt) (p(m), m=1, nt)
 
   open(unit=12, file='syn.sax', access='direct', recl=mt)
   n = 1
   write(12, rec=n) mt, nt
   write(12, rec=n+1) (p(m), m=1, nt)
   close(12)
 
   inquire(iolength=mt) (p(m), m=1, nt)
 
   open(unit=12, file='syn.sax', access='direct', recl=mt)
   n = 1
   write(12, rec=n) mt, nt
   write(12, rec=n+1) (p(m), m=1, nt)
   close(12)
 
   end program synsig

and a changelog


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

	PR 16908
	* io/transfer.c (next_record_w): Do not blank pad.
	* io/transfer.c (next_record): Take into account partial 	records.
	

tested with no additional test suite failures on gnu/linux/i686 FC1.


--bud





Index: gcc/libgfortran/io/transfer.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.9
diff -c -3 -p -r1.9 transfer.c
*** gcc/libgfortran/io/transfer.c	18 Aug 2004 01:20:06 -0000	1.9
--- gcc/libgfortran/io/transfer.c	21 Aug 2004 04:37:57 -0000
*************** next_record_w (int done)
*** 1223,1242 ****
    switch (current_mode ())
      {
      case FORMATTED_DIRECT:
-     case UNFORMATTED_DIRECT:
        if (current_unit->bytes_left == 0)
  	break;
  
        length = current_unit->bytes_left;
- 
        p = salloc_w (current_unit->s, &length);
        if (p == NULL)
  	goto io_error;
  
        memset (p, ' ', current_unit->bytes_left);
        if (sfree (current_unit->s) == FAILURE)
  	goto io_error;
  
        break;
  
      case UNFORMATTED_SEQUENTIAL:
--- 1223,1245 ----
    switch (current_mode ())
      {
      case FORMATTED_DIRECT:
        if (current_unit->bytes_left == 0)
  	break;
  
        length = current_unit->bytes_left;
        p = salloc_w (current_unit->s, &length);
+ 
        if (p == NULL)
  	goto io_error;
  
        memset (p, ' ', current_unit->bytes_left);
        if (sfree (current_unit->s) == FAILURE)
  	goto io_error;
+       break;
  
+     case UNFORMATTED_DIRECT:
+       if (sfree (current_unit->s) == FAILURE)
+         goto io_error;
        break;
  
      case UNFORMATTED_SEQUENTIAL:
*************** next_record_w (int done)
*** 1304,1309 ****
--- 1307,1313 ----
  void
  next_record (int done)
  {
+   gfc_offset fp; /* file position */
  
    current_unit->read_bad = 0;
  
*************** next_record (int done)
*** 1314,1321 ****
  
    current_unit->current_record = 0;
    if (current_unit->flags.access == ACCESS_DIRECT)
!     current_unit->last_record = file_position (current_unit->s) 
!                                / current_unit->recl;
    else
      current_unit->last_record++;
  
--- 1318,1330 ----
  
    current_unit->current_record = 0;
    if (current_unit->flags.access == ACCESS_DIRECT)
!    {
!     fp = file_position (current_unit->s);
!     current_unit->last_record = fp / current_unit->recl;
!     /* round up if partial */
!     if (fp % current_unit->recl)
!       current_unit->last_record++;
!    }
    else
      current_unit->last_record++;