gcc/testsuite/gfortran.dg/pr105456-nmlw.f90

   1 ! { dg-do run }
   2 ! { dg-shouldfail "The users message" }
   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     iostat = 42
  28     iomsg = "The users message"
  29   end subroutine
  30   subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  31     class(t), intent(inout) :: dtv
  32     integer, intent(in) :: unit
  33     character(*), intent(in) :: iotype
  34     integer, intent(in) :: v_list(:)
  35     integer, intent(out) :: iostat
  36     character(*), intent(inout) :: iomsg
  37     character :: comma
  38     if (iotype.eq."NAMELIST") then
  39       read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k
  40     else
  41       read (unit,*) dtv%c, comma, dtv%k
  42     end if
  43     if (comma /= ',') STOP 1
  44   end subroutine
  45 end module
  46
  47 program p
  48   use m
  49   implicit none
  50   character(len=50) :: buffer
  51   type(t) :: x
  52   namelist /nml/ x
  53   x = t('a', 5)
  54   write (buffer, nml)
  55   if (buffer.ne.' &NML  X=a,  5  /') STOP 1
  56   x = t('x', 0)
  57   read (buffer, nml)
  58   if (x%c.ne.'a'.or. x%k.ne.5) STOP 2
  59 end
  60 ! { dg-output "Fortran runtime error: The users message" }