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

gcc/testsuite/ChangeLog

+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.

gcc/testsuite/gfortran.dg/dtio_25.f90

+! { 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
+

libgfortran/ChangeLog

+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

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,

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

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);
 }
 

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,