OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

2016-10-04 Jerry DeLisle <jvdelisle@gcc.gnu.org> 

io/inquire.c (inquire_via_unit): Add check for internal unit
	passed into child IO procedure.

From-SVN: r240768
This commit is contained in:
Jerry DeLisle 2016-10-05 04:39:33 +00:00
parent 3aa27eae35
commit ddd12b5fb0
3 changed files with 41 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
gcc/testsuite/gfortran.dg/dtio_15.f90 Normal file
View File

@ -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

5
libgfortran/ChangeLog
View File

@ -1,3 +1,8 @@
2016-10-04 Jerry DeLisle <jvdelisle@gcc.gnu.org>
io/inquire.c (inquire_via_unit): Add check for internal unit
passed into child IO procedure.
2016-10-01 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/77663

4
libgfortran/io/inquire.c
View File

@ -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)