From c680ada5f527a33ea7c793704019fb46c795d5f4 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Tue, 18 Oct 2016 04:14:25 +0000 Subject: [PATCH] re PR fortran/48298 ([F03] User-Defined Derived-Type IO (DTIO)) 2016-10-17 Jerry DeLisle PR fortran/48298 * io/io.h: Move size_used from dtp to unit structure. Add bool has_size to unit structure. * read.c (read_x): Use has_size and size_used. * transfer.c (read_sf_internal,read_sf,read_block_form, read_block_form4): Likewise. (data_transfer_init): If parent, initialize the size variables. (finalize_transfer): Set the size variable using size_used in gfc_unit. (write_block): Delete bogus/dead code. * gfortran.dg/dtio_17.f90: New test. From-SVN: r241294 --- gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gfortran.dg/dtio_17.f90 | 77 +++++++++++++++++++++++++++ libgfortran/ChangeLog | 12 +++++ libgfortran/io/io.h | 3 +- libgfortran/io/read.c | 5 +- libgfortran/io/transfer.c | 42 ++++++++++----- 6 files changed, 126 insertions(+), 17 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dtio_17.f90 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b962485a50a..6d57099bfc5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2016-10-17 Jerry DeLisle + + * gfortran.dg/dtio_17.f90: New test. + 2016-10-18 Kugan Vivekanandarajah * gcc.dg/ipa/vrp4.c: Adjust testcase. diff --git a/gcc/testsuite/gfortran.dg/dtio_17.f90 b/gcc/testsuite/gfortran.dg/dtio_17.f90 new file mode 100644 index 00000000000..a6b1fb39888 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_17.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! PR48298, this tests function of size= specifier with DTIO. +MODULE p + USE ISO_FORTRAN_ENV + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + CONTAINS + procedure :: pwf + procedure :: prf + GENERIC :: WRITE(FORMATTED) => pwf + GENERIC :: READ(FORMATTED) => prf + END TYPE person +CONTAINS + SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + CHARACTER (LEN=30) :: udfmt + INTEGER :: myios + + iomsg = "SUCCESS" + iostat=0 + if (iotype.eq."DT") then + WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + if (iotype.eq."LISTDIRECTED") then + WRITE(unit, '(*(g0))', IOSTAT=iostat) dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + END SUBROUTINE pwf + + SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + CHARACTER (LEN=30) :: udfmt + INTEGER :: myios + real :: areal + udfmt='(*(g0))' + iomsg = "SUCCESS" + iostat=0 + if (iotype.eq."DT") then + READ(unit, FMT = '(a20,i2)', IOSTAT=iostat) dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + END SUBROUTINE prf + +END MODULE p + +PROGRAM test + USE p + implicit none + TYPE (person) :: chairman + integer(4) :: rl, tl, kl, thesize + + chairman%name="Charlie" + chairman%age=62 + + open(28, status='scratch') + write(28, '(i10,i10,DT,i15,DT,i12)') rl, kl, chairman, rl, chairman, tl + rewind(28) + chairman%name="bogus" + chairman%age=99 + !print *, chairman + read(28, '(i10,i10,DT,i15,DT,i12)', advance='no', size=thesize) rl, & + & kl, chairman, rl, chairman, tl + if (thesize.ne.91) call abort + close(28) +END PROGRAM test diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index bfda86df86c..9662df891f5 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,15 @@ +2016-10-17 Jerry DeLisle + + PR fortran/48298 + * io/io.h: Move size_used from dtp to unit structure. Add bool + has_size to unit structure. + * read.c (read_x): Use has_size and size_used. + * transfer.c (read_sf_internal,read_sf,read_block_form, + read_block_form4): Likewise. + (data_transfer_init): If parent, initialize the size variables. + (finalize_transfer): Set the size variable using size_used in + gfc_unit. (write_block): Delete bogus/dead code. + 2016-10-16 Janne Blomqvist PR libfortran/48587 diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index aaacc089fc7..edc520a920f 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -514,7 +514,6 @@ typedef struct st_parameter_dt large enough to hold a complex value (two reals) of the largest kind. */ char value[32]; - GFC_IO_INT size_used; formatted_dtio fdtio_ptr; unformatted_dtio ufdtio_ptr; } p; @@ -650,6 +649,8 @@ typedef struct gfc_unit /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */ int child_dtio; int last_char; + bool has_size; + GFC_IO_INT size_used; } gfc_unit; diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index f8d5b72e47b..d72cdb37e11 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -1282,8 +1282,9 @@ read_x (st_parameter_dt *dtp, int n) } done: - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) n; + if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || + dtp->u.p.current_unit->has_size) + dtp->u.p.current_unit->size_used += (GFC_IO_INT) n; dtp->u.p.current_unit->bytes_left -= n; dtp->u.p.current_unit->strm_pos += (gfc_offset) n; } diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 2232417af6b..1f46ca64cf1 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -267,8 +267,9 @@ read_sf_internal (st_parameter_dt *dtp, int * length) dtp->u.p.current_unit->bytes_left -= *length; - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) *length; + if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || + dtp->u.p.current_unit->has_size) + dtp->u.p.current_unit->size_used += (GFC_IO_INT) *length; return base; @@ -397,8 +398,9 @@ read_sf (st_parameter_dt *dtp, int * length) dtp->u.p.current_unit->bytes_left -= n; - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) n; + if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || + dtp->u.p.current_unit->has_size) + dtp->u.p.current_unit->size_used += (GFC_IO_INT) n; /* We can't call fbuf_getptr before the loop doing fbuf_getc, because fbuf_getc might reallocate the buffer. So return current pointer @@ -478,8 +480,9 @@ read_block_form (st_parameter_dt *dtp, int * nbytes) source = fbuf_read (dtp->u.p.current_unit, nbytes); fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR); - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) *nbytes; + if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || + dtp->u.p.current_unit->has_size) + dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes; if (norig != *nbytes) { @@ -536,8 +539,9 @@ read_block_form4 (st_parameter_dt *dtp, int * nbytes) dtp->u.p.current_unit->bytes_left -= *nbytes; - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) *nbytes; + if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || + dtp->u.p.current_unit->has_size) + dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes; return source; } @@ -770,8 +774,9 @@ write_block (st_parameter_dt *dtp, int length) } } - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) length; + if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || + dtp->u.p.current_unit->has_size) + dtp->u.p.current_unit->size_used += (GFC_IO_INT) length; dtp->u.p.current_unit->strm_pos += (gfc_offset) length; @@ -2596,9 +2601,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; - if ((cf & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used = 0; /* Initialize the count. */ - dtp->u.p.current_unit = get_unit (dtp, 1); if (dtp->u.p.current_unit == NULL) @@ -2674,6 +2676,18 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) return; } + if (dtp->u.p.current_unit->child_dtio == 0) + { + if ((cf & IOPARM_DT_HAS_SIZE) != 0) + { + dtp->u.p.current_unit->has_size = true; + /* Initialize the count. */ + dtp->u.p.current_unit->size_used = 0; + } + else + dtp->u.p.current_unit->has_size = false; + } + /* Check the action. */ if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE) @@ -3772,7 +3786,7 @@ finalize_transfer (st_parameter_dt *dtp) return; if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - *dtp->size = dtp->u.p.size_used; + *dtp->size = dtp->u.p.current_unit->size_used; if (dtp->u.p.eor_condition) { -- 2.30.2