gcc/testsuite/gfortran.dg/dtio_12.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR77657 in which the DTIO subroutine was not found,
   4 ! which led to an error in attempting to link to the abstract interface.
   5 !
   6 ! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
   7 !
   8 MODULE abstract_parent
   9   implicit none
  10
  11   type, abstract :: parent
  12   contains
  13     procedure(write_formatted_interface), deferred :: write_formatted
  14     generic :: write(formatted) => write_formatted
  15   end type parent
  16
  17   abstract interface
  18     subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg)
  19       import parent
  20       class(parent), intent(in) :: this
  21       integer, intent(in) :: unit
  22       character (len=*), intent(in) :: iotype
  23       integer, intent(in) :: vlist(:)
  24       integer, intent(out) :: iostat
  25       character (len=*), intent(inout) :: iomsg
  26     end subroutine
  27   end interface
  28
  29 end module
  30
  31 module child_module
  32   use abstract_parent, only : parent
  33   implicit none
  34
  35   type, extends(parent) :: child
  36     integer :: i = 99
  37   contains
  38     procedure :: write_formatted
  39   end type
  40 contains
  41   subroutine write_formatted(this,unit,iotype,vlist,iostat,iomsg)
  42     class(child), intent(in) :: this
  43     integer, intent(in) :: unit
  44     character (len=*), intent(in) :: iotype
  45     integer, intent(in) :: vlist(:)
  46     integer, intent(out) :: iostat
  47     character (len=*), intent(inout) :: iomsg
  48     write (unit, "(i4)") this%i
  49   end subroutine
  50 end module
  51
  52   use child_module, only : child
  53   implicit none
  54   type (child) :: baby
  55   integer :: v(1), istat
  56   character(20) :: msg
  57   open (10, status = "scratch")
  58   call baby%write_formatted(10, "abcd", v, istat, msg) ! Call the dtio proc directly
  59   rewind (10)
  60   read (10, *) msg
  61   if (trim (msg) .ne. "99") call abort
  62   rewind (10)
  63   baby%i = 42
  64   write (10,"(DT)") baby                               ! Call the dtio proc via the library
  65   rewind (10)
  66   read (10, *) msg
  67   if (trim (msg) .ne. "42") call abort
  68   rewind (10)
  69   write (10,"(DT)") child (77)                         ! The original testcase
  70   rewind (10)
  71   read (10, *) msg
  72   if (trim (msg) .ne. "77") call abort
  73   rewind (10)
  74   write (10,40) child (77)                         ! Modified using format label
  75 40 format(DT)
  76   rewind (10)
  77   read (10, *) msg
  78   if (trim (msg) .ne. "77") call abort
  79   close(10)
  80 end