From patchwork Sat Mar 25 13:41:25 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry DeLisle X-Patchwork-Id: 743484 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3vr1fg1wBnz9s3s for ; Sun, 26 Mar 2017 00:41:44 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="T5yA5Dww"; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to:cc :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=k8sbMU68HkAQLpFB4PIx4RLgZzJ9V7YKaanUKOrV5LVMStV8xK zQApdAIY2j2LiBD88ovvnXPhhgrcn4YPtFLQc55GeYVx+o3nnn1Sbq4R8YMcACxP e10j1v9RF0ijseRzb1WEun0auvaSlvMy+jfrQr9hlWKk3tS5G6GjYb14s= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to:cc :from:subject:message-id:date:mime-version:content-type; s= default; bh=WDbjrO/vfhfW7cnLnpQ1/iqywGo=; b=T5yA5DwwWoqAuLk7xIGH ROfSQZK4Msmw9ScqNelisYSa/y1EHUPPjQRtjiPg0bnB3bFhlNA4xd3fc6EABG52 fwWmsEqkmH+YvM1GsVgaLMw6lZgVRHzcWXxQ6mVjK21chUgMAuOnDUdoVYIzjv3S IwR2LLaa450ujTNj2s/bAik= Received: (qmail 82140 invoked by alias); 25 Mar 2017 13:41:30 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 81997 invoked by uid 89); 25 Mar 2017 13:41:29 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-25.1 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_LOW, RP_MATCHES_RCVD, SPF_PASS autolearn=ham version=3.3.2 spammy=H*r:InterMail, H*M:charter X-Spam-User: qpsmtpd, 2 recipients X-HELO: mtaout005-public.msg.strl.va.charter.net Received: from mtaout005-public.msg.strl.va.charter.net (HELO mtaout005-public.msg.strl.va.charter.net) (68.114.190.30) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sat, 25 Mar 2017 13:41:27 +0000 Received: from impout005 ([68.114.189.20]) by mtaout005.msg.strl.va.charter.net (InterMail vM.9.00.023.01 201-2473-194) with ESMTP id <20170325134126.VRTX7356.mtaout005.msg.strl.va.charter.net@impout005>; Sat, 25 Mar 2017 08:41:26 -0500 Received: from amda8.localdomain ([96.41.215.23]) by impout005 with charter.net id 0DhR1v0040Wrkg001DhRqR; Sat, 25 Mar 2017 08:41:26 -0500 X-Authority-Analysis: v=2.2 cv=O6pJhF1W c=1 sm=1 tr=0 a=salB9WdMPIDduBH7JsZfrA==:117 a=salB9WdMPIDduBH7JsZfrA==:17 a=aYEP4OYVHkEA:10 a=r77TgQKjGQsHNAKrUKIA:9 a=mDV3o1hIAAAA:8 a=zV5oU6kStGME50lcU4QA:9 a=QEXdDO2ut3YA:10 a=nbVG6ydUHlrScmh89qMA:9 a=HQS5GP9m128IKoul:21 a=J2n3EicjJvVxO5v_:21 a=hquHOILUSkIA:10 a=uE-rJ3KAziaFd6K17yAA:9 a=voGCI5DAS3EA:10 a=_FVE-zBwftR9WsbkzFJk:22 X-Auth-id: anZkZWxpc2xlQGNoYXJ0ZXIubmV0 To: "fortran@gcc.gnu.org" Cc: GCC Patches From: Jerry DeLisle Subject: [patch, libgfortran] PR78881 [F03] reading from string with DTIO procedure does not work properly Message-ID: <60af6724-6949-8bc3-d751-d345b32d7be9@charter.net> Date: Sat, 25 Mar 2017 06:41:25 -0700 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:45.0) Gecko/20100101 Thunderbird/45.8.0 MIME-Version: 1.0 Hi all, I managed to figure out the rest of this. Attached is updated full patch. I consolidated the two previous test cases into one which checks all four conditions I was concerned with. Regression tested on x86_64_linux. Ok for trunk? Regards, Jerry 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. Changelog for test case will be added. ! { 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/io/io.h b/libgfortran/io/io.h index 277c5ed7..df491577 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 7f57ff1a..39805baa 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 fc22d802..1e56b5de 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)