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

1 files changed, 40 insertions, 10 deletions

diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index fc22d80..1e56b5d 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. */
@@ -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)