From patchwork Fri Mar 10 18:17:39 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry DeLisle X-Patchwork-Id: 737510 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 3vfwVP2Mbgz9s7r for ; Sat, 11 Mar 2017 05:18:05 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="M56+DnNE"; 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=lf4eP/Wd0I3BhXNu2D/v3aMCXSH74xZyC5yJ6LIEzoLha/UhR5 c5t1JddesYKBs5iWCLnGqPVvY1fGX7ntNeyTqL0PcB7UPo1tdV4Sc0+tMOjgdKun zMLYoIZ+bNPsRaQZQ38NOqIwy2RHD2YJrGoMPnDdMhuccRZgjNsPCOMjk= 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=Ihc8SeHLPnbs2dtEffHtBvXjOi8=; b=M56+DnNENkD1fBTjse09 kH+/omDOMdDW88lL1j4tJ18SxVhik/+3K3gScNp6ce03PiLQ/5sR5W9XTYV+fAd7 GW8QNOzj9Qt2xmIrCRXHjM7sQYFgKXc6fZ6j6nAWvWFRwpkrkRIJo3/rhcCzvp6g aJAs1HuzFTkBn9Z2OaSnE1s= Received: (qmail 15382 invoked by alias); 10 Mar 2017 18:17:45 -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 15347 invoked by uid 89); 10 Mar 2017 18:17:44 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-20.5 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_SORBS_WEB, RP_MATCHES_RCVD, SPF_PASS, UNSUBSCRIBE_BODY autolearn=ham version=3.3.2 spammy=tough, jvdelisle@gcc.gnu.org, jvdelislegccgnuorg, OPEN X-Spam-User: qpsmtpd, 2 recipients X-HELO: mtaout003-public.msg.strl.va.charter.net Received: from mtaout003-public.msg.strl.va.charter.net (HELO mtaout003-public.msg.strl.va.charter.net) (68.114.190.28) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 10 Mar 2017 18:17:42 +0000 Received: from impout001 ([68.114.189.16]) by mtaout003.msg.strl.va.charter.net (InterMail vM.9.00.023.01 201-2473-194) with ESMTP id <20170310181741.IEGZ7355.mtaout003.msg.strl.va.charter.net@impout001>; Fri, 10 Mar 2017 12:17:41 -0600 Received: from amda8.localdomain ([66.96.68.196]) by impout001 with charter.net id uJHf1u00H4E4Wx601JHgQE; Fri, 10 Mar 2017 12:17:41 -0600 X-Authority-Analysis: v=2.2 cv=fL1J5dSe c=1 sm=1 tr=0 a=3BTVQCqdHQ9ozV1XzgarEg==:117 a=3BTVQCqdHQ9ozV1XzgarEg==:17 a=aYEP4OYVHkEA:10 a=r77TgQKjGQsHNAKrUKIA:9 a=mDV3o1hIAAAA:8 a=V93IX06UxngiwegP6AoA:9 a=QEXdDO2ut3YA:10 a=bN80ceqn6rdnQBxQxt8A:9 a=M3DauXBB3AzwNDe9:21 a=ygMxRCTqQjqjD9OD:21 a=hquHOILUSkIA:10 a=_FVE-zBwftR9WsbkzFJk:22 X-Auth-id: anZkZWxpc2xlQGNoYXJ0ZXIubmV0 To: "fortran@gcc.gnu.org" Cc: GCC Patches From: Jerry DeLisle Subject: [patch, libgfortran] PR78854 [F03] DTIO namelist output not working on internal unit Message-ID: <10edb617-84db-b2f6-4ccb-50a8734208df@charter.net> Date: Fri, 10 Mar 2017 10:17:39 -0800 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:45.0) Gecko/20100101 Thunderbird/45.7.0 MIME-Version: 1.0 Hi all, The attached patch fixes this PR by properly stashing the internal unit created by parent so that it may be correctly accessed by the child DTIO procedure. Note the included test case. The Fortran Standard requires that the iotype be passed to the child routine so that it is aware of what the intended purpose is. In the case of namelist I/O the iotype is set to "NAMELIST". It is up to the user to program the child procedure to look for that and do the right thing for namelists to work correctly. If a user chooses to ignore this feature, so be it, but tough luck if things don't work as "expected". There are some other DTIO bugs related to this one. Once I get this patch in I will be able to address those more specifically. Regression tested on x86_64. OK for trunk? Regards, Jerry 2017-03-10 Jerry DeLisle PR libgfortran/78854 * io/list_read.c (nml_get_obj_data): Stash internal unit for later use by child procedures. * io/write.c (nml_write_obj): Likewise. * io/tranfer.c (data_transfer_init): Minor whitespace. * io/unit.c (set_internal_uit): Look for the stashed internal unit and use it if found. 2017-03-10 Jerry DeLisle PR libgfortran/78854 * gfortran.dg/dtio_25.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90 new file mode 100644 index 00000000..fc049cd3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_25.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! PR78854 namelist write to internal unit. +module m + implicit none + type :: t + character :: c + integer :: k + contains + procedure :: write_formatted + generic :: write(formatted) => write_formatted + end type +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 + if (iotype.eq."NAMELIST") then + write (unit, '(a,a,a,a,i5)') 'x%c="',dtv%c,'",','x%k=', dtv%k + else + write (unit,*) dtv%c, dtv%k + end if + end subroutine +end module + +program p + use m + implicit none + character(len=50) :: buffer + type(t) :: x + namelist /nml/ x + x = t('a', 5) + write (buffer, nml) + if (buffer.ne.'&NML x%c="a",x%k= 5 /') call abort + x = t('x', 0) + read (buffer, nml) + if (x%c.ne.'a'.or. x%k.ne.5) call abort +end + diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index dd4ab72e..7f57ff1a 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -3301,6 +3301,11 @@ get_name: 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, diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 36786c03..fc22d802 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -2822,6 +2822,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) return; } } + /* Process the ADVANCE option. */ dtp->u.p.advance_status diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index ed3bc323..b733b939 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -461,6 +461,7 @@ set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind) { gfc_offset start_record = 0; + iunit->unit_number = dtp->common.unit; iunit->recl = dtp->internal_unit_len; iunit->internal_unit = dtp->internal_unit; iunit->internal_unit_len = dtp->internal_unit_len; @@ -598,15 +599,28 @@ get_unit (st_parameter_dt *dtp, int do_create) return unit; } } + + /* If an internal unit number is passed from the parent to the child + it should have been stashed on the newunit_stack ready to be used. + Check for it now and return the internal unit if found. */ + if (newunit_tos && (dtp->common.unit <= NEWUNIT_START) + && (dtp->common.unit == newunit_stack[newunit_tos].unit_number)) + { + unit = newunit_stack[newunit_tos--].unit; + return unit; + } + /* Has to be an external unit. */ dtp->u.p.unit_is_internal = 0; dtp->internal_unit = NULL; dtp->internal_unit_desc = NULL; + /* For an external unit with unit number < 0 creating it on the fly is not allowed, such units must be created with OPEN(NEWUNIT=...). */ if (dtp->common.unit < 0) return get_gfc_unit (dtp->common.unit, 0); + return get_gfc_unit (dtp->common.unit, do_create); } diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 47970d42..f03929e4 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -2253,6 +2253,12 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, child_iomsg_len = IOMSG_LEN; } namelist_write_newline (dtp); + + /* If writing to 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 WRITE procedure. */ dtp->u.p.current_unit->child_dtio++; dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,