From patchwork Wed Sep 25 17:35:32 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Bernd Edlinger X-Patchwork-Id: 277942 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 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client did not present a certificate) by ozlabs.org (Postfix) with ESMTPS id 1E5FC2C007A for ; Thu, 26 Sep 2013 03:35:42 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:content-type:from:to:subject:date:mime-version; q= dns; s=default; b=oexQcZlPtuxpZOogjoIhcsAwaK+i1PR23QdNMcyISac6Lh HJOaou8zmgyHZH4uMmoQDNKHvKQpZOcpShNgOvOJZh6SBJOQKS/YtgtkH78GwDLj CCjLhZH1ZlT4IHo5zgzRI6PBPoi2XUrjhDOHIgp63ZdUujaNn/DoUJN49ue1U= 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 :message-id:content-type:from:to:subject:date:mime-version; s= default; bh=IdQTd71pUUSMhZXW50+Mi7+89Hs=; b=NDo6Gdla70Bwrj5FnF4E QJRH+OcnGcPqVP8blEaUaou8gHe+ZXEK/ZrKrOVnlCkgi4X4/bAo2kFMj8xf8Fk9 Bnn6/hub6p55icSBSiChThyxA6xT5CnBpw+EaMMyXaY1TCeDZK0/busf2twth80g hcn0lYHT4aKxO/cMv0Iv38Y= Received: (qmail 20640 invoked by alias); 25 Sep 2013 17:35:37 -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 20627 invoked by uid 89); 25 Sep 2013 17:35:36 -0000 Received: from dub0-omc3-s18.dub0.hotmail.com (HELO dub0-omc3-s18.dub0.hotmail.com) (157.55.2.27) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 25 Sep 2013 17:35:36 +0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.6 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, FSL_HELO_NON_FQDN_1, RDNS_NONE, SPF_PASS autolearn=no version=3.3.2 X-HELO: dub0-omc3-s18.dub0.hotmail.com Received: from DUB122-W29 ([157.55.2.9]) by dub0-omc3-s18.dub0.hotmail.com with Microsoft SMTPSVC(6.0.3790.4675); Wed, 25 Sep 2013 10:35:32 -0700 X-TMN: [TNopDdBMFvKauGe79PvnveuU3UuFLiFr] Message-ID: From: Bernd Edlinger To: "gcc-patches@gcc.gnu.org" Subject: [PATCH] fortran/PR58113 Date: Wed, 25 Sep 2013 19:35:32 +0200 MIME-Version: 1.0 Hi, this test case fails very often, and the reason is not in GCC but in a missing glibc rounding support for strtod. This patch fixes the test case, to first determine if the rounding support is available. This is often the case for real(16) thru the libquadmath. So even in cases where the test case usually fails it still tests something with this patch. Ok for trunk? Regards Bernd Edlinger 2013-09-25 Bernd Edlinger PR fortran/58113 * gfortran.dg/round_4.f90: Check for rounding support. --- gcc/testsuite/gfortran.dg/round_4.f90 2013-07-21 13:54:27.000000000 +0200 +++ gcc/testsuite/gfortran.dg/round_4.f90 2013-08-23 10:16:32.000000000 +0200 @@ -27,6 +27,17 @@ real(xp) :: r10p, r10m, ref10u, ref10d real(qp) :: r16p, r16m, ref16u, ref16d character(len=20) :: str, round + logical :: rnd4, rnd8, rnd10, rnd16 + + ! Test for which types glibc's strtod function supports rounding + str = '0.01 0.01 0.01 0.01' + read (str, *, round='up') r4p, r8p, r10p, r16p + read (str, *, round='down') r4m, r8m, r10m, r16m + rnd4 = r4p /= r4m + rnd8 = r8p /= r8m + rnd10 = r10p /= r10m + rnd16 = r16p /= r16m +! write (*, *) rnd4, rnd8, rnd10, rnd16 ref4u = 0.100000001_4 ref8u = 0.10000000000000001_8 @@ -55,40 +66,40 @@ round = 'up' call t() - if (r4p /= ref4u .or. r4m /= -ref4d) call abort() - if (r8p /= ref8u .or. r8m /= -ref8d) call abort() - if (r10p /= ref10u .or. r10m /= -ref10d) call abort() - if (r16p /= ref16u .or. r16m /= -ref16d) call abort() + if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4d)) call abort() + if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8d)) call abort() + if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10d)) call abort() + if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16d)) call abort() round = 'down' call t() - if (r4p /= ref4d .or. r4m /= -ref4u) call abort() - if (r8p /= ref8d .or. r8m /= -ref8u) call abort() - if (r10p /= ref10d .or. r10m /= -ref10u) call abort() - if (r16p /= ref16d .or. r16m /= -ref16u) call abort() + if (rnd4 .and. (r4p /= ref4d .or. r4m /= -ref4u)) call abort() + if (rnd8 .and. (r8p /= ref8d .or. r8m /= -ref8u)) call abort() + if (rnd10 .and. (r10p /= ref10d .or. r10m /= -ref10u)) call abort() + if (rnd16 .and. (r16p /= ref16d .or. r16m /= -ref16u)) call abort() round = 'zero' call t() - if (r4p /= ref4d .or. r4m /= -ref4d) call abort() - if (r8p /= ref8d .or. r8m /= -ref8d) call abort() - if (r10p /= ref10d .or. r10m /= -ref10d) call abort() - if (r16p /= ref16d .or. r16m /= -ref16d) call abort() + if (rnd4 .and. (r4p /= ref4d .or. r4m /= -ref4d)) call abort() + if (rnd8 .and. (r8p /= ref8d .or. r8m /= -ref8d)) call abort() + if (rnd10 .and. (r10p /= ref10d .or. r10m /= -ref10d)) call abort() + if (rnd16 .and. (r16p /= ref16d .or. r16m /= -ref16d)) call abort() round = 'nearest' call t() - if (r4p /= ref4u .or. r4m /= -ref4u) call abort() - if (r8p /= ref8u .or. r8m /= -ref8u) call abort() - if (r10p /= ref10u .or. r10m /= -ref10u) call abort() - if (r16p /= ref16u .or. r16m /= -ref16u) call abort() + if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4u)) call abort() + if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8u)) call abort() + if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10u)) call abort() + if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16u)) call abort() ! Same as nearest (but rounding towards zero if there is a tie ! [does not apply here]) round = 'compatible' call t() - if (r4p /= ref4u .or. r4m /= -ref4u) call abort() - if (r8p /= ref8u .or. r8m /= -ref8u) call abort() - if (r10p /= ref10u .or. r10m /= -ref10u) call abort() - if (r16p /= ref16u .or. r16m /= -ref16u) call abort() + if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4u)) call abort() + if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8u)) call abort() + if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10u)) call abort() + if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16u)) call abort() contains subroutine t() ! print *, round