Hi all,
The attached patch fixes this PR by properly stashing the internal unit created
by parent so that it may be correctly accessed by the child DTIO procedure.
Note the included test case. The Fortran Standard requires that the iotype be
passed to the child routine so that it is aware of what the intended purpose is.
In the case of namelist I/O the iotype is set to "NAMELIST". It is up to the
user to program the child procedure to look for that and do the right thing for
namelists to work correctly. If a user chooses to ignore this feature, so be
it, but tough luck if things don't work as "expected".
There are some other DTIO bugs related to this one. Once I get this patch in I
will be able to address those more specifically.
Regression tested on x86_64.
OK for trunk?
Regards,
Jerry
2017-03-10 Jerry DeLisle <jvdeli...@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 Jerry DeLisle <jvdeli...@gcc.gnu.org>
PR libgfortran/78854
* gfortran.dg/dtio_25.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90
new file mode 100644
index 00000000..fc049cd3
--- /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/io/list_read.c b/libgfortran/io/list_read.c
index dd4ab72e..7f57ff1a 100644
--- 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 36786c03..fc22d802 100644
--- 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 ed3bc323..b733b939 100644
--- 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 47970d42..f03929e4 100644
--- 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,
