re PR libfortran/34370 (file positioning after nonadvancing i/o)

2007-12-13  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/34370
	PR libfortran/34323
	PR libfortran/34405
	* io/io.h:  Add previous_nonadvancing_write to gfc_unit.
	Add prototype for finish_last_advance_record.
	* io/file_pos.c (st_backspace):  Generate error if backspace is
	attempted for direct access or unformatted stream.
	If there are bytes left from a previous ADVANCE="no", write
	them out before performing the backspace.
	(st_endfile):  Generate error if endfile is attempted for
	direct access.
	If there are bytes left from a previous ADVANCE="no", write
	them out before performing the endfile.
	(st_rewind):  Generate error if rewind is attempted for
	direct access.
	* unit.c (close_unit_1):  Move functionality to write
	previously written bytes to...
	(finish_last_advance_record):  ... here.
	* transfer.c (data_transfer_init):  If reading, reset
	previous_nonadvancing_write.
	(finalize_transfer):  Set the previous_noadvancing_write
	flag if we are writing and ADVANCE="no" was specified.
	Only call next_record() if advance="no" wasn't specified.

2007-12-13  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/34370
	PR libfortran/34323
	PR libfortran/34405
	* gfortran.dg/advance_6.f90:  New test case.
	* gfortran.dg/direct_io_7.f90:  New test case.
	* gfortran.dg/streamio_13.f90:  New test case.

From-SVN: r130912

gcc/testsuite/ChangeLog

+2007-12-13  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR libfortran/34370
+	PR libfortran/34323
+	PR libfortran/34405
+	* gfortran.dg/advance_6.f90:  New test case.
+	* gfortran.dg/direct_io_7.f90:  New test case.
+	* gfortran.dg/streamio_13.f90:  New test case.
+
 2007-12-13  Douglas Gregor  <doug.gregor@gmail.com>
 
 	* g++.dg/cpp0x/__func__.C: New.

gcc/testsuite/gfortran.dg/advance_6.f90

+! { dg-do run }
+! PR 34370 - file positioning after non-advancing I/O didn't add
+! a record marker.
+
+program main
+  implicit none
+  character(len=3) :: c
+  character(len=80), parameter :: fname = "advance_backspace_1.dat"
+
+  call write_file
+  close (95)
+  call check_end_record
+
+  call write_file
+  backspace 95
+  c = 'xxx'
+  read (95,'(A)') c
+  if (c /= 'ab ') call abort
+  close (95)
+  call check_end_record
+  
+  call write_file
+  backspace 95
+  close (95)
+  call check_end_record
+
+  call write_file
+  endfile 95
+  close (95)
+  call check_end_record
+
+  call write_file
+  endfile 95
+  rewind 95
+  c = 'xxx'
+  read (95,'(A)') c
+  if (c /= 'ab ') call abort
+  close (95)
+  call check_end_record
+
+  call write_file
+  rewind 95
+  c = 'xxx'
+  read (95,'(A)') c
+  if (c /= 'ab ') call abort
+  close (95)
+  call check_end_record
+
+contains
+
+  subroutine write_file
+    open(95, file=fname, status="replace", form="formatted")
+    write (95, '(A)', advance="no") 'a'
+    write (95, '(A)', advance="no") 'b'
+  end subroutine write_file
+
+! Checks for correct end record, then deletes the file.
+
+  subroutine check_end_record
+    character(len=1) :: x
+    open(2003, file=fname, status="old", access="stream", form="unformatted")
+    read(2003) x
+    if (x /= 'a') call abort
+    read(2003) x
+    if (x /= 'b') call abort
+    read(2003) x
+    if (x /= achar(10)) then
+       read(2003) x
+       if (x /= achar(13)) then
+       else
+          call abort
+       end if
+    end if
+    close(2003,status="delete")
+  end subroutine check_end_record
+end program main

gcc/testsuite/gfortran.dg/direct_io_7.f90

