From patchwork Thu Feb 20 12:54:57 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 322175 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 6DC792C00C4 for ; Thu, 20 Feb 2014 23:55:13 +1100 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; q=dns; s= default; b=K4ZtMomyKyCQgv3M9G1EBb/Dm2NnJSRWgY+6eeABR2W3MfIzluFVY grX8ehSyYERLr3uSTVnlRa3o/gpZXxhhcplYSo5jCYkEOM9U46G+VwmuxIy1pH9L x9QG4uOYXCcgL7Du3tZGSo0rMMWH9Xe+PKTiZ+Wh13GrDTCh3srapo= 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:date :from:to:subject:message-id:mime-version:content-type; s= default; bh=StFBE7Z3REvT4OKhxbIcW0pV45E=; b=gD+MRVoflmOLtUQbR+Iv oykjGNMWCMu3PVCjR8bbcwLR0qMfmRyUjTuJP9mQ2AkGx+oXXZnbjQsf81vf1hJ7 4QmqxvbyYcgQzJqNAsyva6jgwtV3/xogvEnPVavvrzt9i/pUSLSSOt1sV5CKzrQh dMYrm+WcbGyxGUVTNvj+Ms4= Received: (qmail 14689 invoked by alias); 20 Feb 2014 12:55:06 -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 14667 invoked by uid 89); 20 Feb 2014 12:55:05 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.5 required=5.0 tests=AWL, BAYES_00, RP_MATCHES_RCVD autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: outpost2.zedat.fu-berlin.de Received: from outpost2.zedat.fu-berlin.de (HELO outpost2.zedat.fu-berlin.de) (130.133.4.90) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Thu, 20 Feb 2014 12:55:04 +0000 Received: from relay1.zedat.fu-berlin.de ([130.133.4.67]) by outpost.zedat.fu-berlin.de (Exim 4.82) with esmtp (envelope-from ) id <1WGT9Y-002BIe-NP>; Thu, 20 Feb 2014 13:55:00 +0100 Received: from mx.physik.fu-berlin.de ([160.45.64.218]) by relay1.zedat.fu-berlin.de (Exim 4.82) with esmtps (envelope-from ) id <1WGT9Y-001XEB-Ke>; Thu, 20 Feb 2014 13:55:00 +0100 Received: from squeeze64.physik.fu-berlin.de ([160.45.66.239] helo=login.physik.fu-berlin.de) by mx.physik.fu-berlin.de with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:256) (Exim 4.80) (envelope-from ) id 1WGT9V-0002RD-Cc; Thu, 20 Feb 2014 13:54:57 +0100 Received: from tburnus by login.physik.fu-berlin.de with local (Exim 4.72 #1 (Debian)) id 1WGT9V-0005sd-Aa; Thu, 20 Feb 2014 13:54:57 +0100 Date: Thu, 20 Feb 2014 13:54:57 +0100 From: Tobias Burnus To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [Patch, Fortran] PR602864 - fix INQUIRE for write= with stdout/stdin/stderr Message-ID: <20140220125457.GA22026@physik.fu-berlin.de> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) A rather simple patch. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 2014-02-20 Tobias Burnus PR fortran/602864 * libgfortran/io/inquire.c (yes, no): New static const char vars. (inquire_via_unit): Use them. Return proper value for write=, read= and readwrite= for stdin/stdout/stderr. 2014-02-20 Tobias Burnus PR fortran/602864 * gfortran.dg/inquire_16.f90: New. diff --git a/gcc/testsuite/gfortran.dg/inquire_16.f90 b/gcc/testsuite/gfortran.dg/inquire_16.f90 new file mode 100644 index 0000000..03b735e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquire_16.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR fortran/602864 +! +! Contributed by Alexander Vogt +! +program test_inquire + use, intrinsic :: ISO_Fortran_env + implicit none + character(len=20) :: s_read, s_write, s_readwrite + + inquire(unit=input_unit, read=s_read, write=s_write, & + readwrite=s_readwrite) + if (s_read /= "YES" .or. s_write /= "NO" .or. s_readwrite /="NO") then + call abort() + endif + + inquire(unit=output_unit, read=s_read, write=s_write, & + readwrite=s_readwrite) + if (s_read /= "NO" .or. s_write /= "YES" .or. s_readwrite /="NO") then + call abort() + endif + + inquire(unit=error_unit, read=s_read, write=s_write, & + readwrite=s_readwrite) + if (s_read /= "NO" .or. s_write /= "YES" .or. s_readwrite /="NO") then + call abort() + endif +end program test_inquire diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c index b12ee51..3f8497a 100644 --- a/libgfortran/io/inquire.c +++ b/libgfortran/io/inquire.c @@ -30,7 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include -static const char undefined[] = "UNDEFINED"; +static const char yes[] = "YES", no[] = "NO", undefined[] = "UNDEFINED"; /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */ @@ -130,10 +130,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) { case ACCESS_DIRECT: case ACCESS_STREAM: - p = "NO"; + p = no; break; case ACCESS_SEQUENTIAL: - p = "YES"; + p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad access"); @@ -151,10 +151,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) { case ACCESS_SEQUENTIAL: case ACCESS_STREAM: - p = "NO"; + p = no; break; case ACCESS_DIRECT: - p = "YES"; + p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad access"); @@ -191,10 +191,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) switch (u->flags.form) { case FORM_FORMATTED: - p = "YES"; + p = yes; break; case FORM_UNFORMATTED: - p = "NO"; + p = no; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad form"); @@ -211,10 +211,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) switch (u->flags.form) { case FORM_FORMATTED: - p = "NO"; + p = no; break; case FORM_UNFORMATTED: - p = "YES"; + p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad form"); @@ -266,10 +266,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) switch (u->flags.pad) { case PAD_YES: - p = "YES"; + p = yes; break; case PAD_NO: - p = "NO"; + p = no; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); @@ -336,10 +336,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) switch (u->flags.async) { case ASYNC_YES: - p = "YES"; + p = yes; break; case ASYNC_NO: - p = "NO"; + p = no; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad async"); @@ -423,10 +423,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) { case ACCESS_SEQUENTIAL: case ACCESS_DIRECT: - p = "NO"; + p = no; break; case ACCESS_STREAM: - p = "YES"; + p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); @@ -499,7 +499,14 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) if ((cf & IOPARM_INQUIRE_HAS_READ) != 0) { - p = (u == NULL) ? inquire_read (NULL, 0) : + if (!u) + inquire_read (NULL, 0); + else if (u->unit_number == options.stdin_unit) + p = yes; + else if (u->unit_number == options.stdout_unit + || u->unit_number == options.stderr_unit) + p = no; + else inquire_read (u->file, u->file_len); cf_strcpy (iqp->read, iqp->read_len, p); @@ -507,7 +514,14 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0) { - p = (u == NULL) ? inquire_write (NULL, 0) : + if (!u) + inquire_write (NULL, 0); + else if (u->unit_number == options.stdin_unit) + p = no; + else if (u->unit_number == options.stdout_unit + || u->unit_number == options.stderr_unit) + p = yes; + else inquire_write (u->file, u->file_len); cf_strcpy (iqp->write, iqp->write_len, p); @@ -515,7 +529,13 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0) { - p = (u == NULL) ? inquire_readwrite (NULL, 0) : + if (!u) + inquire_readwrite (NULL, 0); + else if (u->unit_number == options.stdin_unit + || u->unit_number == options.stdout_unit + || u->unit_number == options.stderr_unit) + p = no; + else inquire_readwrite (u->file, u->file_len); cf_strcpy (iqp->readwrite, iqp->readwrite_len, p); @@ -552,10 +572,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) switch (u->flags.pad) { case PAD_NO: - p = "NO"; + p = no; break; case PAD_YES: - p = "YES"; + p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad pad");