gcc/testsuite/gfortran.dg/dtio_3.f90

! { dg-do run }
!
! Functional test of User Defined Derived Type IO.
!
! This tests recursive calls where a derived type has a member that is
! itself.
!
MODULE p
  USE ISO_FORTRAN_ENV
  TYPE :: person
    CHARACTER (LEN=20) :: name
    INTEGER(4) :: age
    type(person), pointer :: next => NULL()
    CONTAINS
      procedure :: pwf
      procedure :: prf
      GENERIC :: WRITE(FORMATTED) => pwf
      GENERIC :: READ(FORMATTED) => prf
  END TYPE person
CONTAINS
  RECURSIVE SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
    CLASS(person), INTENT(IN) :: dtv
    INTEGER, INTENT(IN) :: unit
    CHARACTER (LEN=*), INTENT(IN) :: iotype
    INTEGER, INTENT(IN) :: vlist(:)
    INTEGER, INTENT(OUT) :: iostat
    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
    CHARACTER (LEN=30) :: udfmt
    INTEGER :: myios

    udfmt='(*(g0))'
    iomsg = "SUCCESS"
    iostat=0
    if (iotype.eq."DT") then
      if (size(vlist).ne.0) print *, 36
      if (associated(dtv%next)) then
        WRITE(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next
      else
        WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
      endif
      if (iostat.ne.0) iomsg = "Fail PWF DT"
    endif
    if (iotype.eq."DTzeroth") then
      if (size(vlist).ne.0) print *, 40
      WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age
      if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
    endif
    if (iotype.eq."DTtwo") then
      if (size(vlist).ne.2) STOP 1
      WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
      WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age
      if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
    endif
    if (iotype.eq."DTthree") then
      WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
      WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14
      if (iostat.ne.0) iomsg = "Fail PWF DTthree"
    endif
    if (iotype.eq."LISTDIRECTED") then
      if (size(vlist).ne.0) print *, 55
      if (associated(dtv%next)) then
        WRITE(unit, FMT = *) dtv%name, dtv%age, dtv%next
      else
        WRITE(unit, FMT = *) dtv%name, dtv%age
      endif
      if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
    endif
    if (iotype.eq."NAMELIST") then
      if (size(vlist).ne.0) print *, 59
      iostat=6000
    endif
    if (associated (dtv%next) .and. (iotype.eq."LISTDIRECTED")) write(unit, fmt = *) dtv%next
  END SUBROUTINE pwf

  RECURSIVE SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
    CLASS(person), INTENT(INOUT) :: dtv
    INTEGER, INTENT(IN) :: unit
    CHARACTER (LEN=*), INTENT(IN) :: iotype
    INTEGER, INTENT(IN) :: vlist(:)
    INTEGER, INTENT(OUT) :: iostat
    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
    CHARACTER (LEN=30) :: udfmt
    INTEGER :: myios
    real :: areal
    udfmt='(*(g0))'
    iomsg = "SUCCESS"
    iostat=0
    if (iotype.eq."DT") then
      if (size(vlist).ne.0) print *, 36
      if (associated(dtv%next)) then
        READ(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next
      else
        READ(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
      endif
      if (iostat.ne.0) iomsg = "Fail PWF DT"
    endif
    if (iotype.eq."DTzeroth") then
      if (size(vlist).ne.0) print *, 40
      READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
      if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
    endif
    if (iotype.eq."DTtwo") then
      if (size(vlist).ne.2) STOP 1
      WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
      READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
      if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
    endif
    if (iotype.eq."DTthree") then
      WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
      READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
      if (iostat.ne.0) iomsg = "Fail PWF DTthree"
    endif
    if (iotype.eq."LISTDIRECTED") then
      if (size(vlist).ne.0) print *, 55
      READ(unit, FMT = *) dtv%name, dtv%age
      if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
    endif
    if (iotype.eq."NAMELIST") then
      if (size(vlist).ne.0) print *, 59
      iostat=6000
    endif
    !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
  END SUBROUTINE prf

END MODULE p

PROGRAM test
  USE p
  TYPE (person) :: chairman
  TYPE (person), target :: member
  character(80) :: astring
  integer :: thelength

  chairman%name="Charlie"
  chairman%age=62
  member%name="George"
  member%age=42
  astring = "FAILURE"
  ! At this point, next is NULL as defined up in the type block.
  open(10, status = "scratch")
  write (10, *, iostat=myiostat, iomsg=astring) member, chairman
  write(10,*)
  rewind(10)
  chairman%name="bogus1"
  chairman%age=99
  member%name="bogus2"
  member%age=66
  read (10, *, iostat=myiostat, iomsg=astring) member, chairman
  if (astring.ne."SUCCESS") print *, astring
  if (member%name.ne."George") STOP 1
  if (chairman%name.ne."Charlie") STOP 1
  if (member%age.ne.42) STOP 1
  if (chairman%age.ne.62) STOP 1
  close(10, status='delete')
  ! Now we set next to point to member. This changes the code path
  ! in the pwf and prf procedures.
  chairman%next => member
  open(10, status = "scratch")
  write (10,"(DT)") chairman
  rewind(10)
  chairman%name="bogus1"
  chairman%age=99
  member%name="bogus2"
  member%age=66
  read (10,"(DT)", iomsg=astring) chairman
  !print *, trim(astring)
  if (member%name.ne."George") STOP 1
  if (chairman%name.ne."Charlie") STOP 1
  if (member%age.ne.42) STOP 1
  if (chairman%age.ne.62) STOP 1
  close(10)
END PROGRAM test