diff mbox

[libgfortran] PR78881 [F03] reading from string with DTIO procedure does not work properly

Message ID 3304d51a-e1e4-59e4-56ac-27428cf15fbb@charter.net
State New
Headers show

Commit Message

Jerry DeLisle March 22, 2017, 4:28 a.m. UTC
Hi all,

The attached patch is part 1 of a 2 part patch.  This part fixes a few problems 
with handling of advance= and EOR conditions.  This does not resolve the 
original case in the PR but gets some issues out of the way so I can continue.

The most notable change is that per standard, child I/O is by definition 
non-advancing and any advance= specifier is ignored. We still do the typical 
error checks for on the advance= and give errors when not valid to specify it, 
but where it is valid, we just ignore it as stated in the standard (set it to 
non-advancing regardless).

"A formatted child input/output statement is a nonadvancing input/output 
statement, and any ADVANCE= specifier is ignored." 9.6.2.4

Regarding the original test case, note that if I use a format specifier of 
'(DT)' instead of *, the test case works as expected. So, evidently with list 
directed I/O we are eating the first character for some reason. I will keep 
working on this issue.

In the meantime, the attached patch and test cases, regression tested on 
x86_64-linux.

OK for trunk?

Jerry

2017-03-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/78881
	* io/transfer.c (read_sf_internal): Add a new check for EOR
	condition. (data_transfer_init): If child dtio, set advance
	status to nonadvancing. Move update of size and check for EOR
	condition to before child dtio return.
! { dg-do run }
! PR78881 test for correct end ofrecord condition and ignoring advance=
module t_m
   use, intrinsic :: iso_fortran_env, only : iostat_end, iostat_eor, output_unit
   implicit none
   type, public :: t
      character(len=:), allocatable :: m_s
   contains
      procedure, pass(this) :: read_t
      generic :: read(formatted) => read_t
   end type t
contains
subroutine read_t(this, lun, iotype, vlist, istat, imsg)
  class(t), intent(inout)         :: this
  integer, intent(in)             :: lun
  character(len=*), intent(in)    :: iotype
  integer, intent(in)             :: vlist(:)
  integer, intent(out)            :: istat
  character(len=*), intent(inout) :: imsg
  character(len=1) :: c
  integer :: i
  i = 0 ; imsg=''
  loop_read: do
    i = i + 1
    read( unit=lun, fmt='(a1)', iostat=istat, iomsg=imsg) c
    select case ( istat )
    case ( 0 )
      if (i.eq.1 .and. c.ne.'h') exit loop_read
      !write( output_unit, fmt=sfmt) "i = ", i, ", c = ", c
    case ( iostat_end )
      !write( output_unit, fmt=sfmt) "i = ", i, ", istat = iostat_end"
      exit loop_read
    case ( iostat_eor )
      !write( output_unit, fmt=sfmt) "i = ", i, ", istat = iostat_eor"
      exit loop_read
    case default
      !write( output_unit, fmt=sfmt) "i = ", i, ", istat = ", istat
      exit loop_read
    end select
    if (i.gt.10) exit loop_read
  end do loop_read
end subroutine read_t
end module t_m

program p
  use t_m, only : t
  implicit none
  
  character(len=:), allocatable :: s
  type(t) :: foo
  character(len=256) :: imsg
  integer :: istat
  
  open(10, status="scratch")
  write(10,'(a)') 'hello'
  rewind(10)
  read(unit=10, fmt='(dt)', iostat=istat, iomsg=imsg) foo
  close(10)
  if (imsg.ne."End of record") call abort
end program p

! { dg-final { cleanup-modules "t_m" } }
! { dg-do run }
! PR78881 test for correct end ofrecord condition and ignoring advance=
module t_m
  use, intrinsic :: iso_fortran_env, only : iostat_end, iostat_eor, output_unit
  implicit none
  type, public :: t
    character(len=:), allocatable :: m_s
  contains
    procedure, pass(this) :: read_t
    generic :: read(formatted) => read_t
  end type t
contains
subroutine read_t(this, lun, iotype, vlist, istat, imsg)
  class(t), intent(inout)         :: this
  integer, intent(in)             :: lun
  character(len=*), intent(in)    :: iotype
  integer, intent(in)             :: vlist(:)
  integer, intent(out)            :: istat
  character(len=*), intent(inout) :: imsg
  character(len=1) :: c
  integer :: i
  i = 0 ; imsg=''
  loop_read: do
    i = i + 1
    read( unit=lun, fmt='(a1)', iostat=istat, iomsg=imsg) c
    select case ( istat )
    case ( 0 )
      if (i.eq.1 .and. c.ne.'H') exit loop_read
      !write( output_unit, fmt=*) "i = ", i, ", c = ", c
    case ( iostat_end )
      !write( output_unit, fmt=*) "i = ", i, ", istat = iostat_end"
      exit loop_read
    case ( iostat_eor )
      !write( output_unit, fmt=*) "i = ", i, ", istat = iostat_eor"
      exit loop_read
    case default
      !write( output_unit, fmt=*) "i = ", i, ", istat = ", istat
      exit loop_read
    end select
    if (i.gt.10) exit loop_read
  end do loop_read
end subroutine read_t
end module t_m

program p
  use t_m, only : t
  implicit none
  character(len=:), allocatable :: s
  type(t) :: foo
  character(len=256) :: imsg
  integer :: istat
  s = "Hello"
  read( unit=s, fmt='(dt)', iostat=istat, iomsg=imsg) foo
  if (imsg.ne."End of record") call abort
end program p

! { dg-final { cleanup-modules "t_m" } }
diff mbox

Patch

diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index fc22d802..30a8a0c4 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -226,7 +226,7 @@  static char *
 read_sf_internal (st_parameter_dt *dtp, int * length)
 {
   static char *empty_string[0];
-  char *base;
+  char *base = NULL;
   int lorig;
 
   /* Zero size array gives internal unit len of 0.  Nothing to read. */
@@ -263,6 +263,12 @@  read_sf_internal (st_parameter_dt *dtp, int * length)
       return NULL;
     }
 
+  if (base && *base == 0)
+    {
+      generate_error (&dtp->common, LIBERROR_EOR, NULL);
+      return NULL;
+    }
+
   dtp->u.p.current_unit->bytes_left -= *length;
 
   if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
@@ -2856,6 +2862,11 @@  data_transfer_init (st_parameter_dt *dtp, int read_flag)
 	}
     }
 
+  /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
+     F2008 9.6.2.4  */
+  if (dtp->u.p.current_unit->child_dtio  > 0)
+    dtp->u.p.advance_status = ADVANCE_NO;
+
   if (read_flag)
     {
       dtp->u.p.current_unit->previous_nonadvancing_write = 0;
@@ -3856,6 +3867,15 @@  finalize_transfer (st_parameter_dt *dtp)
 	 namelist_write (dtp);
     }
 
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    *dtp->size = dtp->u.p.current_unit->size_used;
+
+  if (dtp->u.p.eor_condition)
+    {
+      generate_error (&dtp->common, LIBERROR_EOR, NULL);
+      goto done;
+    }
+
   if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio  > 0))
     {
       if (cf & IOPARM_DT_HAS_FORMAT)
@@ -3866,15 +3886,6 @@  finalize_transfer (st_parameter_dt *dtp)
       return;
     }
 
-  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
-    *dtp->size = dtp->u.p.current_unit->size_used;
-
-  if (dtp->u.p.eor_condition)
-    {
-      generate_error (&dtp->common, LIBERROR_EOR, NULL);
-      goto done;
-    }
-
   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
     {
       if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)