| ! { dg-do run } |
| ! |
| ! Tests dtio transfer of arrays of derived types and classes |
| ! |
| MODULE p |
| TYPE :: person |
| CHARACTER (LEN=20) :: name |
| INTEGER(4) :: age |
| CONTAINS |
| procedure :: pwf |
| procedure :: prf |
| GENERIC :: WRITE(FORMATTED) => pwf |
| GENERIC :: READ(FORMATTED) => prf |
| END TYPE person |
| type, extends(person) :: employee |
| character(20) :: job_title |
| end type |
| type, extends(person) :: officer |
| character(20) :: position |
| end type |
| type, extends(person) :: member |
| integer :: membership_number |
| end type |
| type :: club |
| type(employee), allocatable :: staff(:) |
| class(person), allocatable :: committee(:) |
| class(person), allocatable :: membership(:) |
| end type |
| CONTAINS |
| 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 |
| select type (dtv) |
| type is (employee) |
| WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Employee" |
| WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%job_title |
| type is (officer) |
| WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Officer" |
| WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%position |
| type is (member) |
| WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Member" |
| WRITE(unit, FMT = "(A20,I4,I4/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%membership_number |
| class default |
| WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Ugggh!" |
| WRITE(unit, FMT = "(A20,I4,' '/)", IOSTAT=iostat) dtv%name, dtv%age |
| end select |
| END SUBROUTINE pwf |
| |
| 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 (20) :: header, rname, jtitle, oposition |
| integer :: i |
| integer :: no |
| integer :: age |
| iostat = 0 |
| select type (dtv) |
| |
| type is (employee) |
| read (unit = unit, fmt = *) header |
| READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, jtitle |
| if (trim (rname) .ne. dtv%name) iostat = 1 |
| if (age .ne. dtv%age) iostat = 2 |
| if (trim (jtitle) .ne. dtv%job_title) iostat = 3 |
| if (iotype .ne. "DTstaff") iostat = 4 |
| |
| type is (officer) |
| read (unit = unit, fmt = *) header |
| READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, oposition |
| if (trim (rname) .ne. dtv%name) iostat = 1 |
| if (age .ne. dtv%age) iostat = 2 |
| if (trim (oposition) .ne. dtv%position) iostat = 3 |
| if (iotype .ne. "DTofficers") iostat = 4 |
| |
| type is (member) |
| read (unit = unit, fmt = *) header |
| READ (UNIT = UNIT, FMT = "(A20,I4,I4)") rname, age, no |
| if (trim (rname) .ne. dtv%name) iostat = 1 |
| if (age .ne. dtv%age) iostat = 2 |
| if (no .ne. dtv%membership_number) iostat = 3 |
| if (iotype .ne. "DTmembers") iostat = 4 |
| |
| class default |
| STOP 1 |
| end select |
| end subroutine |
| END MODULE p |
| |
| PROGRAM test |
| USE p |
| |
| type (club) :: social_club |
| TYPE (person) :: chairman |
| CLASS (person), allocatable :: president(:) |
| character (40) :: line |
| integer :: i, j |
| |
| allocate (social_club%staff, source = [employee ("Bert",25,"Barman"), & |
| employee ("Joy",16,"Auditor")]) |
| |
| allocate (social_club%committee, source = [officer ("Hank",32, "Chair"), & |
| officer ("Ann", 29, "Secretary")]) |
| |
| allocate (social_club%membership, source = [member ("Dan",52,1), & |
| member ("Sue",39,2)]) |
| |
| chairman%name="Charlie" |
| chairman%age=62 |
| |
| open (7, status = "scratch") |
| write (7,*) social_club%staff ! Tests array of derived types |
| write (7,*) social_club%committee ! Tests class array |
| do i = 1, size (social_club%membership, 1) |
| write (7,*) social_club%membership(i) ! Tests class array elements |
| end do |
| |
| rewind (7) |
| read (7, "(DT'staff')", iostat = i) social_club%staff |
| if (i .ne. 0) STOP 2 |
| |
| social_club%committee(2)%age = 33 ! Introduce an error |
| |
| read (7, "(DT'officers')", iostat = i) social_club%committee |
| if (i .ne. 2) STOP 3! Pick up error |
| |
| do j = 1, size (social_club%membership, 1) |
| read (7, "(DT'members')", iostat = i) social_club%membership(j) |
| if (i .ne. 0) STOP 4 |
| end do |
| close (7) |
| END PROGRAM test |