[patch] fix PR libfortran/23321

[Thomas Koenig]

On Thu, Aug 18, 2005 at 12:26:43PM +0200, Paul Thomas wrote:
> Thomas,
> 
> The patch looks OK. However, I have a problem with the test-case: Unless 
> the print statement is present, it aborts at the next statement.  I 
> cannot, at the moment, see what the problem is.

Paul,

thanks for the pointer to the failing test case.

The testsuite failure has nothing to do with the patch.
I think there is some cleanup issue with library error returns
(specifically, that ioparm isn't cleaned up the way it is supposed
to be on a library exit error).  This merits its own PR.

I have attached a new test case that doesn't expose this error,
plus made another minor correction.  Regression-tested on 4.1.
OK (plus for 4.0, once regression-testing there passes?).

	Thomas

2005-08-25  Thomas Koenig  <Thomas.Koenig@online.de>

	PR libfortran/23321
	* io/transfer.c(data_transfer_init):  Check for a too-large
	record number.  Return if sseek failed.

2005-08-25  Thomas Koenig  <Thomas.Koenig@online.de>

	PR libfortran/23321
	* gfortran.dg/direct_io_4.f90:  New test case.
-------------- next part --------------
Index: transfer.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.54
diff -c -p -r1.54 transfer.c
*** transfer.c	17 Aug 2005 02:48:57 -0000	1.54
--- transfer.c	25 Aug 2005 21:09:01 -0000
*************** data_transfer_init (int read_flag)
*** 1163,1172 ****
        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);
      }
  
    /* Overwriting an existing sequential file ?
--- 1163,1185 ----
        if (g.mode == READING && current_unit->mode  == WRITING)
  	 flush(current_unit->s);
  
+       /* Check whether the record exists to be read.  Only
+ 	 a partial record needs to exist.  */
+ 
+       if (g.mode == READING && (ioparm.rec -1)
+ 	  * current_unit->recl >= file_length (current_unit->s))
+ 	{
+ 	  generate_error (ERROR_BAD_OPTION, "Non-existing record number");
+ 	  return;
+ 	}
+ 
        /* Position the file.  */
        if (sseek (current_unit->s,
  	       (ioparm.rec - 1) * current_unit->recl) == FAILURE)
! 	{
! 	  generate_error (ERROR_OS, NULL);
! 	  return;
! 	}
      }
  
    /* Overwriting an existing sequential file ?
-------------- next part --------------
! { dg-do run }
! PR 23321 : Running off the end of a file was not detected with direct I/O.
program main
  implicit none
  integer(kind=1) :: a, b
  integer :: ios, i, ios2

  a = 42
  open (unit=10,status="scratch",recl=1,access="direct")
  write(10,rec=1) a

  read (10,rec=2, iostat=ios) b
  if (ios == 0) call abort

  read (10, rec=82641, iostat=ios) b      ! This used to cause a segfault
  if (ios == 0) call abort

  read(10, rec=1, err=100) b
  if (a /= b) call abort
  goto 200
100 continue
  call abort
200 continue 
end program main