| ! { dg-do run } |
| ! |
| ! Functional test of User Defined Derived Type IO. |
| ! |
| ! This tests a combination of module procedure and generic procedure |
| ! and performs reading and writing an array with a pseudo user defined |
| ! tag at the beginning of the file. |
| ! |
| module usertypes |
| type udt |
| integer :: myarray(15) |
| contains |
| procedure :: user_defined_read |
| generic :: read (formatted) => user_defined_read |
| end type udt |
| type, extends(udt) :: more |
| integer :: someinteger = -25 |
| end type |
| |
| interface write(formatted) |
| module procedure user_defined_write |
| end interface |
| |
| integer :: result_array(15) |
| contains |
| subroutine user_defined_read (dtv, unit, iotype, v_list, iostat, iomsg) |
| class(udt), intent(inout) :: dtv |
| integer, intent(in) :: unit |
| character(*), intent(in) :: iotype |
| integer, intent(in) :: v_list (:) |
| integer, intent(out) :: iostat |
| character(*), intent(inout) :: iomsg |
| character(10) :: typestring |
| |
| iomsg = 'SUCCESS' |
| read (unit, '(a6)', iostat=iostat, iomsg=iomsg) typestring |
| typestring = trim(typestring) |
| select type (dtv) |
| type is (udt) |
| if (typestring.eq.' UDT: ') then |
| read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray |
| else |
| iostat = 6000 |
| iomsg = 'FAILURE' |
| end if |
| type is (more) |
| if (typestring.eq.' MORE: ') then |
| read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray |
| else |
| iostat = 6000 |
| iomsg = 'FAILUREwhat' |
| end if |
| end select |
| end subroutine user_defined_read |
| |
| subroutine user_defined_write (dtv, unit, iotype, v_list, iostat, iomsg) |
| class(udt), intent(in) :: dtv |
| integer, intent(in) :: unit |
| character(*), intent(in) :: iotype |
| integer, intent(in) :: v_list (:) |
| integer, intent(out) :: iostat |
| character(*), intent(inout) :: iomsg |
| character(10) :: typestring |
| select type (dtv) |
| type is (udt) |
| write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "UDT: " |
| write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray |
| type is (more) |
| write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "MORE: " |
| write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray |
| end select |
| write (unit,*) |
| end subroutine user_defined_write |
| end module usertypes |
| |
| program test1 |
| use usertypes |
| type (udt) :: udt1 |
| type (more) :: more1 |
| class (more), allocatable :: somemore |
| integer :: thesize, i, ios |
| character(25):: iomsg |
| |
| ! Create a file that contains some data for testing. |
| open (10, form='formatted', status='scratch') |
| write(10, '(a)') ' UDT: ' |
| do i = 1, 15 |
| write(10,'(i5)', advance='no') i |
| end do |
| write(10,*) |
| rewind(10) |
| udt1%myarray = 99 |
| result_array = (/ (i, i = 1, 15) /) |
| more1%myarray = result_array |
| read (10, fmt='(dt)', advance='no', iomsg=iomsg) udt1 |
| if (iomsg.ne.'SUCCESS') STOP 1 |
| if (any(udt1%myarray.ne.result_array)) STOP 1 |
| close(10) |
| open (10, form='formatted', status='scratch') |
| write (10, '(dt)') more1 |
| rewind(10) |
| more1%myarray = 99 |
| read (10, '(dt)', iostat=ios, iomsg=iomsg) more1 |
| if (iomsg.ne.'SUCCESS') STOP 1 |
| if (any(more1%myarray.ne.result_array)) STOP 1 |
| close (10) |
| end program test1 |