re PR fortran/78854 ([F03] DTIO namelist output not working on internal unit)

2017-03-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/78854
	* io/list_read.c (nml_get_obj_data): Stash internal unit for
	later use by child procedures.
	* io/write.c (nml_write_obj): Likewise.
	* io/tranfer.c (data_transfer_init): Minor whitespace.
	* io/unit.c (set_internal_uit): Look for the stashed internal
	unit and use it if found.

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

From-SVN: r246070

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8497890288878fc3db19dc42d3f2ba3b2e9b2e86..5607171ee5e0962a0f8f09ce2a6f1141469eb1e9 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2017-03-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR libgfortran/78854
+       * gfortran.dg/dtio_25.f90: New test.
+
 2017-03-10  Martin Sebor  <msebor@redhat.com>
 
        * gcc.dg/tree-ssa/builtin-sprintf-warn-3.c: Add a test case.

diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90
new file mode 100644 (file)
index 0000000..fc049cd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_25.f90
@@ -0,0 +1,41 @@
+! { dg-do run }
+! PR78854 namelist write to internal unit.
+module m
+  implicit none
+  type :: t
+    character :: c
+    integer :: k
+  contains
+    procedure :: write_formatted
+    generic :: write(formatted) => write_formatted
+  end type
+contains
+  subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    class(t), intent(in) :: dtv
+    integer, intent(in) :: unit
+    character(*), intent(in) :: iotype
+    integer, intent(in) :: v_list(:)
+    integer, intent(out) :: iostat
+    character(*), intent(inout) :: iomsg
+    if (iotype.eq."NAMELIST") then
+      write (unit, '(a,a,a,a,i5)') 'x%c="',dtv%c,'",','x%k=', dtv%k
+    else
+      write (unit,*) dtv%c, dtv%k
+    end if
+  end subroutine
+end module
+
+program p
+  use m
+  implicit none
+  character(len=50) :: buffer
+  type(t) :: x
+  namelist /nml/ x
+  x = t('a', 5)
+  write (buffer, nml)
+  if (buffer.ne.'&NML x%c="a",x%k=    5  /') call abort
+  x = t('x', 0)
+  read (buffer, nml)
+  if (x%c.ne.'a'.or. x%k.ne.5) call abort
+end
+

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index bd2f726670d0bbd1dd563a1c21bb7eb762ce4110..c16b6788b142d9f8e31569e30f3a2f671a2ac0e1 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,13 @@
+2017-03-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR libgfortran/78854
+       * io/list_read.c (nml_get_obj_data): Stash internal unit for
+       later use by child procedures.
+       * io/write.c (nml_write_obj): Likewise.
+       * io/tranfer.c (data_transfer_init): Minor whitespace.
+       * io/unit.c (set_internal_uit): Look for the stashed internal
+       unit and use it if found.
+
 2017-03-10  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR libfortran/79956

diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index dd4ab72e05e0501ed412b2e9d5bc9f9cd58919a1..7f57ff1a91606629e9658d11068bd30892edcab1 100644 (file)
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -3301,6 +3301,11 @@ get_name:
          child_iomsg_len = IOMSG_LEN;
        }
 
+      /* If reading from an internal unit, stash it to allow
+        the child procedure to access it.  */
+      if (is_internal_unit (dtp))
+       stash_internal_unit (dtp);
+
       /* Call the user defined formatted READ procedure.  */
       dtp->u.p.current_unit->child_dtio++;
       dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,

diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 36786c0349e62019fc63cbcd3533927046ad2fd7..fc22d802196ee94926e7259025f57528d6e56b2a 100644 (file)
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -2822,6 +2822,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
          return;
        }
     }
+
   /* Process the ADVANCE option.  */
 
   dtp->u.p.advance_status

diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index ed3bc3231ec350b840534a675a7d12cb0c2ede37..b733b939b69edf90274f120971b0bd465fccc4a1 100644 (file)
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -461,6 +461,7 @@ set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
 {
   gfc_offset start_record = 0;
 
+  iunit->unit_number = dtp->common.unit;
   iunit->recl = dtp->internal_unit_len;
   iunit->internal_unit = dtp->internal_unit;
   iunit->internal_unit_len = dtp->internal_unit_len;
@@ -598,15 +599,28 @@ get_unit (st_parameter_dt *dtp, int do_create)
          return unit;
        }
     }
+
+  /* If an internal unit number is passed from the parent to the child
+     it should have been stashed on the newunit_stack ready to be used.
+     Check for it now and return the internal unit if found.  */
+  if (newunit_tos && (dtp->common.unit <= NEWUNIT_START)
+      && (dtp->common.unit == newunit_stack[newunit_tos].unit_number))
+    {
+      unit = newunit_stack[newunit_tos--].unit;
+      return unit;
+    }
+
   /* Has to be an external unit.  */
   dtp->u.p.unit_is_internal = 0;
   dtp->internal_unit = NULL;
   dtp->internal_unit_desc = NULL;
+
   /* For an external unit with unit number < 0 creating it on the fly
      is not allowed, such units must be created with
      OPEN(NEWUNIT=...).  */
   if (dtp->common.unit < 0)
     return get_gfc_unit (dtp->common.unit, 0);
+
   return get_gfc_unit (dtp->common.unit, do_create);
 }
 

diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index 47970d42de19d0a7fd015cb4420e562d074afd49..f03929e49f8039003a7f81e3c11d00a3342e8788 100644 (file)
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -2253,6 +2253,12 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
                      child_iomsg_len = IOMSG_LEN;
                    }
                  namelist_write_newline (dtp);
+
+                 /* If writing to an internal unit, stash it to allow
+                    the child procedure to access it.  */
+                 if (is_internal_unit (dtp))
+                   stash_internal_unit (dtp);
+                     
                  /* Call the user defined formatted WRITE procedure.  */
                  dtp->u.p.current_unit->child_dtio++;
                  dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,