Mercurial > hg > CbC > CbC_gcc
diff gcc/testsuite/gfortran.dg/dtio_30.f03 @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/testsuite/gfortran.dg/dtio_30.f03 Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,60 @@ +! { dg-do run } +! PR80333 Namelist dtio write of array of class does not traverse the array +! This test checks both NAMELIST WRITE and READ of an array of class +module m + implicit none + type :: t + character :: c + character :: d + contains + procedure :: read_formatted + generic :: read(formatted) => read_formatted + procedure :: write_formatted + generic :: write(formatted) => write_formatted + end type t +contains + subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + integer :: i + read(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d + end subroutine read_formatted + + subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + write(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d + end subroutine write_formatted +end module m + +program p + use m + implicit none + class(t), dimension(:,:), allocatable :: w + namelist /nml/ w + integer :: unit, iostatus + character(256) :: str = "" + + open(10, status='scratch') + allocate(w(10,3)) + w = t('j','r') + w(5:7,2)%c='k' + write(10, nml) + rewind(10) + w = t('p','z') + read(10, nml) + write(str,*) w + if (str.ne." jr jr jr jr jr jr jr jr jr jr jr jr jr jr kr kr kr jr jr jr jr jr jr jr jr jr jr jr jr jr") & + & call abort + str = "" + write(str,"(*(DT))") w + if (str.ne."jrjrjrjrjrjrjrjrjrjrjrjrjrjrkrkrkrjrjrjrjrjrjrjrjrjrjrjrjrjr") call abort +end program p