From: Jerry DeLisle Date: Sat, 11 Mar 2017 14:49:57 +0000 (+0000) Subject: re PR fortran/78854 ([F03] DTIO namelist output not working on internal unit) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c08de9db47cea407e4399c987d2b8b9b6a6413ed;p=gcc.git re PR fortran/78854 ([F03] DTIO namelist output not working on internal unit) 2017-03-11 Jerry DeLisle 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 84978902888..5607171ee5e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-03-11 Jerry DeLisle + + PR libgfortran/78854 + * gfortran.dg/dtio_25.f90: New test. + 2017-03-10 Martin Sebor * 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 index 00000000000..fc049cd3e37 --- /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 bd2f726670d..c16b6788b14 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,13 @@ +2017-03-11 Jerry DeLisle + + 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 PR libfortran/79956 diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index dd4ab72e05e..7f57ff1a916 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 36786c0349e..fc22d802196 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 ed3bc3231ec..b733b939b69 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 47970d42de1..f03929e49f8 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,