re PR fortran/31618 ([4.2, 4.1 only] backspace intrinsic is not working on an unforma...

2007-04-23  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/31618
	* io/transfer.c (read_block_direct):  Instead of calling us_read,
	set dtp->u.p.current_unit->current_record = 0 so that pre_position
	will read the record marker.
	(data_transfer_init):  For different error conditions, call
	generate_error, then return.

2007-04-23  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/31618
	* gfortran.dg/backspace_8.f:  New test case.

From-SVN: r124079

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 22b6f46b259e520a9faf89aa4ee32b17c6a0bf5b..1358818206e6c1c37f3fb3e529f3cbbea27db124 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-04-23  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/31618
+       * gfortran.dg/backspace_8.f:  New test case.
+
 2007-04-23  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/31630

diff --git a/gcc/testsuite/gfortran.dg/backspace_8.f b/gcc/testsuite/gfortran.dg/backspace_8.f
new file mode 100644 (file)
index 0000000..8c8c96a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/backspace_8.f
@@ -0,0 +1,18 @@
+C { dg-do run }
+C PR libfortran/31618 - backspace after an error didn't work.
+      program main
+      character*78 msg
+      open (21, file="backspace_7.dat", form="unformatted")
+      write (21) 42, 43
+      write (21) 4711, 4712
+      write (21) -1, -4
+      rewind (21)
+      read (21) i,j
+      read (21,err=100,end=100) i,j,k
+      call abort
+ 100  continue
+      backspace 21
+      read (21) i,j
+      if (i .ne. 4711 .or. j .ne. 4712) call abort
+      close (21,status="delete")
+      end

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 74ba4e0f9e1ef4f5d3dcf19127eb333f75880fe0..d682fc10793b988ddcdc4c164aaa2c9a43d08e50 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,12 @@
+2007-04-23  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/31618
+       * io/transfer.c (read_block_direct):  Instead of calling us_read,
+       set dtp->u.p.current_unit->current_record = 0 so that pre_position
+       will read the record marker.
+       (data_transfer_init):  For different error conditions, call
+       generate_error, then return.
+
 2007-04-19  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        * runtime/main.c (please_free_exe_path_when_done): New variable.

diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 65d83ef465c499d0646c9c66b1e156f039d7ddb2..f9f6657b737e4b281c67deb853872a501471c6f6 100644 (file)
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -494,11 +494,11 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
            }
          else
            {
-             /* Let's make sure the file position is correctly set for the
-                next read statement.  */
+             /* Let's make sure the file position is correctly pre-positioned
+                for the next read statement.  */
 
+             dtp->u.p.current_unit->current_record = 0;
              next_record_r_unf (dtp, 0);
-             us_read (dtp, 0);
              generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
              return;
            }
@@ -1769,15 +1769,18 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   /* Check the action.  */
 
   if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
-    generate_error (&dtp->common, ERROR_BAD_ACTION,
-                   "Cannot read from file opened for WRITE");
+    {
+      generate_error (&dtp->common, ERROR_BAD_ACTION,
+                     "Cannot read from file opened for WRITE");
+      return;
+    }
 
   if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
-    generate_error (&dtp->common, ERROR_BAD_ACTION,
-                   "Cannot write to file opened for READ");
-
-  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
-    return;
+    {
+      generate_error (&dtp->common, ERROR_BAD_ACTION,
+                     "Cannot write to file opened for READ");
+      return;
+    }
 
   dtp->u.p.first_item = 1;
 
@@ -1786,14 +1789,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
     parse_format (dtp);
 
-  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
-    return;
-
   if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
       && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
         != 0)
-    generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                   "Format present for UNFORMATTED data transfer");
+    {
+      generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                     "Format present for UNFORMATTED data transfer");
+      return;
+    }
 
   if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
      {
@@ -1803,13 +1806,19 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
      }
   else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
           !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
-    generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                   "Missing format for FORMATTED data transfer");
+    {
+      generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                     "Missing format for FORMATTED data transfer");
+    }
 
   if (is_internal_unit (dtp)
       && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
-    generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                   "Internal file cannot be accessed by UNFORMATTED data transfer");
+    {
+      generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                     "Internal file cannot be accessed by UNFORMATTED "
+                     "data transfer");
+      return;
+    }
 
   /* Check the record or position number.  */
 
@@ -1839,49 +1848,71 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
     {
       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
-       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                       "ADVANCE specification conflicts with sequential access");
+       {
+         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                         "ADVANCE specification conflicts with sequential access");
+         return;
+       }
 
       if (is_internal_unit (dtp))
-       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                       "ADVANCE specification conflicts with internal file");
+       {
+         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                         "ADVANCE specification conflicts with internal file");
+         return;
+       }
 
       if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
          != IOPARM_DT_HAS_FORMAT)
-       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                       "ADVANCE specification requires an explicit format");
+       {
+         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                         "ADVANCE specification requires an explicit format");
+         return;
+       }
     }
 
   if (read_flag)
     {
       if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
-       generate_error (&dtp->common, ERROR_MISSING_OPTION,
-                       "EOR specification requires an ADVANCE specification of NO");
+       {
+         generate_error (&dtp->common, ERROR_MISSING_OPTION,
+                         "EOR specification requires an ADVANCE specification "
+                         "of NO");
+         return;
+       }
 
       if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
-       generate_error (&dtp->common, ERROR_MISSING_OPTION,
-                       "SIZE specification requires an ADVANCE specification of NO");
-
+       {
+         generate_error (&dtp->common, ERROR_MISSING_OPTION,
+                         "SIZE specification requires an ADVANCE specification of NO");
+         return;
+       }
     }
   else
     {                          /* Write constraints.  */
       if ((cf & IOPARM_END) != 0)
-       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                       "END specification cannot appear in a write statement");
+       {
+         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                         "END specification cannot appear in a write statement");
+         return;
+       }
 
       if ((cf & IOPARM_EOR) != 0)
-       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                       "EOR specification cannot appear in a write statement");
+       {
+         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                         "EOR specification cannot appear in a write statement");
+         return;
+       }
 
       if ((cf & IOPARM_DT_HAS_SIZE) != 0)
-       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
-                       "SIZE specification cannot appear in a write statement");
+       {
+         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+                         "SIZE specification cannot appear in a write statement");
+         return;
+       }
     }
 
   if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
     dtp->u.p.advance_status = ADVANCE_YES;
-  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
-    return;
 
   /* Sanity checks on the record number.  */
   if ((cf & IOPARM_DT_HAS_REC) != 0)