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