gcc/testsuite/gfortran.dg/dtio_28.f03

   1 ! { dg-do run }
   2 ! PR78670 Incorrect file position with namelist read under DTIO
   3 MODULE m
   4   IMPLICIT NONE
   5   TYPE :: t
   6     CHARACTER :: c
   7   CONTAINS
   8     PROCEDURE :: read_formatted
   9     GENERIC :: READ(FORMATTED) => read_formatted
  10     PROCEDURE :: write_formatted
  11     GENERIC :: WRITE(FORMATTED) => write_formatted
  12   END TYPE t
  13 CONTAINS
  14   SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  15     CLASS(t), INTENT(IN) :: dtv
  16     INTEGER, INTENT(IN) :: unit
  17     CHARACTER(*), INTENT(IN) :: iotype
  18     INTEGER, INTENT(IN) :: v_list(:)
  19     INTEGER, INTENT(OUT) :: iostat
  20     CHARACTER(*), INTENT(INOUT) :: iomsg
  21     write(unit,'(a)', iostat=iostat, iomsg=iomsg) dtv%c
  22   END SUBROUTINE write_formatted
  23
  24   SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  25     CLASS(t), INTENT(INOUT) :: dtv
  26     INTEGER, INTENT(IN) :: unit
  27     CHARACTER(*), INTENT(IN) :: iotype
  28     INTEGER, INTENT(IN) :: v_list(:)
  29     INTEGER, INTENT(OUT) :: iostat
  30     CHARACTER(*), INTENT(INOUT) :: iomsg
  31
  32     CHARACTER :: ch
  33     dtv%c = ''
  34     DO
  35       READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) ch
  36       IF (iostat /= 0) RETURN
  37       ! Store first non-blank
  38       IF (ch /= ' ') THEN
  39         dtv%c = ch
  40         RETURN
  41       END IF
  42     END DO
  43   END SUBROUTINE read_formatted
  44 END MODULE m
  45
  46 PROGRAM p
  47   USE m
  48   IMPLICIT NONE
  49   TYPE(t) :: x
  50   TYPE(t) :: y
  51   TYPE(t) :: z
  52   integer :: j, k
  53   NAMELIST /nml/ j, x, y, z, k
  54   INTEGER :: unit, iostatus
  55
  56   OPEN(NEWUNIT=unit, STATUS='SCRATCH', ACTION='READWRITE')
  57
  58   x%c = 'a'
  59   y%c = 'b'
  60   z%c = 'c'
  61   j=1
  62   k=2
  63   WRITE(unit, nml)
  64   REWIND (unit)
  65   x%c = 'x'
  66   y%c = 'y'
  67   z%c = 'x'
  68   j=99
  69   k=99
  70   READ (unit, nml, iostat=iostatus)
  71   if (iostatus.ne.0) STOP 1
  72   if (j.ne.1 .or. k.ne.2 .or. x%c.ne.'a' .or. y%c.ne.'b' .or. z%c.ne.'c') STOP 2
  73   !WRITE(*, nml)
  74 END PROGRAM p