@@ -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
new file mode 100644
@@ -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
@@ -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
@@ -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)