diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e7f7334f119..acbfee9929b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2017-03-29 Jerry DeLisle + + 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. + 2017-03-29 Segher Boessenkool PR rtl-optimization/80233 diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90 index 6e66a3121fe..a90a238ed51 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 00000000000..c70dc344e64 --- /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 5323194af80..44352c1b754 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/ChangeLog b/libgfortran/ChangeLog index 13fe6bbeb44..897c2573ec1 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,11 @@ +2017-03-29 Jerry DeLisle + + 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 Janus Weil PR fortran/78661 diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 5514d19edae..76eafa80626 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)