gcc/testsuite/gfortran.dg/dtio_7.f90

   1 ! { dg-do run }
   2 !
   3 ! Tests dtio transfer of arrays of derived types and classes
   4 !
   5 MODULE 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
  29 CONTAINS
  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         call abort
  93     end select
  94   end subroutine
  95 END MODULE p
  96
  97 PROGRAM 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) call abort
 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) call abort                     ! 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) call abort
 137   end do
 138   close (7)
 139 END PROGRAM test