diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8306a1c0c35..005cbe4dec3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-03-25 Jerry DeLisle + + PR libgfortran/78881 + * gfortran.dg/dtio_26.f90: New test. + 2017-03-25 Paul Thomas PR fortran/80156 diff --git a/gcc/testsuite/gfortran.dg/dtio_26.f03 b/gcc/testsuite/gfortran.dg/dtio_26.f03 new file mode 100644 index 00000000000..e947545fb49 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_26.f03 @@ -0,0 +1,69 @@ +! { dg-do run } +! PR78881 test for correct end of record condition and ignoring advance= +module t_m + use, intrinsic :: iso_fortran_env, only : iostat_end, iostat_eor, output_unit + implicit none + type, public :: t + character(len=:), allocatable :: m_s + contains + procedure, pass(this) :: read_t + generic :: read(formatted) => read_t + end type t +contains +subroutine read_t(this, lun, iotype, vlist, istat, imsg) + class(t), intent(inout) :: this + integer, intent(in) :: lun + character(len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: istat + character(len=*), intent(inout) :: imsg + character(len=1) :: c + integer :: i + i = 0 ; imsg='' + loop_read: do + i = i + 1 + read( unit=lun, fmt='(a1)', iostat=istat, iomsg=imsg) c + select case ( istat ) + case ( 0 ) + if (i.eq.1 .and. c.ne.'h') exit loop_read + !write( output_unit, fmt=sfmt) "i = ", i, ", c = ", c + case ( iostat_end ) + !write( output_unit, fmt=sfmt) "i = ", i, ", istat = iostat_end" + exit loop_read + case ( iostat_eor ) + !write( output_unit, fmt=sfmt) "i = ", i, ", istat = iostat_eor" + exit loop_read + case default + !write( output_unit, fmt=sfmt) "i = ", i, ", istat = ", istat + exit loop_read + end select + if (i.gt.10) exit loop_read + end do loop_read +end subroutine read_t +end module t_m + +program p + use t_m, only : t + implicit none + + character(len=:), allocatable :: s + type(t) :: foo + character(len=256) :: imsg + integer :: istat + + open(10, status="scratch") + write(10,'(a)') 'hello' + rewind(10) + read(unit=10, fmt='(dt)', iostat=istat, iomsg=imsg) foo + if (imsg.ne."End of record") call abort + rewind(10) + read(unit=10, fmt=*, iostat=istat, iomsg=imsg) foo + if (imsg.ne."End of record") call abort + s = "hello" + read( unit=s, fmt='(dt)', iostat=istat, iomsg=imsg) foo + if (imsg.ne."End of record") call abort + read( unit=s, fmt=*, iostat=istat, iomsg=imsg) foo + if (imsg.ne."End of record") call abort +end program p + +! { dg-final { cleanup-modules "t_m" } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 96b75e9292a..12e3f1fa696 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,21 @@ +2017-03-25 Jerry DeLisle + + PR libgfortran/78881 + * io/io.h (st_parameter_dt): Rename unused component last_char to + child_saved_iostat. Move comment to gfc_unit. + * io/list_read.c (list_formatted_read_scalar): After call to + child READ procedure, save the returned iostat value for later + check. (finish_list_read): Only finish READ if child_saved_iostat + was OK. + * io/transfer.c (read_sf_internal): If there is a saved character + in last character, seek back one. Add a new check for EOR + condition. (read_sf): If there is a saved character + in last character, seek back one. (formatted_transfer_scalar_read): + Initialize last character before invoking child procedure. + (data_transfer_init): If child dtio, set advance + status to nonadvancing. Move update of size and check for EOR + condition to before child dtio return. + 2017-03-17 Thomas Koenig PR libfortran/79956 diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 277c5ed7806..df491577349 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -534,10 +534,7 @@ typedef struct st_parameter_dt unsigned expanded_read : 1; /* 13 unused bits. */ - /* Used for ungetc() style functionality. Possible values - are an unsigned char, EOF, or EOF - 1 used to mark the - field as not valid. */ - int last_char; /* No longer used, moved to gfc_unit. */ + int child_saved_iostat; int nml_delim; int repeat_count; int saved_length; @@ -701,6 +698,10 @@ typedef struct gfc_unit /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */ int child_dtio; + + /* Used for ungetc() style functionality. Possible values + are an unsigned char, EOF, or EOF - 1 used to mark the + field as not valid. */ int last_char; bool has_size; GFC_IO_INT size_used; diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 7f57ff1a916..39805baaeab 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -2221,6 +2221,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, dtp->u.p.fdtio_ptr (p, &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--; } break; @@ -2352,15 +2353,18 @@ finish_list_read (st_parameter_dt *dtp) /* Set the next_char and push_char worker functions. */ set_workers (dtp); - c = next_char (dtp); - if (c == EOF) + if (likely (dtp->u.p.child_saved_iostat == LIBERROR_OK)) { - free_line (dtp); - hit_eof (dtp); - return; + c = next_char (dtp); + if (c == EOF) + { + free_line (dtp); + hit_eof (dtp); + return; + } + if (c != '\n') + eat_line (dtp); } - if (c != '\n') - eat_line (dtp); } free_line (dtp); diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index fc22d802196..1e56b5de136 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -226,7 +226,7 @@ static char * read_sf_internal (st_parameter_dt *dtp, int * length) { static char *empty_string[0]; - char *base; + char *base = NULL; int lorig; /* Zero size array gives internal unit len of 0. Nothing to read. */ @@ -244,6 +244,15 @@ read_sf_internal (st_parameter_dt *dtp, int * length) return (char*) empty_string; } + /* There are some cases with mixed DTIO where we have read a character + and saved it in the last character buffer, so we need to backup. */ + if (unlikely (dtp->u.p.current_unit->child_dtio > 0 && + dtp->u.p.current_unit->last_char != EOF - 1)) + { + dtp->u.p.current_unit->last_char = EOF - 1; + sseek (dtp->u.p.current_unit->s, -1, SEEK_CUR); + } + lorig = *length; if (is_char4_unit(dtp)) { @@ -263,6 +272,12 @@ read_sf_internal (st_parameter_dt *dtp, int * length) return NULL; } + if (base && *base == 0) + { + generate_error (&dtp->common, LIBERROR_EOR, NULL); + return NULL; + } + dtp->u.p.current_unit->bytes_left -= *length; if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || @@ -304,6 +319,15 @@ read_sf (st_parameter_dt *dtp, int * length) return (char*) empty_string; } + /* There are some cases with mixed DTIO where we have read a character + and saved it in the last character buffer, so we need to backup. */ + if (unlikely (dtp->u.p.current_unit->child_dtio > 0 && + dtp->u.p.current_unit->last_char != EOF - 1)) + { + dtp->u.p.current_unit->last_char = EOF - 1; + fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR); + } + n = seen_comma = 0; /* Read data into format buffer and scan through it. */ @@ -1499,6 +1523,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind /* Call the user defined formatted READ procedure. */ dtp->u.p.current_unit->child_dtio++; + dtp->u.p.current_unit->last_char = EOF - 1; dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist, child_iostat, child_iomsg, iotype_len, child_iomsg_len); @@ -2856,6 +2881,11 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) } } + /* Child IO is non-advancing and any ADVANCE= specifier is ignored. + F2008 9.6.2.4 */ + if (dtp->u.p.current_unit->child_dtio > 0) + dtp->u.p.advance_status = ADVANCE_NO; + if (read_flag) { dtp->u.p.current_unit->previous_nonadvancing_write = 0; @@ -3856,6 +3886,15 @@ finalize_transfer (st_parameter_dt *dtp) namelist_write (dtp); } + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) + *dtp->size = dtp->u.p.current_unit->size_used; + + if (dtp->u.p.eor_condition) + { + generate_error (&dtp->common, LIBERROR_EOR, NULL); + goto done; + } + if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0)) { if (cf & IOPARM_DT_HAS_FORMAT) @@ -3866,15 +3905,6 @@ finalize_transfer (st_parameter_dt *dtp) return; } - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - *dtp->size = dtp->u.p.current_unit->size_used; - - if (dtp->u.p.eor_condition) - { - generate_error (&dtp->common, LIBERROR_EOR, NULL); - goto done; - } - if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) { if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)