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

4 files changed, 87 insertions, 4 deletions

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e7f7334..acbfee9 100644
--- a/gcc/testsuite/ChangeLog
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90
index 6e66a31..a90a238 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 0000000..c70dc34
--- /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 5323194..44352c1 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