+! { dg-do run }
+! PR 34405 - direct access prohibits ENDFILE, BACKSPACE and REWIND
+program test
+  implicit none
+  integer :: ios
+  character(len=80) :: msg
+  open (95, access="direct", recl=4, status="scratch")
+  write (95,rec=1) 'abcd'
+
+  ios = 0
+  msg = " "
+  backspace (95,iostat=ios,iomsg=msg)
+  if (ios == 0 .or. &
+       msg /= "Cannot BACKSPACE a file opened for DIRECT access") call abort
+
+  ios = 0
+  msg = " "
+  endfile (95,iostat=ios,iomsg=msg)
+  if (ios == 0 .or. &
+       msg /= "Cannot perform ENDFILE on a file opened for DIRECT access") &
+       call abort
+
+  ios = 0
+  msg = " "
+  rewind (95,iostat=ios,iomsg=msg)
+  if (ios == 0 .or. &
+       msg /= "Cannot REWIND a file opened for DIRECT access ") call abort
+
+  close (95)
+end program test
+

gcc/testsuite/gfortran.dg/streamio_13.f90

+! { dg-do run }
+! PR 34405 - BACKSPACE for unformatted stream files is prohibited.
+program main
+  implicit none
+  integer :: ios
+  character(len=80) :: msg
+  open(2003,form="unformatted",access="stream",status="scratch")
+  write (2003) 1
+  write (2003) 2
+  ios = 0
+  msg = ' '
+  backspace (2003,iostat=ios,iomsg=msg)
+  if (ios == 0 .or. msg /="Cannot BACKSPACE an unformatted stream file") &
+       call abort
+end program main

libgfortran/ChangeLog

+2007-12-13  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR libfortran/34370
+	PR libfortran/34323
+	PR libfortran/34405
+	* io/io.h:  Add previous_nonadvancing_write to gfc_unit.
+	Add prototype for finish_last_advance_record.
+	* io/file_pos.c (st_backspace):  Generate error if backspace is
+	attempted for direct access or unformatted stream.
+	If there are bytes left from a previous ADVANCE="no", write
+	them out before performing the backspace.
+	(st_endfile):  Generate error if endfile is attempted for
+	direct access.
+	If there are bytes left from a previous ADVANCE="no", write
+	them out before performing the endfile.
+	(st_rewind):  Generate error if rewind is attempted for
+	direct access.
+	* unit.c (close_unit_1):  Move functionality to write
+	previously written bytes to...
+	(finish_last_advance_record):  ... here.
+	* transfer.c (data_transfer_init):  If reading, reset
+	previous_nonadvancing_write.
+	(finalize_transfer):  Set the previous_noadvancing_write
+	flag if we are writing and ADVANCE="no" was specified.
+	Only call next_record() if advance="no" wasn't specified.
+
 2007-12-13  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34427

libgfortran/io/file_pos.c

@@ -199,12 +199,22 @@ st_backspace (st_parameter_filepos *fpp)
       goto done;
     }
 
-  /* Ignore direct access.  Non-advancing I/O is only allowed for formatted
-     sequential I/O and the next direct access transfer repositions the file 
-     anyway.  */
+  /* Direct access is prohibited, and so is unformatted stream access.  */
 
-  if (u->flags.access == ACCESS_DIRECT || u->flags.access == ACCESS_STREAM)
-    goto done;
+
+  if (u->flags.access == ACCESS_DIRECT)
+    {
+      generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+		      "Cannot BACKSPACE a file opened for DIRECT access");
+      goto done;
+    }
+
+    if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
+      {
+	generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+			"Cannot BACKSPACE an unformatted stream file");
+	goto done;
+      }
 
   /* Check for special cases involving the ENDFILE record first.  */
 
@@ -224,6 +234,15 @@ st_backspace (st_parameter_filepos *fpp)
 
       if (u->mode == WRITING)
 	{
+	  /* If there are previously written bytes from a write with
+	     ADVANCE="no", add a record marker before performing the
+	     BACKSPACE.  */
+
+	  if (u->previous_nonadvancing_write)
+	    finish_last_advance_record (u);
+
+	  u->previous_nonadvancing_write = 0;
+
 	  flush (u->s);
 	  struncate (u->s);
 	  u->mode = READING;
@@ -261,6 +280,22 @@ st_endfile (st_parameter_filepos *fpp)
   u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
+      if (u->flags.access == ACCESS_DIRECT)
+	{
+	  generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+			  "Cannot perform ENDFILE on a file opened"
+			  " for DIRECT access");
+	  goto done;
+	}
+
+      /* If there are previously written bytes from a write with ADVANCE="no",
+	 add a record marker before performing the ENDFILE.  */
+
+      if (u->previous_nonadvancing_write)
+	finish_last_advance_record (u);
+
+      u->previous_nonadvancing_write = 0;
+
       if (u->current_record)
 	{
 	  st_parameter_dt dtp;
@@ -274,6 +309,7 @@ st_endfile (st_parameter_filepos *fpp)
       struncate (u->s);
       u->endfile = AFTER_ENDFILE;
       update_position (u);
+    done:
       unlock_unit (u);
     }
 
