view gcc/testsuite/gfortran.dg/dtio_15.f90 @ 158:494b0b89df80 default tip

...
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 25 May 2020 18:13:55 +0900
parents 84e7813d76e9
children
line wrap: on
line source

! { dg-do run }
! Test that inquire of string internal unit in child process errors.
module string_m
  implicit none
  type person
    character(10) :: aname
    integer :: ijklmno
  contains
    procedure :: write_s
    generic :: write(formatted) => write_s
  end type person
contains
  subroutine write_s (this, lun, iotype, vlist, istat, imsg)
    class(person), intent(in)       :: this
    integer, intent(in)             :: lun
    character(len=*), intent(in)    :: iotype
    integer, intent(in)             :: vlist(:)
    integer, intent(out)            :: istat
    character(len=*), intent(inout) :: imsg
    integer :: filesize
    inquire( unit=lun, size=filesize, iostat=istat, iomsg=imsg)
    if (istat /= 0) return
  end subroutine write_s
end module string_m
program p
   use string_m
   type(person) :: s
   character(len=12) :: msg
   integer :: istat
   character(len=256) :: imsg = ""
   write( msg, "(DT)", iostat=istat) s
   if (istat /= 5018) STOP 1
end program p