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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6dce4ebeb6a79a1579ab2d284b7607e9b028501e..848b4bde1d8479d08bd3e0b6a004b2081e42e808 100644 (file)
--- 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 3cdbf1fd2cac79c2c1e12dc74fa88cc41b54107b..216317ad3d356ab14066817a8c62f1192cfe27c3 100644 (file)
--- 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 e55d653284c256afdf260b60cc0103378fe5a330..01fa6a78c9b86c8c55de16d5ac3f15de16cfbcc1 100644 (file)
--- 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 (file)
index 0000000..0f462d5
--- /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