From ddd12b5fb06e5b7a11ef65bd50509d30305afb8b Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Wed, 5 Oct 2016 04:39:33 +0000 Subject: [PATCH] 2016-10-04 Jerry DeLisle io/inquire.c (inquire_via_unit): Add check for internal unit passed into child IO procedure. From-SVN: r240768 --- gcc/testsuite/gfortran.dg/dtio_15.f90 | 33 +++++++++++++++++++++++++++ libgfortran/ChangeLog | 5 ++++ libgfortran/io/inquire.c | 4 +++- 3 files changed, 41 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/dtio_15.f90 diff --git a/gcc/testsuite/gfortran.dg/dtio_15.f90 b/gcc/testsuite/gfortran.dg/dtio_15.f90 new file mode 100644 index 00000000000..040bb3ebe1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_15.f90 @@ -0,0 +1,33 @@ +! {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) call abort +end program p diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 5430ed18850..0e5c4d2c003 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,8 @@ +2016-10-04 Jerry DeLisle + + io/inquire.c (inquire_via_unit): Add check for internal unit + passed into child IO procedure. + 2016-10-01 Andre Vehreschild PR fortran/77663 diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c index 2bb518b69c7..7751b8df4db 100644 --- a/libgfortran/io/inquire.c +++ b/libgfortran/io/inquire.c @@ -41,7 +41,9 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) const char *p; GFC_INTEGER_4 cf = iqp->common.flags; - if (iqp->common.unit == GFC_INTERNAL_UNIT || iqp->common.unit == GFC_INTERNAL_UNIT4) + if (iqp->common.unit == GFC_INTERNAL_UNIT || + iqp->common.unit == GFC_INTERNAL_UNIT4 || + u->internal_unit_kind != 0) generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL); if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) -- 2.30.2