1! { dg-do run }
2!
3! Tests dtio transfer of arrays of derived types and classes
4!
5MODULE p
6  TYPE :: person
7    CHARACTER (LEN=20) :: name
8    INTEGER(4) :: age
9    CONTAINS
10      procedure :: pwf
11      procedure :: prf
12      GENERIC :: WRITE(FORMATTED) => pwf
13      GENERIC :: READ(FORMATTED) => prf
14  END TYPE person
15  type, extends(person) :: employee
16    character(20) :: job_title
17  end type
18  type, extends(person) :: officer
19    character(20) :: position
20  end type
21  type, extends(person) :: member
22    integer :: membership_number
23  end type
24  type :: club
25    type(employee), allocatable :: staff(:)
26    class(person), allocatable :: committee(:)
27    class(person), allocatable :: membership(:)
28  end type
29CONTAINS
30  SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
31    CLASS(person), INTENT(IN) :: dtv
32    INTEGER, INTENT(IN) :: unit
33    CHARACTER (LEN=*), INTENT(IN) :: iotype
34    INTEGER, INTENT(IN) :: vlist(:)
35    INTEGER, INTENT(OUT) :: iostat
36    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
37    select type (dtv)
38      type is (employee)
39        WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Employee"
40        WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%job_title
41      type is (officer)
42        WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Officer"
43        WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%position
44      type is (member)
45        WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Member"
46        WRITE(unit, FMT = "(A20,I4,I4/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%membership_number
47      class default
48        WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Ugggh!"
49        WRITE(unit, FMT = "(A20,I4,' '/)", IOSTAT=iostat) dtv%name, dtv%age
50    end select
51  END SUBROUTINE pwf
52
53  SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
54    CLASS(person), INTENT(INOUT) :: dtv
55    INTEGER, INTENT(IN) :: unit
56    CHARACTER (LEN=*), INTENT(IN) :: iotype
57    INTEGER, INTENT(IN) :: vlist(:)
58    INTEGER, INTENT(OUT) :: iostat
59    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
60    character (20) :: header, rname, jtitle, oposition
61    integer :: i
62    integer :: no
63    integer :: age
64    iostat = 0
65    select type (dtv)
66
67      type is (employee)
68        read (unit = unit, fmt = *) header
69        READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, jtitle
70        if (trim (rname) .ne. dtv%name) iostat = 1
71        if (age .ne. dtv%age) iostat = 2
72        if (trim (jtitle) .ne. dtv%job_title) iostat = 3
73        if (iotype .ne. "DTstaff") iostat = 4
74
75      type is (officer)
76        read (unit = unit, fmt = *) header
77        READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, oposition
78        if (trim (rname) .ne. dtv%name) iostat = 1
79        if (age .ne. dtv%age) iostat = 2
80        if (trim (oposition) .ne. dtv%position) iostat = 3
81        if (iotype .ne. "DTofficers") iostat = 4
82
83      type is (member)
84        read (unit = unit, fmt = *) header
85        READ (UNIT = UNIT, FMT = "(A20,I4,I4)") rname, age, no
86        if (trim (rname) .ne. dtv%name) iostat = 1
87        if (age .ne. dtv%age) iostat = 2
88        if (no .ne. dtv%membership_number) iostat = 3
89        if (iotype .ne. "DTmembers") iostat = 4
90
91      class default
92        STOP 1
93    end select
94  end subroutine
95END MODULE p
96
97PROGRAM test
98  USE p
99
100  type (club) :: social_club
101  TYPE (person) :: chairman
102  CLASS (person), allocatable :: president(:)
103  character (40) :: line
104  integer :: i, j
105
106  allocate (social_club%staff, source = [employee ("Bert",25,"Barman"), &
107                                         employee ("Joy",16,"Auditor")])
108
109  allocate (social_club%committee, source = [officer ("Hank",32, "Chair"), &
110                                             officer ("Ann", 29, "Secretary")])
111
112  allocate (social_club%membership, source = [member ("Dan",52,1), &
113                                              member ("Sue",39,2)])
114
115  chairman%name="Charlie"
116  chairman%age=62
117
118  open (7, status = "scratch")
119  write (7,*) social_club%staff                ! Tests array of derived types
120  write (7,*) social_club%committee            ! Tests class array
121  do i = 1, size (social_club%membership, 1)
122    write (7,*) social_club%membership(i)      ! Tests class array elements
123  end do
124
125  rewind (7)
126  read (7, "(DT'staff')", iostat = i) social_club%staff
127  if (i .ne. 0) STOP 2
128
129  social_club%committee(2)%age = 33            ! Introduce an error
130
131  read (7, "(DT'officers')", iostat = i) social_club%committee
132  if (i .ne. 2) STOP 3! Pick up error
133
134  do j = 1, size (social_club%membership, 1)
135    read (7, "(DT'members')", iostat = i) social_club%membership(j)
136    if (i .ne. 0) STOP 4
137  end do
138  close (7)
139END PROGRAM test
140