re PR libfortran/15472 (implicit open for unformatted file causes run-time error)

2004-07-04  Bud Davis  <bdavis9659@comcast.net>
            Paul Brook  <paul@codesourcery.com>

        PR fortran/15472
        * io/transfer.c(us_write): set recl for seq unform writes to max size.
        * io/transfer.c(data_transfer_init): handle un-opened seq unform unit.
        * io/unix.c(fd_alloc_w_at): handle requests at start, fd_flush at
          right time.
        * io/unix.c(is_seekable): set based upon the file/device, not the
          method being used to access it (fd or mmap).
        * io/unix.c(fd_flush): don't set file_size if !seekable.
        * io/unix.c(fd_truncate: ditto.
        * gfortran.fortran-torture/execute/seq_io.f90: New test.

Co-Authored-By: Paul Brook <paul@codesourcery.com>

From-SVN: r84104

gcc/testsuite/ChangeLog

@@ -1,3 +1,7 @@
+2004-07-04  Bud Davis  <bdavis9659@comcast.net>
+
+	* gfortran.fortran-torture/execute/seq_io.f90: New test.
+
 2004-07-04  Neil Booth  <neil@duron.akihabara.co.uk>
 
 	* gcc.dg/cpp/if-mop.c: Two new testcases.

gcc/testsuite/gfortran.fortran-torture/execute/seq_io.f90

@@ -0,0 +1,81 @@
+! pr 15472
+! sequential access files
+!
+!  this test verifies the most basic sequential unformatted I/O
+!      write 3 records of various sizes
+!      then read them back
+!      and compare with what was written
+!
+       implicit none
+       integer size
+       parameter(size=100)
+       logical debug 
+       data debug /.FALSE./
+! set debug to true for help in debugging failures.
+       integer m(2)
+       integer n
+       real*4 r(size)
+       integer i
+       m(1) = Z'11111111'
+       m(2) = Z'22222222'
+       n    = Z'33333333'
+       do i = 1,size
+         r(i) = i
+       end do
+       write(9)m  ! an array of 2
+       write(9)n  ! an integer
+       write(9)r  ! an array of reals
+! zero all the results so we can compare after they are read back
+       do i = 1,size
+          r(i) = 0
+       end do
+       m(1) = 0
+       m(2) = 0
+       n = 0
+
+       rewind(9)
+       read(9)m
+       read(9)n
+       read(9)r
+!
+! check results
+       if (m(1).ne.Z'11111111') then
+         if (debug) then
+            print '(A,Z8)','m(1) incorrect.  m(1) = ',m(1)
+         else
+            call abort
+         endif
+       endif
+
+       if (m(2).ne.Z'22222222') then
+         if (debug) then
+            print '(A,Z8)','m(2) incorrect.  m(2) = ',m(2)
+         else
+            call abort
+         endif
+       endif
+
+       if (n.ne.Z'33333333') then
+         if (debug) then
+            print '(A,Z8)','n incorrect.  n = ',n
+         else
+            call abort
+         endif
+       endif
+
+       do i = 1,size
+          if (int(r(i)).ne.i) then
+            if (debug) then
+              print*,'element ',i,' was ',r(i),' should be ',i
+            else
+              call abort
+            endif
+          endif
+       end do
+! use hexdump to look at the file "fort.9"
+       if (debug) then
+         close(9)
+       else
+         close(9,status='DELETE')
+       endif
+       end

libgfortran/ChangeLog

@@ -1,3 +1,16 @@
+2004-07-04  Bud Davis  <bdavis9659@comcast.net>
+	    Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/15472
+	* io/transfer.c(us_write): set recl for seq unform writes to max size.
+	* io/transfer.c(data_transfer_init): handle un-opened seq unform unit.
+	* io/unix.c(fd_alloc_w_at): handle requests at start, fd_flush at 
+	  right time.
+	* io/unix.c(is_seekable): set based upon the file/device, not the
+          method being used to access it (fd or mmap).
+	* io/unix.c(fd_flush): don't set file_size if !seekable.
+	* io/unix.c(fd_truncate: ditto.
+
 2004-07-04  Janne Blomqvist  <jblomqvi@cc.hut.fi>
 	Paul Brook  <paul@codesourcery.com>
 

libgfortran/io/transfer.c

@@ -835,6 +835,11 @@ us_write (void)
   if (sfree (current_unit->s) == FAILURE)
     generate_error (ERROR_OS, NULL);
 
+  /* for sequential unformatted, we write until we have more bytes than
+      can fit in the record markers. if disk space runs out first it will
+      error on the write */
+  current_unit->recl = g.max_offset;
+
   current_unit->bytes_left = current_unit->recl;
 }
 
@@ -890,7 +895,11 @@ data_transfer_init (int read_flag)
      memset (&u_flags, '\0', sizeof (u_flags));
      u_flags.access = ACCESS_SEQUENTIAL;
      u_flags.action = ACTION_READWRITE;
-     u_flags.form = FORM_UNSPECIFIED;
+     /* is it unformatted ?*/
+     if (ioparm.format == NULL && !ioparm.list_format)
+       u_flags.form = FORM_UNFORMATTED;
+     else
+       u_flags.form = FORM_UNSPECIFIED;
      u_flags.delim = DELIM_UNSPECIFIED;
      u_flags.blank = BLANK_UNSPECIFIED;
      u_flags.pad = PAD_UNSPECIFIED;

libgfortran/io/unix.c

@@ -90,7 +90,7 @@ typedef struct
   gfc_offset physical_offset;	/* Current physical file offset */
   gfc_offset logical_offset;	/* Current logical file offset */
   gfc_offset dirty_offset;	/* Start of modified bytes in buffer */
-  gfc_offset file_length;		/* Length of the file, -1 if not seekable. */
+  gfc_offset file_length;	/* Length of the file, -1 if not seekable. */
 
   char *buffer;
   int len;			/* Physical length of the current buffer */
@@ -280,7 +280,9 @@ fd_flush (unix_stream * s)
     return FAILURE;
 
   s->physical_offset = s->dirty_offset + s->ndirty;
-  if (s->physical_offset > s->file_length)
+
+  /* don't increment file_length if the file is non-seekable */
+  if (s->file_length != -1 && s->physical_offset > s->file_length)
     s->file_length = s->physical_offset;
   s->ndirty = 0;
 
@@ -406,18 +408,28 @@ fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
     }
 
   /* Return a position within the current buffer */
