libgfortran: Propagate user defined iostat and iomsg.

	PR libfortran/105456

libgfortran/ChangeLog:

	* io/list_read.c (list_formatted_read_scalar): Add checks
	for the case where a user defines their own error codes
	and error messages and generate the runtime error.
	* io/transfer.c (st_read_done): Whitespace.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr105456.f90: New test.

diff --git a/gcc/testsuite/gfortran.dg/pr105456.f90 b/gcc/testsuite/gfortran.dg/pr105456.f90
new file mode 100644 (file)
index 0000000..1883238
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105456.f90
@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-shouldfail "The users message" }
+module sk1
+  implicit none
+  type char
+     character :: ch
+  end type char
+  interface read (formatted)
+     module procedure read_formatted
+  end interface read (formatted)
+contains
+  subroutine read_formatted (dtv, unit, iotype, vlist, piostat, piomsg)
+    class (char), intent(inout) :: dtv
+    integer, intent(in) :: unit
+    character (len=*), intent(in) :: iotype
+    integer, intent(in) :: vlist(:)
+    integer, intent(out) :: piostat
+    character (len=*), intent(inout) :: piomsg
+    character :: ch
+    read (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) ch
+    piostat = 42
+    piomsg="The users message"
+    dtv%ch = ch
+  end subroutine read_formatted
+end module sk1
+
+program skip1
+  use sk1
+  implicit none
+  type (char) :: x
+  open (10,status="scratch")
+  write (10,'(A)') '', 'a'
+  rewind (10)
+  read (10,*) x
+  write (*,'(10(A))') "Read: '",x%ch,"'"
+end program skip1
+! { dg-output ".*(unit = 10, file = .*)" }
+! { dg-output "Fortran runtime error: The users message" }

diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 3d29cb64813c03a0c5efe6a7ff69bb5eab28a7dd..ee3ab71351967f8e8b4328498614a130a1001c96 100644 (file)
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -2138,6 +2138,7 @@ static int
 list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
                            int kind, size_t size)
 {
+  char message[MSGLEN];
   gfc_char4_t *q, *r;
   size_t m;
   int c;
@@ -2247,7 +2248,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
          child_iostat = ((dtp->common.flags & IOPARM_HAS_IOSTAT)
                          ? dtp->common.iostat : &noiostat);
 
-         /* Set iomsge, intent(inout).  */
+         /* Set iomsg, intent(inout).  */
          if (dtp->common.flags & IOPARM_HAS_IOMSG)
            {
              child_iomsg = dtp->common.iomsg;
@@ -2266,6 +2267,25 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
                              iotype_len, child_iomsg_len);
          dtp->u.p.child_saved_iostat = *child_iostat;
          dtp->u.p.current_unit->child_dtio--;
+         
+         
+         if ((dtp->u.p.child_saved_iostat != 0) &&
+             !(dtp->common.flags & IOPARM_HAS_IOMSG) &&
+             !(dtp->common.flags & IOPARM_HAS_IOSTAT))
+           {
+             /* Trim trailing spaces from the message.  */
+             for(int i = IOMSG_LEN - 1; i > 0; i--)
+               if (!isspace(child_iomsg[i]))
+                 {
+                   /* Add two to get back to the end of child_iomsg.  */
+                   child_iomsg_len = i+2;
+                   break;
+                 }
+             free_line (dtp);
+             snprintf (message, child_iomsg_len, child_iomsg);
+             generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
+                             message);
+           }
       }
       break;
     default:

diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 99ef96a9e7c82a97471e4c2cc35df73375933ac0..01db4122d16d9d13f0a7839525cc916e99666041 100644 (file)
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -4556,7 +4556,7 @@ st_read_done (st_parameter_dt *dtp)
       if (dtp->u.p.current_unit->au)
        {
          if (dtp->common.flags & IOPARM_DT_HAS_ID)
-           *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, AIO_READ_DONE);  
+           *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, AIO_READ_DONE);
          else
            {
              if (dtp->u.p.async)