gcc/testsuite/gfortran.dg/dtio_25.f90

   1 ! { dg-do run }
   2 ! PR78854 namelist write to internal unit.
   3 module m
   4   implicit none
   5   type :: t
   6     character :: c
   7     integer :: k
   8   contains
   9     procedure :: write_formatted
  10     generic :: write(formatted) => write_formatted
  11     procedure :: read_formatted
  12     generic :: read(formatted) => read_formatted
  13   end type
  14 contains
  15   subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  16     class(t), intent(in) :: dtv
  17     integer, intent(in) :: unit
  18     character(*), intent(in) :: iotype
  19     integer, intent(in) :: v_list(:)
  20     integer, intent(out) :: iostat
  21     character(*), intent(inout) :: iomsg
  22     if (iotype.eq."NAMELIST") then
  23       write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k
  24     else
  25       write (unit,*) dtv%c, dtv%k
  26     end if
  27   end subroutine
  28   subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  29     class(t), intent(inout) :: dtv
  30     integer, intent(in) :: unit
  31     character(*), intent(in) :: iotype
  32     integer, intent(in) :: v_list(:)
  33     integer, intent(out) :: iostat
  34     character(*), intent(inout) :: iomsg
  35     character :: comma
  36     if (iotype.eq."NAMELIST") then
  37       read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k
  38     else
  39       read (unit,*) dtv%c, comma, dtv%k
  40     end if
  41     if (comma /= ',') STOP 1
  42   end subroutine
  43 end module
  44
  45 program p
  46   use m
  47   implicit none
  48   character(len=50) :: buffer
  49   type(t) :: x
  50   namelist /nml/ x
  51   x = t('a', 5)
  52   write (buffer, nml)
  53   if (buffer.ne.'&NML  X=a,  5  /') STOP 1
  54   x = t('x', 0)
  55   read (buffer, nml)
  56   if (x%c.ne.'a'.or. x%k.ne.5) STOP 2
  57 end