Hi all,
The attached patch resolves this problem by moving the code that invokes the
child I/O procedure into nml_read_obj where it belongs. This allows the normal
flow of code that parses the namelist decorations before attempting to read the
object data.
One new test case is provided. Test case dtio_25.f90 is updated to fix it. One
minor tweak on dtio_4.f90. (tests are in the patch)
As a followup, I will be testing for arrays of derived types in namelists. If
any problems there I will open a new PR.
Regression tested on x86-64-linux.
OK for trunk?
Regards,
Jerry
2017-03-28 Jerry DeLisle <jvdeli...@gcc.gnu.org>
PR libgfortran/78670
* io/list_read.c (nml_get_obj_data): Delete code which calls the
child read procedure. (nml_read_obj): Insert the code which
calls the child procedure. Don't need to touch nodes if using
dtio since parent will not be traversing the components.
2017-03-28 Jerry DeLisle <jvdeli...@gcc.gnu.org>
PR libgfortran/78670
* gfortran.dg/dtio_25.f90: Use 'a1' format when trying to read
a character of length 1. Update test for success.
* gfortran.dg/dtio_28.f03: New test.
* gfortran.dg/dtio_4.f90: Update to open test file with status =
'scratch' to delete the file when done.
diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90
index 6e66a312..a90a238e 100644
--- a/gcc/testsuite/gfortran.dg/dtio_25.f90
+++ b/gcc/testsuite/gfortran.dg/dtio_25.f90
@@ -20,7 +20,7 @@ contains
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
if (iotype.eq."NAMELIST") then
- write (unit, '(a3,a1,i3)') dtv%c,',', dtv%k
+ write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k
else
write (unit,*) dtv%c, dtv%k
end if
@@ -34,7 +34,7 @@ contains
character(*), intent(inout) :: iomsg
character :: comma
if (iotype.eq."NAMELIST") then
- read (unit, '(a4,a1,i3)') dtv%c, comma, dtv%k ! FIXME: need a4 here, with a3 above
+ read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k
else
read (unit,*) dtv%c, comma, dtv%k
end if
@@ -50,7 +50,7 @@ program p
namelist /nml/ x
x = t('a', 5)
write (buffer, nml)
- if (buffer.ne.'&NML X= a, 5 /') call abort
+ if (buffer.ne.'&NML X=a, 5 /') call abort
x = t('x', 0)
read (buffer, nml)
if (x%c.ne.'a'.or. x%k.ne.5) call abort
diff --git a/gcc/testsuite/gfortran.dg/dtio_28.f03 b/gcc/testsuite/gfortran.dg/dtio_28.f03
new file mode 100644
index 00000000..c70dc344
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_28.f03
@@ -0,0 +1,74 @@
+! { dg-do run }
+! PR78670 Incorrect file position with namelist read under DTIO
+MODULE m
+ IMPLICIT NONE
+ TYPE :: t
+ CHARACTER :: c
+ CONTAINS
+ PROCEDURE :: read_formatted
+ GENERIC :: READ(FORMATTED) => read_formatted
+ PROCEDURE :: write_formatted
+ GENERIC :: WRITE(FORMATTED) => write_formatted
+ END TYPE t
+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
+ write(unit,'(a)', iostat=iostat, iomsg=iomsg) dtv%c
+ END SUBROUTINE write_formatted
+
+ SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+ CLASS(t), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER(*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: v_list(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER(*), INTENT(INOUT) :: iomsg
+
+ CHARACTER :: ch
+ dtv%c = ''
+ DO
+ READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) ch
+ IF (iostat /= 0) RETURN
+ ! Store first non-blank
+ IF (ch /= ' ') THEN
+ dtv%c = ch
+ RETURN
+ END IF
+ END DO
+ END SUBROUTINE read_formatted
+END MODULE m
+
+PROGRAM p
+ USE m
+ IMPLICIT NONE
+ TYPE(t) :: x
+ TYPE(t) :: y
+ TYPE(t) :: z
+ integer :: j, k
+ NAMELIST /nml/ j, x, y, z, k
+ INTEGER :: unit, iostatus
+
+ OPEN(NEWUNIT=unit, STATUS='SCRATCH', ACTION='READWRITE')
+
+ x%c = 'a'
+ y%c = 'b'
+ z%c = 'c'
+ j=1
+ k=2
+ WRITE(unit, nml)
+ REWIND (unit)
+ x%c = 'x'
+ y%c = 'y'
+ z%c = 'x'
+ j=99
+ k=99
+ READ (unit, nml, iostat=iostatus)
+ if (iostatus.ne.0) call abort
+ if (j.ne.1 .or. k.ne.2 .or. x%c.ne.'a' .or. y%c.ne.'b' .or. z%c.ne.'c') call abort
+ !WRITE(*, nml)
+END PROGRAM p
diff --git a/gcc/testsuite/gfortran.dg/dtio_4.f90 b/gcc/testsuite/gfortran.dg/dtio_4.f90
index 5323194a..44352c1b 100644
--- a/gcc/testsuite/gfortran.dg/dtio_4.f90
+++ b/gcc/testsuite/gfortran.dg/dtio_4.f90
@@ -96,7 +96,7 @@ program test1
if (iomsg.ne.'SUCCESS') call abort
if (any(udt1%myarray.ne.result_array)) call abort
close(10)
- open (10, form='formatted')
+ open (10, form='formatted', status='scratch')
write (10, '(dt)') more1
rewind(10)
more1%myarray = 99
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 5514d19e..76eafa80 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -2958,6 +2958,61 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
break;
case BT_DERIVED:
+ /* If this object has a User Defined procedure, call it. */
+ if (nl->dtio_sub != NULL)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "NAMELIST";
+ gfc_charlen_type iotype_len = 8;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+ gfc_class list_obj;
+ formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
+
+ GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ list_obj.data = (void *)nl->mem_pos;
+ list_obj.vptr = nl->vtable;
+ list_obj.len = 0;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ 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,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.child_saved_iostat = *child_iostat;
+ dtp->u.p.current_unit->child_dtio--;
+ goto incr_idx;
+ }
+
+ /* Must be default derived type namelist read. */
obj_name_len = strlen (nl->var_name) + 1;
obj_name = xmalloc (obj_name_len+1);
memcpy (obj_name, nl->var_name, obj_name_len-1);
@@ -3268,58 +3323,6 @@ get_name:
goto nml_err_ret;
}
- else if (nl->dtio_sub != NULL)
- {
- int unit = dtp->u.p.current_unit->unit_number;
- char iotype[] = "NAMELIST";
- gfc_charlen_type iotype_len = 8;
- char tmp_iomsg[IOMSG_LEN] = "";
- char *child_iomsg;
- gfc_charlen_type child_iomsg_len;
- int noiostat;
- int *child_iostat = NULL;
- gfc_array_i4 vlist;
- gfc_class list_obj;
- formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
-
- GFC_DESCRIPTOR_DATA(&vlist) = NULL;
- GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
-
- list_obj.data = (void *)nl->mem_pos;
- list_obj.vptr = nl->vtable;
- list_obj.len = 0;
-
- /* Set iostat, intent(out). */
- noiostat = 0;
- child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
- dtp->common.iostat : &noiostat;
-
- /* Set iomsg, intent(inout). */
- if (dtp->common.flags & IOPARM_HAS_IOMSG)
- {
- child_iomsg = dtp->common.iomsg;
- child_iomsg_len = dtp->common.iomsg_len;
- }
- else
- {
- child_iomsg = tmp_iomsg;
- 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,
- child_iostat, child_iomsg,
- iotype_len, child_iomsg_len);
- dtp->u.p.current_unit->child_dtio--;
-
- return true;
- }
/* Get the length, data length, base pointer and rank of the variable.
Set the default loop specification first. */
@@ -3466,11 +3469,12 @@ get_name:
nl->var_name);
goto nml_err_ret;
}
+
/* If a derived type, touch its components and restore the root
namelist_info if we have parsed a qualified derived type
component. */
- if (nl->type == BT_DERIVED)
+ if (nl->type == BT_DERIVED && nl->dtio_sub == NULL)
nml_touch_nodes (nl);
if (first_nl)