-
-  if (s->ndirty == 0)
-    {				/* First write into a clean buffer */
-      s->dirty_offset = where;
-      s->ndirty = *len;
+  if (s->ndirty == 0 
+      || where > s->dirty_offset + s->ndirty    
+      || s->dirty_offset > where + *len)
+    {  /* Discontiguous blocks, start with a clean buffer.  */  
+        /* Flush the buffer.  */  
+       if (s->ndirty != 0)    
+         fd_flush (s);  
+       s->dirty_offset = where;  
+       s->ndirty = *len;
     }
   else
-    {
-      if (s->dirty_offset + s->ndirty == where)
-	s->ndirty += *len;
-      else
-	fd_flush (s);		/* Can't combine two dirty blocks */
+    {  
+      gfc_offset start;  /* Merge with the existing data.  */  
+      if (where < s->dirty_offset)    
+        start = where;  
+      else    
+        start = s->dirty_offset;  
+      if (where + *len > s->dirty_offset + s->ndirty)    
+        s->ndirty = where + *len - start;  
+      else    
+        s->ndirty = s->dirty_offset + s->ndirty - start;  
+        s->dirty_offset = start;
     }
 
   s->logical_offset = where + *len;
@@ -461,14 +473,19 @@ static try
 fd_truncate (unix_stream * s)
 {
 
-  if (ftruncate (s->fd, s->logical_offset))
+  if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
     return FAILURE;
 
+  /* non-seekable files, like terminals and fifo's fail the lseek.
+     the fd is a regular file at this point */
+
+  if (ftruncate (s->fd, s->logical_offset))
+   {
+    return FAILURE;
+   }
+
   s->physical_offset = s->file_length = s->logical_offset;
 
-  if (lseek (s->fd, s->file_length, SEEK_SET) == -1)
-    return FAILURE;
-
   return SUCCESS;
 }
 
@@ -1390,8 +1407,10 @@ file_position (stream * s)
 int
 is_seekable (stream * s)
 {
-
-  return ((unix_stream *) s)->mmaped;
+  /* by convention, if file_length == -1, the file is not seekable
+     note that a mmapped file is always seekable, an fd_ file may
+     or may not be. */
+  return ((unix_stream *) s)->file_length!=-1;
 }
 
 try