[patch, libgfortran] [F03] Incorrect file position with namelist read under DTIO

[Jerry DeLisle <jvdelisle at charter dot net>]

Hi all,

The attached patch resolves this problem by moving the code that invokes the 
child I/O procedure into nml_read_obj where it belongs.  This allows the normal 
flow of code that parses the namelist decorations before attempting to read the 
object data.

One new test case is provided. Test case dtio_25.f90 is updated to fix it. One 
minor tweak on dtio_4.f90. (tests are in the patch)

As a followup, I will be testing for arrays of derived types in namelists. If 
any problems there I will open a new PR.

Regression tested on x86-64-linux.

OK for trunk?

Regards,

Jerry

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

	PR libgfortran/78670
	* io/list_read.c (nml_get_obj_data): Delete code which calls the
	child read procedure. (nml_read_obj): Insert the code which
	calls the child procedure. Don't need to touch nodes if using
	dtio since parent will not be traversing the components.


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

	PR libgfortran/78670
	* gfortran.dg/dtio_25.f90: Use 'a1' format when trying to read
	a character of length 1. Update test for success.
	* gfortran.dg/dtio_28.f03: New test.
	* gfortran.dg/dtio_4.f90: Update to open test file with status =
	'scratch' to delete the file when done.

diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90
index 6e66a312..a90a238e 100644
--- a/gcc/testsuite/gfortran.dg/dtio_25.f90
+++ b/gcc/testsuite/gfortran.dg/dtio_25.f90
@@ -20,7 +20,7 @@ contains
     integer, intent(out) :: iostat
     character(*), intent(inout) :: iomsg
     if (iotype.eq."NAMELIST") then
-      write (unit, '(a3,a1,i3)') dtv%c,',', dtv%k
+      write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k
     else
       write (unit,*) dtv%c, dtv%k
     end if
@@ -34,7 +34,7 @@ contains
     character(*), intent(inout) :: iomsg
     character :: comma
     if (iotype.eq."NAMELIST") then
-      read (unit, '(a4,a1,i3)') dtv%c, comma, dtv%k    ! FIXME: need a4 here, with a3 above
+      read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k
     else
       read (unit,*) dtv%c, comma, dtv%k
     end if
@@ -50,7 +50,7 @@ program p
   namelist /nml/ x
   x = t('a', 5)
   write (buffer, nml)
-  if (buffer.ne.'&NML  X=  a,  5  /') call abort
+  if (buffer.ne.'&NML  X=a,  5  /') call abort
   x = t('x', 0)
   read (buffer, nml)
   if (x%c.ne.'a'.or. x%k.ne.5) call abort
diff --git a/gcc/testsuite/gfortran.dg/dtio_28.f03 b/gcc/testsuite/gfortran.dg/dtio_28.f03
new file mode 100644
index 00000000..c70dc344
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_28.f03
@@ -0,0 +1,74 @@
+! { dg-do run }
+! PR78670 Incorrect file position with namelist read under DTIO
+MODULE m
+  IMPLICIT NONE
+  TYPE :: t
+    CHARACTER :: c
+  CONTAINS
+    PROCEDURE :: read_formatted
+    GENERIC :: READ(FORMATTED) => read_formatted
+    PROCEDURE :: write_formatted
+    GENERIC :: WRITE(FORMATTED) => write_formatted
+  END TYPE t
+CONTAINS
+  SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    CLASS(t), INTENT(IN) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    CHARACTER(*), INTENT(IN) :: iotype
+    INTEGER, INTENT(IN) :: v_list(:)
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER(*), INTENT(INOUT) :: iomsg
+    write(unit,'(a)', iostat=iostat, iomsg=iomsg) dtv%c
+  END SUBROUTINE write_formatted
+  
+  SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    CLASS(t), INTENT(INOUT) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    CHARACTER(*), INTENT(IN) :: iotype
+    INTEGER, INTENT(IN) :: v_list(:)
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER(*), INTENT(INOUT) :: iomsg
+    
+    CHARACTER :: ch
+    dtv%c = ''
+    DO
+      READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) ch
+      IF (iostat /= 0) RETURN
+      ! Store first non-blank
+      IF (ch /= ' ') THEN
+        dtv%c = ch
+        RETURN
+      END IF
+    END DO
+  END SUBROUTINE read_formatted
+END MODULE m
+
+PROGRAM p
+  USE m
+  IMPLICIT NONE
+  TYPE(t) :: x
+  TYPE(t) :: y
+  TYPE(t) :: z
+  integer :: j, k
+  NAMELIST /nml/ j, x, y, z, k
+  INTEGER :: unit, iostatus
+  
+  OPEN(NEWUNIT=unit, STATUS='SCRATCH', ACTION='READWRITE')
+  
+  x%c = 'a'
+  y%c = 'b'
+  z%c = 'c'
+  j=1
+  k=2
+  WRITE(unit, nml)
+  REWIND (unit)
+  x%c = 'x'
+  y%c = 'y'
+  z%c = 'x'
+  j=99
+  k=99
+  READ (unit, nml, iostat=iostatus)
+  if (iostatus.ne.0) call abort
+  if (j.ne.1 .or. k.ne.2 .or. x%c.ne.'a' .or. y%c.ne.'b' .or. z%c.ne.'c') call abort
+  !WRITE(*, nml)
+END PROGRAM p
diff --git a/gcc/testsuite/gfortran.dg/dtio_4.f90 b/gcc/testsuite/gfortran.dg/dtio_4.f90
index 5323194a..44352c1b 100644
--- a/gcc/testsuite/gfortran.dg/dtio_4.f90
+++ b/gcc/testsuite/gfortran.dg/dtio_4.f90
@@ -96,7 +96,7 @@ program test1
   if (iomsg.ne.'SUCCESS') call abort
   if (any(udt1%myarray.ne.result_array)) call abort
   close(10)
