re PR fortran/48298 ([F03] User-Defined Derived-Type IO (DTIO))

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

	PR fortran/48298
	* trans-io.c (transfer_expr): Ignore dtio procedures for inquire
	with iolength.

	* gfortran.dg/dtio_16.f90: New test.

From-SVN: r241216

4 files changed, 84 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6dce4eb..848b4bd 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2016-10-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/48298
+	* trans-io.c (transfer_expr): Ignore dtio procedures for inquire
+	with iolength.
+
 2016-10-15  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/77972
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 3cdbf1f..216317a 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -2325,7 +2325,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
 	  if (derived->attr.has_dtio_procs)
 	    arg2 = get_dtio_proc (ts, code, &dtio_sub);
 
-	  if (dtio_sub != NULL)
+	  if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
 	    {
 	      tree decl;
 	      decl = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e55d653..01fa6a7 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2016-10-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	* gfortran.dg/dtio_16.f90: New test.
+
 2016-10-15  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc.target/sparc/bmaskbshuf.c: Rename to...
diff --git a/gcc/testsuite/gfortran.dg/dtio_16.f90 b/gcc/testsuite/gfortran.dg/dtio_16.f90
new file mode 100644
index 0000000..0f462d5c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_16.f90
@@ -0,0 +1,73 @@
+! { dg-do run }
+! Tests that inquire(iolength=) treats derived types as if they do not
+! have User Defined procedures. Fortran Draft F2016 Standard, 9.10.3
+MODULE p
+  TYPE :: person
+    CHARACTER (LEN=20) :: name
+    INTEGER(4) :: age
+  END TYPE person
+  INTERFACE WRITE(FORMATTED)
+     MODULE procedure pwf
+  END INTERFACE
+  INTERFACE WRITE(UNFORMATTED)
+     MODULE procedure pwuf
+  END INTERFACE
+  INTERFACE read(FORMATTED)
+     MODULE procedure prf
+  END INTERFACE
+  INTERFACE read(UNFORMATTED)
+     MODULE procedure pruf
+  END INTERFACE
+CONTAINS
+  SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
+    CLASS(person), INTENT(IN) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    CHARACTER (LEN=*), INTENT(IN) :: iotype
+    INTEGER, INTENT(IN) :: vlist(:)
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+    WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age
+  END SUBROUTINE pwf
+
+  SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
+    CLASS(person), INTENT(INOUT) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    CHARACTER (LEN=*), INTENT(IN) :: iotype
+    INTEGER, INTENT(IN) :: vlist(:)
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+    READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+  END SUBROUTINE prf
+
+  SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
+    CLASS(person), INTENT(IN) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+    print *, "in pwuf"
+    WRITE (UNIT=UNIT, FMT = *) DTV%name, DTV%age
+  END SUBROUTINE pwuf
+
+  SUBROUTINE pruf (dtv,unit,iostat,iomsg)
+    CLASS(person), INTENT(INOUT) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+    print *, "in pruf"
+    READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+  END SUBROUTINE pruf
+
+END MODULE p
+
+PROGRAM test
+  USE p
+  IMPLICIT NONE
+  TYPE (person) :: chairman
+  integer(4) :: rl, tl, kl
+
+  chairman%name="Charlie"
+  chairman%age=62
+
+  inquire(iolength=rl) rl, kl, chairman, rl, chairman, tl
+  if (rl.ne.64) call abort
+END PROGRAM test