! { 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 |