-  open (10, form='formatted')
+  open (10, form='formatted', status='scratch')
   write (10, '(dt)') more1
   rewind(10)
   more1%myarray = 99
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 5514d19e..76eafa80 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -2958,6 +2958,61 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
 	    break;
 
 	  case BT_DERIVED:
+	    /* If this object has a User Defined procedure, call it.  */
+	    if (nl->dtio_sub != NULL)
+	      {
+		int unit = dtp->u.p.current_unit->unit_number;
+		char iotype[] = "NAMELIST";
+		gfc_charlen_type iotype_len = 8;
+		char tmp_iomsg[IOMSG_LEN] = "";
+		char *child_iomsg;
+		gfc_charlen_type child_iomsg_len;
+		int noiostat;
+		int *child_iostat = NULL;
+		gfc_array_i4 vlist;
+		gfc_class list_obj;
+		formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
+
+		GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+		GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+		list_obj.data = (void *)nl->mem_pos;
+		list_obj.vptr = nl->vtable;
+		list_obj.len = 0;
+
+		/* Set iostat, intent(out).  */
+		noiostat = 0;
+		child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+				dtp->common.iostat : &noiostat;
+
+		/* Set iomsg, intent(inout).  */
+		if (dtp->common.flags & IOPARM_HAS_IOMSG)
+		  {
+		    child_iomsg = dtp->common.iomsg;
+		    child_iomsg_len = dtp->common.iomsg_len;
+		  }
+		else
+		  {
+		    child_iomsg = tmp_iomsg;
+		    child_iomsg_len = IOMSG_LEN;
+		  }
+
+		/* If reading from an internal unit, stash it to allow
+		   the child procedure to access it.  */
+		if (is_internal_unit (dtp))
+		  stash_internal_unit (dtp);
+
+		/* Call the user defined formatted READ procedure.  */
+		dtp->u.p.current_unit->child_dtio++;
+		dtio_ptr ((void *)&list_obj, &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--;
+		goto incr_idx;
+	      }
+
+	    /* Must be default derived type namelist read.  */
 	    obj_name_len = strlen (nl->var_name) + 1;
 	    obj_name = xmalloc (obj_name_len+1);
 	    memcpy (obj_name, nl->var_name, obj_name_len-1);
@@ -3268,58 +3323,6 @@ get_name:
 
       goto nml_err_ret;
     }
-  else if (nl->dtio_sub != NULL)
-    {
-      int unit = dtp->u.p.current_unit->unit_number;
-      char iotype[] = "NAMELIST";
-      gfc_charlen_type iotype_len = 8;
-      char tmp_iomsg[IOMSG_LEN] = "";
-      char *child_iomsg;
-      gfc_charlen_type child_iomsg_len;
-      int noiostat;
-      int *child_iostat = NULL;
-      gfc_array_i4 vlist;
-      gfc_class list_obj;
-      formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
-
-      GFC_DESCRIPTOR_DATA(&vlist) = NULL;
-      GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
-
-      list_obj.data = (void *)nl->mem_pos;
-      list_obj.vptr = nl->vtable;
-      list_obj.len = 0;
-
-      /* Set iostat, intent(out).  */
-      noiostat = 0;
-      child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
-		      dtp->common.iostat : &noiostat;
-
-      /* Set iomsg, intent(inout).  */
-      if (dtp->common.flags & IOPARM_HAS_IOMSG)
-	{
-	  child_iomsg = dtp->common.iomsg;
-	  child_iomsg_len = dtp->common.iomsg_len;
-	}
-      else
-	{
-	  child_iomsg = tmp_iomsg;
-	  child_iomsg_len = IOMSG_LEN;
-	}
-
-      /* If reading from an internal unit, stash it to allow
-	 the child procedure to access it.  */
-      if (is_internal_unit (dtp))
-	stash_internal_unit (dtp);
-
-      /* Call the user defined formatted READ procedure.  */
-      dtp->u.p.current_unit->child_dtio++;
-      dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
-		child_iostat, child_iomsg,
-		iotype_len, child_iomsg_len);
-      dtp->u.p.current_unit->child_dtio--;
-
-      return true;
-    }
 
   /* Get the length, data length, base pointer and rank of the variable.
      Set the default loop specification first.  */
@@ -3466,11 +3469,12 @@ get_name:
 		nl->var_name);
       goto nml_err_ret;
     }
+
   /* If a derived type, touch its components and restore the root
      namelist_info if we have parsed a qualified derived type
      component.  */
 
-  if (nl->type == BT_DERIVED)
+  if (nl->type == BT_DERIVED && nl->dtio_sub == NULL)
     nml_touch_nodes (nl);
 
   if (first_nl)