From dc42a736c9c76adf6b9e98cf121d37c7f64e607b Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Mon, 20 Feb 2017 10:52:50 +0000
Subject: [PATCH] re PR fortran/79382 (DTIO ICE)
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
---
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 78d40afea290..418f9267cb05 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d3e7e84236e8..52de1c113124 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 fab1612270a1..ce53f01cdea3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/dtio_10.f90 b/gcc/testsuite/gfortran.dg/dtio_10.f90
index 71354b7876f8..6ab6c3e68b44 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 000000000000..4ebddbbe854b
--- /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 <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
diff --git a/gcc/testsuite/gfortran.dg/dtio_24.f90 b/gcc/testsuite/gfortran.dg/dtio_24.f90
new file mode 100644
index 000000000000..eb59b9ec8ba5
--- /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 <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
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index a3a8c2249ee7..4cdb3b4f2521 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -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
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index b47f4e07c82c..36786c0349e6 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);
--
GitLab