@@ -299,6 +335,14 @@ st_rewind (st_parameter_filepos *fpp)
 			"Cannot REWIND a file opened for DIRECT access");
       else
 	{
+	  /* If there are previously written bytes from a write with ADVANCE="no",
+	     add a record marker before performing the ENDFILE.  */
+
+	  if (u->previous_nonadvancing_write)
+	    finish_last_advance_record (u);
+
+	  u->previous_nonadvancing_write = 0;
+
 	  /* Flush the buffers.  If we have been writing to the file, the last
 	       written record is the last record in the file, so truncate the
 	       file now.  Reset to read mode so two consecutive rewind

libgfortran/io/io.h

@@ -451,7 +451,8 @@ typedef struct gfc_unit
   struct gfc_unit *left, *right;
   int priority;
 
-  int read_bad, current_record, saved_pos;
+  int read_bad, current_record, saved_pos, previous_nonadvancing_write;
+
   enum
   { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
   endfile;
@@ -692,6 +693,9 @@ internal_proto(unlock_unit);
 extern void update_position (gfc_unit *);
 internal_proto(update_position);
 
+extern void finish_last_advance_record (gfc_unit *u);
+internal_proto (finish_last_advance_record);
+
 /* open.c */
 
 extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);

libgfortran/io/transfer.c

@@ -1891,6 +1891,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 
   if (read_flag)
     {
+      dtp->u.p.current_unit->previous_nonadvancing_write = 0;
+
       if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
 	{
 	  generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
@@ -2644,9 +2646,14 @@ finalize_transfer (st_parameter_dt *dtp)
       return;
     }
 
+  if (dtp->u.p.mode == WRITING)
+    dtp->u.p.current_unit->previous_nonadvancing_write
+      = dtp->u.p.advance_status == ADVANCE_NO;
+
   if (is_stream_io (dtp))
     {
-      if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
+      if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+	  && dtp->u.p.advance_status != ADVANCE_NO)
 	next_record (dtp, 1);
 
       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED

libgfortran/io/unit.c

@@ -581,27 +581,8 @@ close_unit_1 (gfc_unit *u, int locked)
 
   /* If there are previously written bytes from a write with ADVANCE="no"
      Reposition the buffer before closing.  */
-  if (u->saved_pos > 0)
-    {
-      char *p;
-
-      p = salloc_w (u->s, &u->saved_pos);
-
-      if (!(u->unit_number == options.stdout_unit
-	    || u->unit_number == options.stderr_unit))
-	{
-	  size_t len;
-
-	  const char crlf[] = "\r\n";
-#ifdef HAVE_CRLF
-	  len = 2;
-#else
-	  len = 1;
-#endif
-	  if (swrite (u->s, &crlf[2-len], &len) != 0)
-	    os_error ("Close after ADVANCE_NO failed");
-	}
-    }
+  if (u->previous_nonadvancing_write)
+    finish_last_advance_record (u);
 
   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 
@@ -718,3 +699,27 @@ filename_from_unit (int n)
     return (char *) NULL;
 }
 
+void
+finish_last_advance_record (gfc_unit *u)
+{
+  char *p;
+
+  if (u->saved_pos > 0)
+    p = salloc_w (u->s, &u->saved_pos);
+
+  if (!(u->unit_number == options.stdout_unit
+	|| u->unit_number == options.stderr_unit))
+    {
+      size_t len;
+
+      const char crlf[] = "\r\n";
+#ifdef HAVE_CRLF
+      len = 2;
+#else
+      len = 1;
+#endif
+      if (swrite (u->s, &crlf[2-len], &len) != 0)
+	os_error ("Completing record after ADVANCE_NO failed");
+    }
+}
+