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

re PR fortran/79382 (DTIO ICE)

Browse Source 
2017-02-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/79382
	* decl.c (access_attr_decl): Test for presence of generic DTIO
	interface and emit error if not present.

2017-02-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/79382
	* io/transfer.c (check_dtio_proc): New function.
	(formatted_transfer_scalar_read): Use it.
	(formatted_transfer_scalar_write): ditto.

2017-02-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/79382
	* gfortran.dg/dtio_10.f90 : Change test of error message.
	* gfortran.dg/dtio_23.f90 : New test.
	* gfortran.dg/dtio_24.f90 : New test.

From-SVN: r245596
This commit is contained in:
Paul Thomas 2017-02-20 10:52:50 +00:00
parent 1ca6a74f89
commit dc42a736c9
8 changed files with 151 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2017-02-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/79382
* decl.c (access_attr_decl): Test for presence of generic DTIO
interface and emit error if not present.
2017-02-20 Paul Thomas <pault@gcc.gnu.org>
PR fortran/79434

15
gcc/fortran/decl.c
View File

@ -7568,6 +7568,21 @@ access_attr_decl (gfc_statement st)
case INTERFACE_GENERIC:
case INTERFACE_DTIO:
if (type == INTERFACE_DTIO
&& gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
{
gfc_find_symbol (name, gfc_current_ns, 0, &sym);
if (sym == NULL)
{
gfc_error ("The GENERIC DTIO INTERFACE at %C is not "
"present in the MODULE '%s'",
gfc_current_ns->proc_name->name);
return MATCH_ERROR;
}
}
if (gfc_get_symbol (name, NULL, &sym))
goto done;

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2017-02-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/79382
* gfortran.dg/dtio_10.f90 : Change test of error message.
* gfortran.dg/dtio_23.f90 : New test.
* gfortran.dg/dtio_24.f90 : New test.
2017-02-20 Paul Thomas <pault@gcc.gnu.org>
PR fortran/79434

2
gcc/testsuite/gfortran.dg/dtio_10.f90
View File

@ -23,5 +23,5 @@ program test1
read (10, fmt='(dt)', advance='no', size=thesize, iostat=ios, &
& iomsg=errormsg) i, udt1
if (ios.ne.5006) call abort
if (errormsg(1:25).ne."Expected CLASS or DERIVED") call abort
if (errormsg(27:47).ne."intrinsic type passed") call abort
end program test1

37
gcc/testsuite/gfortran.dg/dtio_23.f90 Normal file
View File

@ -0,0 +1,37 @@
! { dg-do compile }
!
! Test fix for the original in PR79832.
!
! Contributed by Walt Brainerd <walt.brainerd@gmail.com>
!
module dollar_mod
implicit none
private
type, public :: dollar_type
real :: amount
contains
procedure :: Write_dollar
generic :: write(formatted) => Write_dollar
end type dollar_type
PRIVATE :: write (formatted) ! { dg-error "is not present" }
contains
subroutine Write_dollar &
(dollar_value, unit, b_edit_descriptor, v_list, iostat, iomsg)
class (dollar_type), intent(in) :: dollar_value
integer, intent(in) :: unit
character (len=*), intent(in) :: b_edit_descriptor
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
write (unit=unit, fmt="(f9.2)", iostat=iostat) dollar_value%amount
end subroutine Write_dollar
end module dollar_mod

51
gcc/testsuite/gfortran.dg/dtio_24.f90 Normal file
View File

@ -0,0 +1,51 @@
! { dg-do run }
!
! Test fix for the additional bug that was found in fixing PR79832.
!
! Contributed by Walt Brainerd <walt.brainerd@gmail.com>
!
module dollar_mod
implicit none
private
type, public :: dollar_type
real :: amount
end type dollar_type
interface write(formatted)
module procedure Write_dollar
end interface
private :: write (formatted)
contains
subroutine Write_dollar &
(dollar_value, unit, b_edit_descriptor, v_list, iostat, iomsg)
class (dollar_type), intent(in) :: dollar_value
integer, intent(in) :: unit
character (len=*), intent(in) :: b_edit_descriptor
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
write (unit=unit, fmt="(f9.2)", iostat=iostat) dollar_value%amount
end subroutine Write_dollar
end module dollar_mod
program test_dollar
use :: dollar_mod
implicit none
integer :: ios
character(100) :: errormsg
type (dollar_type), parameter :: wage = dollar_type(15.10)
write (unit=*, fmt="(DT)", iostat=ios, iomsg=errormsg) wage
if (ios.ne.5006) call abort
if (errormsg(1:22).ne."Missing DTIO procedure") call abort
end program test_dollar

7
libgfortran/ChangeLog
View File

@ -1,3 +1,10 @@
2017-02-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/79382
* io/transfer.c (check_dtio_proc): New function.
(formatted_transfer_scalar_read): Use it.
(formatted_transfer_scalar_write): ditto.
2017-01-31 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/79305

27
libgfortran/io/transfer.c
View File

@ -1244,6 +1244,26 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
}
/* Check that the dtio procedure required for formatted IO is present. */
static int
check_dtio_proc (st_parameter_dt *dtp, const fnode *f)
{
char buffer[BUFLEN];
if (dtp->u.p.fdtio_ptr != NULL)
return 0;
snprintf (buffer, BUFLEN,
"Missing DTIO procedure or intrinsic type passed for item %d "
"in formatted transfer",
dtp->u.p.item_count - 1);
format_error (dtp, f, buffer);
return 1;
}
static int
require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
{
@ -1436,6 +1456,9 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
case FMT_DT:
if (n == 0)
goto need_read_data;
if (check_dtio_proc (dtp, f))
return;
if (require_type (dtp, BT_CLASS, type, f))
return;
int unit = dtp->u.p.current_unit->unit_number;
@ -1938,8 +1961,12 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
child_iomsg_len = IOMSG_LEN;
}
if (check_dtio_proc (dtp, f))
return;
/* Call the user defined formatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);