gcc/testsuite/gfortran.dg/dtio_30.f03

   1 ! { dg-do run }
   2 ! PR80333  Namelist dtio write of array of class does not traverse the array
   3 ! This test checks both NAMELIST WRITE and READ of an array of class
   4 module m
   5   implicit none
   6   type :: t
   7     character :: c
   8     character :: d
   9   contains
  10     procedure :: read_formatted
  11     generic :: read(formatted) => read_formatted
  12     procedure :: write_formatted
  13     generic :: write(formatted) => write_formatted
  14   end type t
  15 contains
  16   subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  17     class(t), intent(inout) :: dtv
  18     integer, intent(in) :: unit
  19     character(*), intent(in) :: iotype
  20     integer, intent(in) :: v_list(:)
  21     integer, intent(out) :: iostat
  22     character(*), intent(inout) :: iomsg
  23     integer :: i
  24     read(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d
  25   end subroutine read_formatted
  26
  27   subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  28     class(t), intent(in) :: dtv
  29     integer, intent(in) :: unit
  30     character(*), intent(in) :: iotype
  31     integer, intent(in) :: v_list(:)
  32     integer, intent(out) :: iostat
  33     character(*), intent(inout) :: iomsg
  34     write(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d
  35   end subroutine write_formatted
  36 end module m
  37
  38 program p
  39   use m
  40   implicit none
  41   class(t), dimension(:,:), allocatable :: w
  42   namelist /nml/  w
  43   integer :: unit, iostatus
  44   character(256) :: str = ""
  45
  46   open(10, status='scratch')
  47   allocate(w(10,3))
  48   w = t('j','r')
  49   w(5:7,2)%c='k'
  50   write(10, nml)
  51   rewind(10)
  52   w = t('p','z')
  53   read(10, nml)
  54   write(str,*) w
  55   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") &
  56       & call abort
  57   str = ""
  58   write(str,"(*(DT))") w
  59   if (str.ne."jrjrjrjrjrjrjrjrjrjrjrjrjrjrkrkrkrjrjrjrjrjrjrjrjrjrjrjrjrjr") call abort
  60 end program p