re PR fortran/78670 ([F03] Incorrect file position with namelist read under DTIO)

2017-03-29  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.

	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.

From-SVN: r246576

gcc/testsuite/ChangeLog

@@ -1,3 +1,12 @@
+2017-03-29  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.
+
 2017-03-29  Segher Boessenkool  <segher@kernel.crashing.org>
 
 	PR rtl-optimization/80233

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

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

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

libgfortran/ChangeLog

@@ -1,3 +1,11 @@
+2017-03-29  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  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/78661

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)