gcc/testsuite/gfortran.dg/pr105456-nmlr.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   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     endif
  41     iostat = 42
  42     iomsg = "The users message"
  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" }