re PR fortran/78881 ([F03] reading from string with DTIO procedure does not work properly)

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

	PR libgfortran/78881
	* io/io.h (st_parameter_dt): Rename unused component last_char to
	child_saved_iostat. Move comment to gfc_unit.
	* io/list_read.c (list_formatted_read_scalar): After call to
	child READ procedure, save the returned iostat value for later
	check. (finish_list_read): Only finish READ if child_saved_iostat
	was OK.
	* io/transfer.c (read_sf_internal): If there is a saved character
	in last character, seek back one. Add a new check for EOR
	condition. (read_sf): If there is a saved character
	in last character, seek back one. (formatted_transfer_scalar_read):
	Initialize last character before invoking child procedure.
	(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.

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

From-SVN: r246478

gcc/testsuite/ChangeLog

+2017-03-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libgfortran/78881
+	* gfortran.dg/dtio_26.f90: New test.
+
 2017-03-25  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/80156

gcc/testsuite/gfortran.dg/dtio_26.f03

+! { dg-do run }
+! PR78881 test for correct end of record 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
+  if (imsg.ne."End of record") call abort
+  rewind(10)
+  read(unit=10, fmt=*, iostat=istat, iomsg=imsg) foo
+  if (imsg.ne."End of record") call abort
+  s = "hello"
+  read( unit=s, fmt='(dt)', iostat=istat, iomsg=imsg) foo
+  if (imsg.ne."End of record") call abort
+  read( unit=s, fmt=*, iostat=istat, iomsg=imsg) foo
+  if (imsg.ne."End of record") call abort
+end program p
+
+! { dg-final { cleanup-modules "t_m" } }

libgfortran/ChangeLog

+2017-03-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libgfortran/78881
+	* io/io.h (st_parameter_dt): Rename unused component last_char to
+	child_saved_iostat. Move comment to gfc_unit.
+	* io/list_read.c (list_formatted_read_scalar): After call to
+	child READ procedure, save the returned iostat value for later
+	check. (finish_list_read): Only finish READ if child_saved_iostat
+	was OK.
+	* io/transfer.c (read_sf_internal): If there is a saved character
+	in last character, seek back one. Add a new check for EOR
+	condition. (read_sf): If there is a saved character
+	in last character, seek back one. (formatted_transfer_scalar_read):
+	Initialize last character before invoking child procedure.
+	(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.
+
 2017-03-17  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR libfortran/79956

libgfortran/io/io.h

@@ -534,10 +534,7 @@ typedef struct st_parameter_dt
 	  unsigned expanded_read : 1;
 	  /* 13 unused bits.  */
 
-	  /* Used for ungetc() style functionality. Possible values
-	     are an unsigned char, EOF, or EOF - 1 used to mark the
-	     field as not valid.  */
-	  int last_char; /* No longer used, moved to gfc_unit.  */
+	  int child_saved_iostat;
 	  int nml_delim;
 	  int repeat_count;
 	  int saved_length;
@@ -701,6 +698,10 @@ typedef struct gfc_unit
 
   /* DTIO Parent/Child procedure, 0 = parent, >0 = child level.  */
   int child_dtio;
+
+  /* Used for ungetc() style functionality. Possible values
+     are an unsigned char, EOF, or EOF - 1 used to mark the
+     field as not valid.  */
   int last_char;
   bool has_size;
   GFC_IO_INT size_used;

libgfortran/io/list_read.c

@@ -2221,6 +2221,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
 	  dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
 			      child_iostat, child_iomsg,
 			      iotype_len, child_iomsg_len);
+	  dtp->u.p.child_saved_iostat = *child_iostat;
 	  dtp->u.p.current_unit->child_dtio--;
       }
       break;
@@ -2352,15 +2353,18 @@ finish_list_read (st_parameter_dt *dtp)
       /* Set the next_char and push_char worker functions.  */
       set_workers (dtp);
 
-      c = next_char (dtp);
-      if (c == EOF)
+      if (likely (dtp->u.p.child_saved_iostat == LIBERROR_OK))
 	{
-	  free_line (dtp);
-	  hit_eof (dtp);
-	  return;
+	  c = next_char (dtp);
+	  if (c == EOF)
+	    {
+	      free_line (dtp);
+	      hit_eof (dtp);
+	      return;
+	    }
+	  if (c != '\n')
+	    eat_line (dtp);
 	}
-      if (c != '\n')
-	eat_line (dtp);
     }
 
   free_line (dtp);

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. */
@@ -244,6 +244,15 @@ read_sf_internal (st_parameter_dt *dtp, int * length)
       return (char*) empty_string;
     }
 
+  /* There are some cases with mixed DTIO where we have read a character
+     and saved it in the last character buffer, so we need to backup.  */
+  if (unlikely (dtp->u.p.current_unit->child_dtio > 0 &&
+		dtp->u.p.current_unit->last_char != EOF - 1))
+    {
+      dtp->u.p.current_unit->last_char = EOF - 1;
+      sseek (dtp->u.p.current_unit->s, -1, SEEK_CUR);
+    }
+
   lorig = *length;
   if (is_char4_unit(dtp))
     {
@@ -263,6 +272,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) ||
@@ -304,6 +319,15 @@ read_sf (st_parameter_dt *dtp, int * length)
       return (char*) empty_string;
     }
 
+  /* There are some cases with mixed DTIO where we have read a character
+     and saved it in the last character buffer, so we need to backup.  */
+  if (unlikely (dtp->u.p.current_unit->child_dtio > 0 &&
+		dtp->u.p.current_unit->last_char != EOF - 1))
+    {
+      dtp->u.p.current_unit->last_char = EOF - 1;
+      fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
+    }
+
   n = seen_comma = 0;
 
   /* Read data into format buffer and scan through it.  */
@@ -1499,6 +1523,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
 
 	  /* Call the user defined formatted READ procedure.  */
 	  dtp->u.p.current_unit->child_dtio++;
+	  dtp->u.p.current_unit->last_char = EOF - 1;
 	  dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
 			      child_iostat, child_iomsg,
 			      iotype_len, child_iomsg_len);
@@ -2856,6 +2881,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 +3886,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 +3905,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)