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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 78d40afea290d8446b5f2278fb9126c04a545aa8..418f9267cb05fa3884cbe0e3989e199200040f16 100644 (file)
--- 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 d3e7e84236e8452ec12860ef857ed4453dd25dc2..52de1c113124fcbbd80979feed91919b0a9b2c97 100644 (file)
--- 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 fab1612270a1c969fed080ee524b7380145d28d0..ce53f01cdea301f8958242585aa50a2529f2cbc9 100644 (file)
--- 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 71354b7876f8d3e686cdb8958d6c63dbebb1f7de..6ab6c3e68b4407e4cb36052a49ca314e4ed739b9 100644 (file)
--- 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 (file)
index 0000000..4ebddbb
--- /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 (file)
index 0000000..eb59b9e
--- /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 a3a8c2249ee7d5b53905bc8f27aec3eb2c3961ab..4cdb3b4f2521b3ba6411c0f03d9ccb961fb371d7 100644 (file)
--- 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 b47f4e07c82cf16481e4dc14cfb55385c84efae0..36786c0349e62019fc63cbcd3533927046ad2fd7 100644 (file)
--- 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);