From patchwork Tue Jul 21 22:03:52 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: dhumieres.dominique@free.fr X-Patchwork-Id: 1333369 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=free.fr Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4BBCL023ctz9sPB for ; Wed, 22 Jul 2020 08:04:06 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id AE02A386F82F; Tue, 21 Jul 2020 22:04:00 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp2-g21.free.fr (smtp2-g21.free.fr [212.27.42.2]) by sourceware.org (Postfix) with ESMTPS id 0802E3857C6E; Tue, 21 Jul 2020 22:03:54 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 0802E3857C6E Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=free.fr Authentication-Results: sourceware.org; spf=none smtp.mailfrom=dhumieres.dominique@free.fr Received: from webmail.free.fr (unknown [172.20.243.59]) by smtp2-g21.free.fr (Postfix) with ESMTP id CE2222003C8; Wed, 22 Jul 2020 00:03:52 +0200 (CEST) Received: from 2a01:e0a:8a:4180:c468:861:6947:eb90 by webmail.free.fr MIME-Version: 1.0 Date: Wed, 22 Jul 2020 00:03:52 +0200 From: dhumieres.dominique@free.fr To: fortran@gcc.gnu.org Subject: [Patch, fortran] PR 93592 - Invalid UP/DOWN rounding with EN descriptor Message-ID: <50effb7d55d3ca2fc258a5cc5197c11d@free.fr> X-Sender: dhumieres.dominique@free.fr User-Agent: Webmail Free/1.3.3 X-Spam-Status: No, score=2.7 required=5.0 tests=BAYES_00, FREEMAIL_FROM, KAM_DMARC_STATUS, KAM_LAZY_DOMAIN_SECURITY, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, SPF_NONE, SPOOFED_FREEMAIL, TXREP, UNPARSEABLE_RELAY autolearn=no autolearn_force=no version=3.4.2 X-Spam-Level: ** X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: jvdelisle@charter.net, gcc-patches@gcc.gnu.org Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" The fix is obvious (I have added a comment). The tests are probably an overkill, but it does not hurt. I am not set up to commit on git, someone will have to do it for me. TIA Dominique --- ../_clean/libgfortran/io/write_float.def 2020-06-13 03:11:55.000000000 +0200 +++ libgfortran/io/write_float.def 2020-07-21 23:03:08.000000000 +0200 @@ -399,7 +399,8 @@ build_float_string (st_parameter_dt *dtp updown: rchar = '0'; - if (ft != FMT_F && w > 0 && d == 0 && p == 0) + /* Do not reset nbefore for FMT_F and FMT_EN. */ + if (ft != FMT_F && ft !=FMT_EN && w > 0 && d == 0 && p == 0) nbefore = 1; /* Scan for trailing zeros to see if we really need to round it. */ for(i = nbefore + nafter; i < ndigits; i++) --- ../_clean/gcc/testsuite/gfortran.dg/fmt_en.f90 2020-06-13 03:11:53.000000000 +0200 +++ gcc/testsuite/gfortran.dg/fmt_en.f90 2020-06-15 16:55:35.000000000 +0200 @@ -10,7 +10,6 @@ use ISO_FORTRAN_ENV integer :: n_tst = 0, n_cnt = 0, n_skip = 0 character(len=20) :: s, s1 - open (unit = 10, file = 'fmt_en.res') ! Check that the default rounding mode is to nearest and to even on tie. do i=1,size(real_kinds) if (i == 1) then @@ -149,8 +148,7 @@ use ISO_FORTRAN_ENV ! print *, n_tst, n_cnt, n_skip if (n_cnt /= 0) STOP 1 - if (all(.not. l_skip)) write (10, *) "All kinds rounded to nearest" - close (10) + if (all(.not. l_skip)) print *, "All kinds rounded to nearest" contains subroutine checkfmt(fmt, x, cmp) @@ -182,4 +180,4 @@ contains end subroutine end program -! { dg-final { scan-file fmt_en.res "All kinds rounded to nearest" { xfail hppa*-*-hpux* } } } +! { dg-output "All kinds rounded to nearest" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } --- ../_clean/gcc/testsuite/gfortran.dg/fmt_en_rd.f90 1970-01-01 01:00:00.000000000 +0100 +++ gcc/testsuite/gfortran.dg/fmt_en_rd.f90 2020-07-19 23:51:17.000000000 +0200 @@ -0,0 +1,185 @@ +! { dg-do run } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20,kind=4) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= 4_'-9.5 9.5 10. 8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then + l_skip(i) = .true. + print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, 4_" -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(rd,en15.0)", 1.0, 4_" 1.E+00") + call checkfmt("(rd,en15.0)", 1.00000012, 4_" 1.E+00") + call checkfmt("(rd,en15.0)", 0.99999994, 4_" 999.E-03") + call checkfmt("(rd,en15.0)", 10.0, 4_" 10.E+00") + call checkfmt("(rd,en15.0)", 10.0000010, 4_" 10.E+00") + call checkfmt("(rd,en15.0)", 9.99999905, 4_" 9.E+00") + call checkfmt("(ru,en15.0)", 100.0, 4_" 100.E+00") + call checkfmt("(rd,en15.0)", 100.000008, 4_" 100.E+00") + call checkfmt("(rd,en15.0)", 99.9999924, 4_" 99.E+00") + call checkfmt("(rd,en15.0)", 1000.0, 4_" 1.E+03") + call checkfmt("(rd,en15.0)", 1000.00006, 4_" 1.E+03") + call checkfmt("(rd,en15.0)", 999.999939, 4_" 999.E+00") + call checkfmt("(rd,en15.0)", 9.5, 4_" 9.E+00") + call checkfmt("(rd,en15.0)", 9.50000095, 4_" 9.E+00") + call checkfmt("(rd,en15.0)", 9.49999905, 4_" 9.E+00") + call checkfmt("(rd,en15.0)", 99.5, 4_" 99.E+00") + call checkfmt("(rd,en15.0)", 99.5000076, 4_" 99.E+00") + call checkfmt("(rd,en15.0)", 99.4999924, 4_" 99.E+00") + call checkfmt("(rd,en15.0)", 999.5, 4_" 999.E+00") + call checkfmt("(rd,en15.0)", 999.500061, 4_" 999.E+00") + call checkfmt("(rd,en15.0)", 999.499939, 4_" 999.E+00") + call checkfmt("(rd,en15.0)", 9500.0, 4_" 9.E+03") + call checkfmt("(rd,en15.0)", 9500.00098, 4_" 9.E+03") + call checkfmt("(rd,en15.0)", 9499.99902, 4_" 9.E+03") + call checkfmt("(rd,en15.1)", 9950.0, 4_" 9.9E+03") + call checkfmt("(rd,en15.2)", 9995.0, 4_" 9.99E+03") + call checkfmt("(rd,en15.3)", 9999.5, 4_" 9.999E+03") + call checkfmt("(rd,en15.1)", 9.5, 4_" 9.5E+00") + call checkfmt("(rd,en15.1)", 9.50000095, 4_" 9.5E+00") + call checkfmt("(rd,en15.1)", 9.49999905, 4_" 9.4E+00") + call checkfmt("(rd,en15.1)", 0.099951, 4_" 99.9E-03") + call checkfmt("(rd,en15.1)", 0.009951, 4_" 9.9E-03") + call checkfmt("(rd,en15.1)", 0.000999951,4_" 999.9E-06") + + call checkfmt("(rd,en15.0)", -1.0, 4_" -1.E+00") + call checkfmt("(rd,en15.0)", -1.00000012, 4_" -2.E+00") + call checkfmt("(rd,en15.0)", -0.99999994, 4_" -1.E+00") + call checkfmt("(rd,en15.0)", -10.0, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -10.0000010, 4_" -11.E+00") + call checkfmt("(rd,en15.0)", -9.99999905, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -100.0, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -100.000008, 4_" -101.E+00") + call checkfmt("(rd,en15.0)", -99.9999924, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -1000.0, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -1000.00006, 4_" -2.E+03") + call checkfmt("(rd,en15.0)", -999.999939, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -9.5, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -9.50000095, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -9.49999905, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -99.5, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -99.5000076, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -99.4999924, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -999.5, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -999.500061, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -999.499939, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -9500.0, 4_" -10.E+03") + call checkfmt("(rd,en15.0)", -9500.00098, 4_" -10.E+03") + call checkfmt("(rd,en15.0)", -9499.99902, 4_" -10.E+03") + call checkfmt("(rd,en15.1)", -9950.0, 4_" -10.0E+03") + call checkfmt("(rd,en15.2)", -9995.0, 4_" -10.00E+03") + call checkfmt("(rd,en15.3)", -9999.5, 4_" -10.000E+03") + call checkfmt("(rd,en15.1)", -9.5, 4_" -9.5E+00") + call checkfmt("(rd,en15.1)", -9.50000095, 4_" -9.6E+00") + call checkfmt("(rd,en15.1)", -9.49999905, 4_" -9.5E+00") + call checkfmt("(rd,en15.1)", -0.099951, 4_" -100.0E-03") + call checkfmt("(rd,en15.1)", -0.009951, 4_" -10.0E-03") + call checkfmt("(rd,en15.1)", -0.000999951,4_" -1.0E-03") + + call checkfmt("(rd,en15.1)", 987350., 4_" 987.3E+03") + call checkfmt("(rd,en15.2)", 98735., 4_" 98.73E+03") + call checkfmt("(rd,en15.3)", 9873.5, 4_" 9.873E+03") + call checkfmt("(rd,en15.1)", 987650., 4_" 987.6E+03") + call checkfmt("(rd,en15.2)", 98765., 4_" 98.76E+03") + call checkfmt("(rd,en15.3)", 9876.5, 4_" 9.876E+03") + call checkfmt("(rd,en15.1)", 3.125E-02, 4_" 31.2E-03") + call checkfmt("(rd,en15.1)", 9.375E-02, 4_" 93.7E-03") + call checkfmt("(rd,en15.2)", 1.5625E-02, 4_" 15.62E-03") + call checkfmt("(rd,en15.2)", 4.6875E-02, 4_" 46.87E-03") + call checkfmt("(rd,en15.3)", 7.8125E-03, 4_" 7.812E-03") + call checkfmt("(rd,en15.3)", 2.34375E-02, 4_" 23.437E-03") + call checkfmt("(rd,en15.3)", 9.765625E-04,4_" 976.562E-06") + call checkfmt("(rd,en15.6)", 2.9296875E-03,4_" 2.929687E-03") + + call checkfmt("(rd,en15.1)", -987350., 4_" -987.4E+03") + call checkfmt("(rd,en15.2)", -98735., 4_" -98.74E+03") + call checkfmt("(rd,en15.3)", -9873.5, 4_" -9.874E+03") + call checkfmt("(rd,en15.1)", -987650., 4_" -987.7E+03") + call checkfmt("(rd,en15.2)", -98765., 4_" -98.77E+03") + call checkfmt("(rd,en15.3)", -9876.5, 4_" -9.877E+03") + call checkfmt("(rd,en15.1)", -3.125E-02, 4_" -31.3E-03") + call checkfmt("(rd,en15.1)", -9.375E-02, 4_" -93.8E-03") + call checkfmt("(rd,en15.2)", -1.5625E-02, 4_" -15.63E-03") + call checkfmt("(rd,en15.2)", -4.6875E-02, 4_" -46.88E-03") + call checkfmt("(rd,en15.3)", -7.8125E-03, 4_" -7.813E-03") + call checkfmt("(rd,en15.3)", -2.34375E-02, 4_" -23.438E-03") + call checkfmt("(rd,en15.3)", -9.765625E-04,4_" -976.563E-06") + call checkfmt("(rd,en15.6)", -2.9296875E-03,4_" -2.929688E-03") + + print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) stop n_cnt + if (all(.not. l_skip)) print *, "All kinds rounded down" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*, kind=4), intent(in) :: cmp + do i=1,size(real_kinds) + if (l_skip(i)) cycle + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded down" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-final { cleanup-saved-temps } } --- ../_clean/gcc/testsuite/gfortran.dg/fmt_en_rn.f90 1970-01-01 01:00:00.000000000 +0100 +++ gcc/testsuite/gfortran.dg/fmt_en_rn.f90 2020-07-20 14:38:43.000000000 +0200 @@ -0,0 +1,185 @@ +! { dg-do run } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20,kind=4) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= 4_'-9.5 9.5 10. 8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then + l_skip(i) = .true. + print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, 4_" -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(rn,en15.0)", 1.0, 4_" 1.E+00") + call checkfmt("(rn,en15.0)", 1.00000012, 4_" 1.E+00") + call checkfmt("(rn,en15.0)", 0.99999994, 4_" 1.E+00") + call checkfmt("(rn,en15.0)", 10.0, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 10.0000010, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 9.99999905, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 100.0, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 100.000008, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 99.9999924, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 1000.0, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 1000.00006, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 999.999939, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 9.5, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 9.50000095, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 9.49999905, 4_" 9.E+00") + call checkfmt("(rn,en15.0)", 99.5, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 99.5000076, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 99.4999924, 4_" 99.E+00") + call checkfmt("(rn,en15.0)", 999.5, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 999.500061, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 999.499939, 4_" 999.E+00") + call checkfmt("(rn,en15.0)", 9500.0, 4_" 10.E+03") + call checkfmt("(rn,en15.0)", 9500.00098, 4_" 10.E+03") + call checkfmt("(rn,en15.0)", 9499.99902, 4_" 9.E+03") + call checkfmt("(rn,en15.1)", 9950.0, 4_" 10.0E+03") + call checkfmt("(rn,en15.2)", 9995.0, 4_" 10.00E+03") + call checkfmt("(rn,en15.3)", 9999.5, 4_" 10.000E+03") + call checkfmt("(rn,en15.1)", 9.5, 4_" 9.5E+00") + call checkfmt("(rn,en15.1)", 9.50000095, 4_" 9.5E+00") + call checkfmt("(rn,en15.1)", 9.49999905, 4_" 9.5E+00") + call checkfmt("(rn,en15.1)", 0.099951, 4_" 100.0E-03") + call checkfmt("(rn,en15.1)", 0.009951, 4_" 10.0E-03") + call checkfmt("(rn,en15.1)", 0.000999951,4_" 1.0E-03") + + call checkfmt("(rn,en15.0)", -1.0, 4_" -1.E+00") + call checkfmt("(rn,en15.0)", -1.00000012, 4_" -1.E+00") + call checkfmt("(rn,en15.0)", -0.99999994, 4_" -1.E+00") + call checkfmt("(rn,en15.0)", -10.0, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -10.0000010, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -9.99999905, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -100.0, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -100.000008, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -99.9999924, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -1000.0, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -1000.00006, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -999.999939, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -9.5, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -9.50000095, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -9.49999905, 4_" -9.E+00") + call checkfmt("(rn,en15.0)", -99.5, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -99.5000076, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -99.4999924, 4_" -99.E+00") + call checkfmt("(rn,en15.0)", -999.5, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -999.500061, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -999.499939, 4_" -999.E+00") + call checkfmt("(rn,en15.0)", -9500.0, 4_" -10.E+03") + call checkfmt("(rn,en15.0)", -9500.00098, 4_" -10.E+03") + call checkfmt("(rn,en15.0)", -9499.99902, 4_" -9.E+03") + call checkfmt("(rn,en15.1)", -9950.0, 4_" -10.0E+03") + call checkfmt("(rn,en15.2)", -9995.0, 4_" -10.00E+03") + call checkfmt("(rn,en15.3)", -9999.5, 4_" -10.000E+03") + call checkfmt("(rn,en15.1)", -9.5, 4_" -9.5E+00") + call checkfmt("(rn,en15.1)", -9.50000095, 4_" -9.5E+00") + call checkfmt("(rn,en15.1)", -9.49999905, 4_" -9.5E+00") + call checkfmt("(rn,en15.1)", -0.099951, 4_" -100.0E-03") + call checkfmt("(rn,en15.1)", -0.009951, 4_" -10.0E-03") + call checkfmt("(rn,en15.1)", -0.000999951,4_" -1.0E-03") + + call checkfmt("(rn,en15.1)", 987350., 4_" 987.4E+03") + call checkfmt("(rn,en15.2)", 98735., 4_" 98.74E+03") + call checkfmt("(rn,en15.3)", 9873.5, 4_" 9.874E+03") + call checkfmt("(rn,en15.1)", 987650., 4_" 987.6E+03") + call checkfmt("(rn,en15.2)", 98765., 4_" 98.76E+03") + call checkfmt("(rn,en15.3)", 9876.5, 4_" 9.876E+03") + call checkfmt("(rn,en15.1)", 3.125E-02, 4_" 31.2E-03") + call checkfmt("(rn,en15.1)", 9.375E-02, 4_" 93.8E-03") + call checkfmt("(rn,en15.2)", 1.5625E-02, 4_" 15.62E-03") + call checkfmt("(rn,en15.2)", 4.6875E-02, 4_" 46.88E-03") + call checkfmt("(rn,en15.3)", 7.8125E-03, 4_" 7.812E-03") + call checkfmt("(rn,en15.3)", 2.34375E-02, 4_" 23.438E-03") + call checkfmt("(rn,en15.3)", 9.765625E-04,4_" 976.562E-06") + call checkfmt("(rn,en15.6)", 2.9296875E-03,4_" 2.929688E-03") + + call checkfmt("(rn,en15.1)", -987350., 4_" -987.4E+03") + call checkfmt("(rn,en15.2)", -98735., 4_" -98.74E+03") + call checkfmt("(rn,en15.3)", -9873.5, 4_" -9.874E+03") + call checkfmt("(rn,en15.1)", -987650., 4_" -987.6E+03") + call checkfmt("(rn,en15.2)", -98765., 4_" -98.76E+03") + call checkfmt("(rn,en15.3)", -9876.5, 4_" -9.876E+03") + call checkfmt("(rn,en15.1)", -3.125E-02, 4_" -31.2E-03") + call checkfmt("(rn,en15.1)", -9.375E-02, 4_" -93.8E-03") + call checkfmt("(rn,en15.2)", -1.5625E-02, 4_" -15.62E-03") + call checkfmt("(rn,en15.2)", -4.6875E-02, 4_" -46.88E-03") + call checkfmt("(rn,en15.3)", -7.8125E-03, 4_" -7.812E-03") + call checkfmt("(rn,en15.3)", -2.34375E-02, 4_" -23.438E-03") + call checkfmt("(rn,en15.3)", -9.765625E-04,4_" -976.562E-06") + call checkfmt("(rn,en15.6)", -2.9296875E-03,4_" -2.929688E-03") + + print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) stop n_cnt + if (all(.not. l_skip)) print *, "All kinds rounded to nearest" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*, kind=4), intent(in) :: cmp + do i=1,size(real_kinds) + if (l_skip(i)) cycle + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded to nearest" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-final { cleanup-saved-temps } } --- ../_clean/gcc/testsuite/gfortran.dg/fmt_en_ru.f90 1970-01-01 01:00:00.000000000 +0100 +++ gcc/testsuite/gfortran.dg/fmt_en_ru.f90 2020-07-19 23:15:40.000000000 +0200 @@ -0,0 +1,185 @@ +! { dg-do run } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20,kind=4) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= 4_'-9.5 9.5 10. 8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then + l_skip(i) = .true. + print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, 4_" -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(ru,en15.0)", 1.0, 4_" 1.E+00") + call checkfmt("(ru,en15.0)", 1.00000012, 4_" 2.E+00") + call checkfmt("(ru,en15.0)", 0.99999994, 4_" 1.E+00") + call checkfmt("(ru,en15.0)", 10.0, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 10.0000010, 4_" 11.E+00") + call checkfmt("(ru,en15.0)", 9.99999905, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 100.0, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 100.000008, 4_" 101.E+00") + call checkfmt("(ru,en15.0)", 99.9999924, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 1000.0, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 1000.00006, 4_" 2.E+03") + call checkfmt("(ru,en15.0)", 999.999939, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 9.5, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 9.50000095, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 9.49999905, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 99.5, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 99.5000076, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 99.4999924, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 999.5, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 999.500061, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 999.499939, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 9500.0, 4_" 10.E+03") + call checkfmt("(ru,en15.0)", 9500.00098, 4_" 10.E+03") + call checkfmt("(ru,en15.0)", 9499.99902, 4_" 10.E+03") + call checkfmt("(ru,en15.1)", 9950.0, 4_" 10.0E+03") + call checkfmt("(ru,en15.2)", 9995.0, 4_" 10.00E+03") + call checkfmt("(ru,en15.3)", 9999.5, 4_" 10.000E+03") + call checkfmt("(ru,en15.1)", 9.5, 4_" 9.5E+00") + call checkfmt("(ru,en15.1)", 9.50000095, 4_" 9.6E+00") + call checkfmt("(ru,en15.1)", 9.49999905, 4_" 9.5E+00") + call checkfmt("(ru,en15.1)", 0.099951, 4_" 100.0E-03") + call checkfmt("(ru,en15.1)", 0.009951, 4_" 10.0E-03") + call checkfmt("(ru,en15.1)", 0.000999951,4_" 1.0E-03") + + call checkfmt("(ru,en15.0)", -1.0, 4_" -1.E+00") + call checkfmt("(ru,en15.0)", -1.00000012, 4_" -1.E+00") + call checkfmt("(ru,en15.0)", -0.99999994, 4_" -999.E-03") + call checkfmt("(ru,en15.0)", -10.0, 4_" -10.E+00") + call checkfmt("(ru,en15.0)", -10.0000010, 4_" -10.E+00") + call checkfmt("(ru,en15.0)", -9.99999905, 4_" -9.E+00") + call checkfmt("(ru,en15.0)", -100.0, 4_" -100.E+00") + call checkfmt("(ru,en15.0)", -100.000008, 4_" -100.E+00") + call checkfmt("(ru,en15.0)", -99.9999924, 4_" -99.E+00") + call checkfmt("(ru,en15.0)", -1000.0, 4_" -1.E+03") + call checkfmt("(ru,en15.0)", -1000.00006, 4_" -1.E+03") + call checkfmt("(ru,en15.0)", -999.999939, 4_" -999.E+00") + call checkfmt("(ru,en15.0)", -9.5, 4_" -9.E+00") + call checkfmt("(ru,en15.0)", -9.50000095, 4_" -9.E+00") + call checkfmt("(ru,en15.0)", -9.49999905, 4_" -9.E+00") + call checkfmt("(ru,en15.0)", -99.5, 4_" -99.E+00") + call checkfmt("(ru,en15.0)", -99.5000076, 4_" -99.E+00") + call checkfmt("(ru,en15.0)", -99.4999924, 4_" -99.E+00") + call checkfmt("(ru,en15.0)", -999.5, 4_" -999.E+00") + call checkfmt("(ru,en15.0)", -999.500061, 4_" -999.E+00") + call checkfmt("(ru,en15.0)", -999.499939, 4_" -999.E+00") + call checkfmt("(ru,en15.0)", -9500.0, 4_" -9.E+03") + call checkfmt("(ru,en15.0)", -9500.00098, 4_" -9.E+03") + call checkfmt("(ru,en15.0)", -9499.99902, 4_" -9.E+03") + call checkfmt("(ru,en15.1)", -9950.0, 4_" -9.9E+03") + call checkfmt("(ru,en15.2)", -9995.0, 4_" -9.99E+03") + call checkfmt("(ru,en15.3)", -9999.5, 4_" -9.999E+03") + call checkfmt("(ru,en15.1)", -9.5, 4_" -9.5E+00") + call checkfmt("(ru,en15.1)", -9.50000095, 4_" -9.5E+00") + call checkfmt("(ru,en15.1)", -9.49999905, 4_" -9.4E+00") + call checkfmt("(ru,en15.1)", -0.099951, 4_" -99.9E-03") + call checkfmt("(ru,en15.1)", -0.009951, 4_" -9.9E-03") + call checkfmt("(ru,en15.1)", -0.000999951,4_" -999.9E-06") + + call checkfmt("(ru,en15.1)", 987350., 4_" 987.4E+03") + call checkfmt("(ru,en15.2)", 98735., 4_" 98.74E+03") + call checkfmt("(ru,en15.3)", 9873.5, 4_" 9.874E+03") + call checkfmt("(ru,en15.1)", 987650., 4_" 987.7E+03") + call checkfmt("(ru,en15.2)", 98765., 4_" 98.77E+03") + call checkfmt("(ru,en15.3)", 9876.5, 4_" 9.877E+03") + call checkfmt("(ru,en15.1)", 3.125E-02, 4_" 31.3E-03") + call checkfmt("(ru,en15.1)", 9.375E-02, 4_" 93.8E-03") + call checkfmt("(ru,en15.2)", 1.5625E-02, 4_" 15.63E-03") + call checkfmt("(ru,en15.2)", 4.6875E-02, 4_" 46.88E-03") + call checkfmt("(ru,en15.3)", 7.8125E-03, 4_" 7.813E-03") + call checkfmt("(ru,en15.3)", 2.34375E-02, 4_" 23.438E-03") + call checkfmt("(ru,en15.3)", 9.765625E-04,4_" 976.563E-06") + call checkfmt("(ru,en15.6)", 2.9296875E-03,4_" 2.929688E-03") + + call checkfmt("(ru,en15.1)", -987350., 4_" -987.3E+03") + call checkfmt("(ru,en15.2)", -98735., 4_" -98.73E+03") + call checkfmt("(ru,en15.3)", -9873.5, 4_" -9.873E+03") + call checkfmt("(ru,en15.1)", -987650., 4_" -987.6E+03") + call checkfmt("(ru,en15.2)", -98765., 4_" -98.76E+03") + call checkfmt("(ru,en15.3)", -9876.5, 4_" -9.876E+03") + call checkfmt("(ru,en15.1)", -3.125E-02, 4_" -31.2E-03") + call checkfmt("(ru,en15.1)", -9.375E-02, 4_" -93.7E-03") + call checkfmt("(ru,en15.2)", -1.5625E-02, 4_" -15.62E-03") + call checkfmt("(ru,en15.2)", -4.6875E-02, 4_" -46.87E-03") + call checkfmt("(ru,en15.3)", -7.8125E-03, 4_" -7.812E-03") + call checkfmt("(ru,en15.3)", -2.34375E-02, 4_" -23.437E-03") + call checkfmt("(ru,en15.3)", -9.765625E-04,4_" -976.562E-06") + call checkfmt("(ru,en15.6)", -2.9296875E-03,4_" -2.929687E-03") + + print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) stop n_cnt + if (all(.not. l_skip)) print *, "All kinds rounded up" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*, kind=4), intent(in) :: cmp + do i=1,size(real_kinds) + if (l_skip(i)) cycle + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded up" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-final { cleanup-saved-temps } } --- ../_clean/gcc/testsuite/gfortran.dg/fmt_en_rz.f90 1970-01-01 01:00:00.000000000 +0100 +++ gcc/testsuite/gfortran.dg/fmt_en_rz.f90 2020-07-20 14:49:16.000000000 +0200 @@ -0,0 +1,185 @@ +! { dg-do run } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20,kind=4) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= 4_'-9.5 9.5 10. 8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then + l_skip(i) = .true. + print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, 4_" -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(rz,en15.0)", 1.0, 4_" 1.E+00") + call checkfmt("(rz,en15.0)", 1.00000012, 4_" 1.E+00") + call checkfmt("(rz,en15.0)", 0.99999994, 4_" 999.E-03") + call checkfmt("(rz,en15.0)", 10.0, 4_" 10.E+00") + call checkfmt("(rz,en15.0)", 10.0000010, 4_" 10.E+00") + call checkfmt("(rz,en15.0)", 9.99999905, 4_" 9.E+00") + call checkfmt("(rz,en15.0)", 100.0, 4_" 100.E+00") + call checkfmt("(rz,en15.0)", 100.000008, 4_" 100.E+00") + call checkfmt("(rz,en15.0)", 99.9999924, 4_" 99.E+00") + call checkfmt("(rz,en15.0)", 1000.0, 4_" 1.E+03") + call checkfmt("(rz,en15.0)", 1000.00006, 4_" 1.E+03") + call checkfmt("(rz,en15.0)", 999.999939, 4_" 999.E+00") + call checkfmt("(rz,en15.0)", 9.5, 4_" 9.E+00") + call checkfmt("(rz,en15.0)", 9.50000095, 4_" 9.E+00") + call checkfmt("(rz,en15.0)", 9.49999905, 4_" 9.E+00") + call checkfmt("(rz,en15.0)", 99.5, 4_" 99.E+00") + call checkfmt("(rz,en15.0)", 99.5000076, 4_" 99.E+00") + call checkfmt("(rz,en15.0)", 99.4999924, 4_" 99.E+00") + call checkfmt("(rz,en15.0)", 999.5, 4_" 999.E+00") + call checkfmt("(rz,en15.0)", 999.500061, 4_" 999.E+00") + call checkfmt("(rz,en15.0)", 999.499939, 4_" 999.E+00") + call checkfmt("(rz,en15.0)", 9500.0, 4_" 9.E+03") + call checkfmt("(rz,en15.0)", 9500.00098, 4_" 9.E+03") + call checkfmt("(rz,en15.0)", 9499.99902, 4_" 9.E+03") + call checkfmt("(rz,en15.1)", 9950.0, 4_" 9.9E+03") + call checkfmt("(rz,en15.2)", 9995.0, 4_" 9.99E+03") + call checkfmt("(rz,en15.3)", 9999.5, 4_" 9.999E+03") + call checkfmt("(rz,en15.1)", 9.5, 4_" 9.5E+00") + call checkfmt("(rz,en15.1)", 9.50000095, 4_" 9.5E+00") + call checkfmt("(rz,en15.1)", 9.49999905, 4_" 9.4E+00") + call checkfmt("(rz,en15.1)", 0.099951, 4_" 99.9E-03") + call checkfmt("(rz,en15.1)", 0.009951, 4_" 9.9E-03") + call checkfmt("(rz,en15.1)", 0.000999951,4_" 999.9E-06") + + call checkfmt("(rz,en15.0)", -1.0, 4_" -1.E+00") + call checkfmt("(rz,en15.0)", -1.00000012, 4_" -1.E+00") + call checkfmt("(rz,en15.0)", -0.99999994, 4_" -999.E-03") + call checkfmt("(rz,en15.0)", -10.0, 4_" -10.E+00") + call checkfmt("(rz,en15.0)", -10.0000010, 4_" -10.E+00") + call checkfmt("(rz,en15.0)", -9.99999905, 4_" -9.E+00") + call checkfmt("(rz,en15.0)", -100.0, 4_" -100.E+00") + call checkfmt("(rz,en15.0)", -100.000008, 4_" -100.E+00") + call checkfmt("(rz,en15.0)", -99.9999924, 4_" -99.E+00") + call checkfmt("(rz,en15.0)", -1000.0, 4_" -1.E+03") + call checkfmt("(rz,en15.0)", -1000.00006, 4_" -1.E+03") + call checkfmt("(rz,en15.0)", -999.999939, 4_" -999.E+00") + call checkfmt("(rz,en15.0)", -9.5, 4_" -9.E+00") + call checkfmt("(rz,en15.0)", -9.50000095, 4_" -9.E+00") + call checkfmt("(rz,en15.0)", -9.49999905, 4_" -9.E+00") + call checkfmt("(rz,en15.0)", -99.5, 4_" -99.E+00") + call checkfmt("(rz,en15.0)", -99.5000076, 4_" -99.E+00") + call checkfmt("(rz,en15.0)", -99.4999924, 4_" -99.E+00") + call checkfmt("(rz,en15.0)", -999.5, 4_" -999.E+00") + call checkfmt("(rz,en15.0)", -999.500061, 4_" -999.E+00") + call checkfmt("(rz,en15.0)", -999.499939, 4_" -999.E+00") + call checkfmt("(rz,en15.0)", -9500.0, 4_" -9.E+03") + call checkfmt("(rz,en15.0)", -9500.00098, 4_" -9.E+03") + call checkfmt("(rz,en15.0)", -9499.99902, 4_" -9.E+03") + call checkfmt("(rz,en15.1)", -9950.0, 4_" -9.9E+03") + call checkfmt("(rz,en15.2)", -9995.0, 4_" -9.99E+03") + call checkfmt("(rz,en15.3)", -9999.5, 4_" -9.999E+03") + call checkfmt("(rz,en15.1)", -9.5, 4_" -9.5E+00") + call checkfmt("(rz,en15.1)", -9.50000095, 4_" -9.5E+00") + call checkfmt("(rz,en15.1)", -9.49999905, 4_" -9.4E+00") + call checkfmt("(rz,en15.1)", -0.099951, 4_" -99.9E-03") + call checkfmt("(rz,en15.1)", -0.009951, 4_" -9.9E-03") + call checkfmt("(rz,en15.1)", -0.000999951,4_" -999.9E-06") + + call checkfmt("(rz,en15.1)", 987350., 4_" 987.3E+03") + call checkfmt("(rz,en15.2)", 98735., 4_" 98.73E+03") + call checkfmt("(rz,en15.3)", 9873.5, 4_" 9.873E+03") + call checkfmt("(rz,en15.1)", 987650., 4_" 987.6E+03") + call checkfmt("(rz,en15.2)", 98765., 4_" 98.76E+03") + call checkfmt("(rz,en15.3)", 9876.5, 4_" 9.876E+03") + call checkfmt("(rz,en15.1)", 3.125E-02, 4_" 31.2E-03") + call checkfmt("(rz,en15.1)", 9.375E-02, 4_" 93.7E-03") + call checkfmt("(rz,en15.2)", 1.5625E-02, 4_" 15.62E-03") + call checkfmt("(rz,en15.2)", 4.6875E-02, 4_" 46.87E-03") + call checkfmt("(rz,en15.3)", 7.8125E-03, 4_" 7.812E-03") + call checkfmt("(rz,en15.3)", 2.34375E-02, 4_" 23.437E-03") + call checkfmt("(rz,en15.3)", 9.765625E-04,4_" 976.562E-06") + call checkfmt("(rz,en15.6)", 2.9296875E-03,4_" 2.929687E-03") + + call checkfmt("(rz,en15.1)", -987350., 4_" -987.3E+03") + call checkfmt("(rz,en15.2)", -98735., 4_" -98.73E+03") + call checkfmt("(rz,en15.3)", -9873.5, 4_" -9.873E+03") + call checkfmt("(rz,en15.1)", -987650., 4_" -987.6E+03") + call checkfmt("(rz,en15.2)", -98765., 4_" -98.76E+03") + call checkfmt("(rz,en15.3)", -9876.5, 4_" -9.876E+03") + call checkfmt("(rz,en15.1)", -3.125E-02, 4_" -31.2E-03") + call checkfmt("(rz,en15.1)", -9.375E-02, 4_" -93.7E-03") + call checkfmt("(rz,en15.2)", -1.5625E-02, 4_" -15.62E-03") + call checkfmt("(rz,en15.2)", -4.6875E-02, 4_" -46.87E-03") + call checkfmt("(rz,en15.3)", -7.8125E-03, 4_" -7.812E-03") + call checkfmt("(rz,en15.3)", -2.34375E-02, 4_" -23.437E-03") + call checkfmt("(rz,en15.3)", -9.765625E-04,4_" -976.562E-06") + call checkfmt("(rz,en15.6)", -2.9296875E-03,4_" -2.929687E-03") + + print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) stop n_cnt + if (all(.not. l_skip)) print *, "All kinds rounded to zero" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*, kind=4), intent(in) :: cmp + do i=1,size(real_kinds) + if (l_skip(i)) cycle + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded to zero" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-final { cleanup-saved-temps } }