From dc42a736c9c76adf6b9e98cf121d37c7f64e607b Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 20 Feb 2017 10:52:50 +0000 Subject: [PATCH] re PR fortran/79382 (DTIO ICE) 2017-02-16 Paul Thomas 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 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 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 --- gcc/fortran/ChangeLog | 6 ++++ gcc/fortran/decl.c | 15 ++++++++ gcc/testsuite/ChangeLog | 7 ++++ gcc/testsuite/gfortran.dg/dtio_10.f90 | 2 +- gcc/testsuite/gfortran.dg/dtio_23.f90 | 37 +++++++++++++++++++ gcc/testsuite/gfortran.dg/dtio_24.f90 | 51 +++++++++++++++++++++++++++ libgfortran/ChangeLog | 7 ++++ libgfortran/io/transfer.c | 27 ++++++++++++++ 8 files changed, 151 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/dtio_23.f90 create mode 100644 gcc/testsuite/gfortran.dg/dtio_24.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 78d40afea29..418f9267cb0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2017-02-16 Paul Thomas + + 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 PR fortran/79434 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index d3e7e84236e..52de1c11312 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fab1612270a..ce53f01cdea 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2017-02-16 Paul Thomas + + 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 PR fortran/79434 diff --git a/gcc/testsuite/gfortran.dg/dtio_10.f90 b/gcc/testsuite/gfortran.dg/dtio_10.f90 index 71354b7876f..6ab6c3e68b4 100644 --- a/gcc/testsuite/gfortran.dg/dtio_10.f90 +++ b/gcc/testsuite/gfortran.dg/dtio_10.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_23.f90 b/gcc/testsuite/gfortran.dg/dtio_23.f90 new file mode 100644 index 00000000000..4ebddbbe854 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_23.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! Test fix for the original in PR79832. +! +! Contributed by Walt Brainerd +! +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 diff --git a/gcc/testsuite/gfortran.dg/dtio_24.f90 b/gcc/testsuite/gfortran.dg/dtio_24.f90 new file mode 100644 index 00000000000..eb59b9ec8ba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_24.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! Test fix for the additional bug that was found in fixing PR79832. +! +! Contributed by Walt Brainerd +! +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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index a3a8c2249ee..4cdb3b4f252 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,10 @@ +2017-02-16 Paul Thomas + + 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 PR fortran/79305 diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index b47f4e07c82..36786c0349e 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -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); -- 2.30.2