gcc/testsuite/gfortran.dg/dtio_27.f90

   1 ! { dg-do run }
   2 !
   3 ! PR 78661: [OOP] Namelist output missing object designator under DTIO
   4 !
   5 ! Contributed by Ian Harvey <ian_harvey@bigpond.com>
   6
   7 MODULE m
   8   IMPLICIT NONE
   9   TYPE :: t
  10     CHARACTER :: c
  11   CONTAINS
  12     PROCEDURE :: write_formatted
  13     GENERIC :: WRITE(FORMATTED) => write_formatted
  14     PROCEDURE :: read_formatted
  15     GENERIC :: READ(FORMATTED) => read_formatted
  16   END TYPE
  17 CONTAINS
  18   SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  19     CLASS(t), INTENT(IN) :: dtv
  20     INTEGER, INTENT(IN) :: unit
  21     CHARACTER(*), INTENT(IN) :: iotype
  22     INTEGER, INTENT(IN) :: v_list(:)
  23     INTEGER, INTENT(OUT) :: iostat
  24     CHARACTER(*), INTENT(INOUT) :: iomsg
  25     WRITE (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c
  26   END SUBROUTINE
  27   SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
  28     CLASS(t), INTENT(INOUT) :: 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     READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c
  35   END SUBROUTINE
  36 END MODULE
  37
  38
  39 PROGRAM p
  40
  41   USE m
  42   IMPLICIT NONE
  43   character(len=4), dimension(3) :: buffer
  44   call test_type
  45   call test_class
  46
  47 contains
  48
  49   subroutine test_type
  50     type(t) :: x
  51     namelist /n1/ x
  52     x = t('a')
  53     write (buffer, n1)
  54     if (buffer(2) /= " X=a") call abort()
  55   end subroutine
  56
  57   subroutine test_class
  58     class(t), allocatable :: y
  59     namelist /n2/ y
  60     y = t('b')
  61     write (buffer, n2)
  62     if (buffer(2) /= " Y=b") call abort()
  63   end subroutine
  64
  65 END