view gcc/testsuite/gfortran.dg/dtio_28.f03 @ 152:2b5abeee2509

update gcc11
author anatofuz
date Mon, 25 May 2020 07:50:57 +0900
parents 84e7813d76e9
children
line wrap: on
line source

! { 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) STOP 1
  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
  !WRITE(*, nml)
END PROGRAM p