From patchwork Fri Nov 1 22:48:04 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry DeLisle X-Patchwork-Id: 1188234 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=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-512250-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=charter.net Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="mNch5S5b"; dkim-atps=neutral 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 474cml1q7Yz9sP4 for ; Sat, 2 Nov 2019 09:48:37 +1100 (AEDT) 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=tFb0uZexXNbnMAYzQqMkV9o/Yc59WdxkufIzvixNZUVTgf/aEA eQbEcIyE0wRcntqz7nQGvsqKfU3DvDLiagATrZn2yPc4V9d9wVgeUgjdXtvXjHCP ddNkQz6R+pXTjYa7DAzQtPqvK4S22EKMpQl7Q9VA0TvYNGK497L4zID9Q= 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=cQdBPHjPvGXbcuFEAqdqHPpO3UM=; b=mNch5S5b8I0wCqZeNd/J NAqZx08SUEm3VfaIHEhX1TPeZ++cdUDk5offrG968HxKJ7OAt1vUJa0O8bq2gDLn Aox7jTzZt+P5ddgjTUrl/S839MYfY0GKJzVoyqra7lcXuvQRP/0R6/pwGQftCum2 kN5j32srzb+9fvhQW3rfSWY= Received: (qmail 106269 invoked by alias); 1 Nov 2019 22:48:24 -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 106219 invoked by uid 89); 1 Nov 2019 22:48:18 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-17.1 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.1 spammy=kin, fmt, Jerry, jerry X-HELO: impout008.msg.chrl.nc.charter.net Received: from impout008aa.msg.chrl.nc.charter.net (HELO impout008.msg.chrl.nc.charter.net) (47.43.20.32) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 01 Nov 2019 22:48:15 +0000 Received: from [192.168.1.6] ([66.191.41.128]) by cmsmtp with ESMTPA id Qfi9iLZK8cx2eQfi9iQ4tm; Fri, 01 Nov 2019 22:48:06 +0000 Authentication-Results: charter.net; none To: "fortran@gcc.gnu.org" Cc: GCC Patches From: Jerry DeLisle Subject: [Patch, Fortran] PR90374 Support d0.d, e0.d, es0.d, en0.d, g0.d Message-ID: <4da10faf-23d7-18be-0fb1-be55b3acac56@charter.net> Date: Fri, 1 Nov 2019 15:48:04 -0700 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.1.1 MIME-Version: 1.0 Hi all, The attached patch provides frontend and runtime modifications to allow the subject format specifiers. These are allowed as default behavior and under -std=f2018. It does not implement the ew.de0 specifier. I decided to do that part separarately since it involves different places in the code. I will to a Changlog for the testsuite changes. In summary: modified: fmt_error_10.f to allow it to pass. modified: fmt_error_7.f likewise. modified: fmt_error_9.f likewise. new file: fmt_zero_width.f90 to test the new features. Regression tested on x86_64-pc-linux-gnu. OK for trunk? Jerry 2019-11-01 Jerry DeLisle PR fortran/90374 * io.c (check_format): Allow zero width for D, E, EN, and ES specifiers as default and when -std=F2018 is given. Retain existing errors when using the -fdec family of flags. 2019-11-01 Jerry DeLisle PR fortran/90374 io/format.c (parse_format_list): Relax format checking for zero width as default and when -std=f2018. io/format.h (format_token): Move definition to io.h. io/io.h (format_token): Add definition here to allow access to this definition at higher levels. Rename the declaration of write_real_g0 to write_real_w0 and add a new format_token argumanet so that higher level functions can pass to it the token so that handling of g0 vs the other zero width specifiers can be differentiated. io/transfer.c (formatted_transfer_scalar_write): Add checks for zero width and call write_real_w0 to handle it. io/write.c (write_real_g0): Remove. (write_real_w0): Add new, same as previous write_real_g0 except check format token to handle the g0 case. diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index b969a1a4738..57a3fdd5152 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -922,19 +922,38 @@ data_desc: if (u != FMT_POSINT) { + if (flag_dec) + { + if (flag_dec_format_defaults) + { + /* Assume a default width based on the variable size. */ + saved_token = u; + break; + } + else + { + gfc_error ("Positive width required in format " + "specifier %s at %L", token_to_string (t), + &format_locus); + saved_token = u; + goto fail; + } + } + + format_locus.nextc += format_string_pos; + if (!gfc_notify_std (GFC_STD_F2018, + "positive width required at %L", + &format_locus)) + { + saved_token = u; + goto fail; + } if (flag_dec_format_defaults) { /* Assume a default width based on the variable size. */ saved_token = u; break; } - - format_locus.nextc += format_string_pos; - gfc_error ("Positive width required in format " - "specifier %s at %L", token_to_string (t), - &format_locus); - saved_token = u; - goto fail; } u = format_lex (); diff --git a/gcc/testsuite/gfortran.dg/fmt_error_10.f b/gcc/testsuite/gfortran.dg/fmt_error_10.f index 7ea6aec1220..6e1a5f60bea 100644 --- a/gcc/testsuite/gfortran.dg/fmt_error_10.f +++ b/gcc/testsuite/gfortran.dg/fmt_error_10.f @@ -18,9 +18,9 @@ str = '(1pd0.15)' write (line,str,iostat=istat, iomsg=msg) 1.0d0 - if (istat.ne.5006 .or. msg(1:15).ne."Positive width ") STOP 5 + if (line.ne."1.000000000000000") STOP 5 read (*,str,iostat=istat, iomsg=msg) x - if (istat.ne.5006 .or. msg(1:15).ne."Positive width ") STOP 6 + if (istat.ne.5006 .or. msg(1:10).ne."Zero width") STOP 6 if (x.ne.555.25) STOP 7 write (line,'(1pd24.15e11.3)') 1.0d0, 1.234 diff --git a/gcc/testsuite/gfortran.dg/fmt_error_7.f b/gcc/testsuite/gfortran.dg/fmt_error_7.f index 9b5fba97e25..3937c8fe750 100644 --- a/gcc/testsuite/gfortran.dg/fmt_error_7.f +++ b/gcc/testsuite/gfortran.dg/fmt_error_7.f @@ -1,7 +1,9 @@ ! { dg-do compile } +! { dg-options "-std=f95" } + ! PR37446 Diagnostic of edit descriptors, esp. EN character(40) :: fmt_string write(*, '(1P,2E12.4)') 1.0 - write(*,'(EN)') 5.0 ! { dg-error "Positive width required" } + write(*,'(EN)') 5.0 ! { dg-error "positive width required" } write(*,'("abcdefg",EN6,"hjjklmnop")') 5.0 ! { dg-error "Period required" } end diff --git a/gcc/testsuite/gfortran.dg/fmt_error_9.f b/gcc/testsuite/gfortran.dg/fmt_error_9.f index 1d677509e37..40c73599ac8 100644 --- a/gcc/testsuite/gfortran.dg/fmt_error_9.f +++ b/gcc/testsuite/gfortran.dg/fmt_error_9.f @@ -16,7 +16,7 @@ write (line,str,iostat=istat, iomsg=msg) 1.0d0 if (istat.ne.0) STOP 3 read (*,str,iostat=istat, iomsg=msg) x - if (istat.ne.5006 .or. msg(1:15).ne."Positive width ") STOP 4 + if (istat.ne.5006 .or. msg(1:10).ne."Zero width") STOP 4 if (x.ne.555.25) STOP 5 write (line,'(1pd24.15e11.3)') 1.0d0, 1.234 diff --git a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 new file mode 100644 index 00000000000..093c0a44c34 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! PR90374 "5.5 d0.d, e0.d, es0.d, en0.d, g0.d and ew.d edit descriptors +program pr90374 + real(4) :: rn + character(32) :: afmt, aresult + real(8) :: one = 1.0D0, zero = 0.0D0, nan, pinf, minf + + nan = zero/zero + rn = 0.00314_4 + afmt = "(D0.3)" + write (aresult,fmt=afmt) rn + if (aresult /= "0.314D-02") stop 12 + afmt = "(E0.10)" + write (aresult,fmt=afmt) rn + if (aresult /= "0.3139999928E-02") stop 15 + afmt = "(ES0.10)" + write (aresult,fmt=afmt) rn + if (aresult /= "3.1399999280E-03") stop 18 + afmt = "(EN0.10)" + write (aresult,fmt=afmt) rn + if (aresult /= "3.1399999280E-03") stop 21 + afmt = "(G0.10)" + write (aresult,fmt=afmt) rn + if (aresult /= "0.3139999928E-02") stop 24 + write (aresult,fmt="(D0.3)") rn + if (aresult /= "0.314D-02") stop 26 + write (aresult,fmt="(E0.10)") rn + if (aresult /= "0.3139999928E-02") stop 28 + write (aresult,fmt="(ES0.10)") rn + if (aresult /= "3.1399999280E-03") stop 30 + write (aresult,fmt="(EN0.10)") rn + if (aresult /= "3.1399999280E-03") stop 32 + write (aresult,fmt="(G0.10)") rn + if (aresult /= "0.3139999928E-02") stop 34 + +end diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index e798d9bda87..b33620815d5 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -925,7 +925,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) tail->repeat = repeat; u = format_lex (fmt); - if (t == FMT_G && u == FMT_ZERO) + if (u == FMT_ZERO) { *seen_dd = true; if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR @@ -944,10 +944,8 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) u = format_lex (fmt); if (u != FMT_POSINT) - { - fmt->error = posint_required; - goto finished; - } + notify_std (&dtp->common, GFC_STD_F2003, + "Positive width required"); tail->u.real.d = fmt->value; break; } diff --git a/libgfortran/io/format.h b/libgfortran/io/format.h index 84169e95d91..a0899736aea 100644 --- a/libgfortran/io/format.h +++ b/libgfortran/io/format.h @@ -27,22 +27,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "io.h" - -/* Format tokens. Only about half of these can be stored in the - format nodes. */ - -typedef enum -{ - FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, - FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL, - FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING, - FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F, - FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC, - FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT -} -format_token; - - /* Format nodes. A format string is converted into a tree of these structures, which is traversed as part of a data transfer statement. */ diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index bcd6dde9a5b..5b89d47e613 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -132,6 +132,20 @@ typedef struct format_hash_entry } format_hash_entry; +/* Format tokens. Only about half of these can be stored in the + format nodes. */ + +typedef enum +{ + FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, + FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL, + FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING, + FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F, + FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC, + FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT +} +format_token; + /* Representation of a namelist object in libgfortran Namelist Records @@ -928,8 +942,8 @@ internal_proto(write_o); extern void write_real (st_parameter_dt *, const char *, int); internal_proto(write_real); -extern void write_real_g0 (st_parameter_dt *, const char *, int, int); -internal_proto(write_real_g0); +extern void write_real_w0 (st_parameter_dt *, const char *, int, format_token, int); +internal_proto(write_real_w0); extern void write_x (st_parameter_dt *, int, int); internal_proto(write_x); diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 4c5e210ce5a..6382d0dad09 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -2008,7 +2008,10 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - write_d (dtp, f, p, kind); + if (f->u.real.w == 0) + write_real_w0 (dtp, p, kind, FMT_D, f->u.real.d); + else + write_d (dtp, f, p, kind); break; case FMT_DT: @@ -2071,7 +2074,10 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - write_e (dtp, f, p, kind); + if (f->u.real.w == 0) + write_real_w0 (dtp, p, kind, FMT_E, f->u.real.d); + else + write_e (dtp, f, p, kind); break; case FMT_EN: @@ -2079,7 +2085,10 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - write_en (dtp, f, p, kind); + if (f->u.real.w == 0) + write_real_w0 (dtp, p, kind, FMT_EN, f->u.real.d); + else + write_en (dtp, f, p, kind); break; case FMT_ES: @@ -2087,7 +2096,10 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - write_es (dtp, f, p, kind); + if (f->u.real.w == 0) + write_real_w0 (dtp, p, kind, FMT_ES, f->u.real.d); + else + write_es (dtp, f, p, kind); break; case FMT_F: @@ -2117,7 +2129,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin break; case BT_REAL: if (f->u.real.w == 0) - write_real_g0 (dtp, p, kind, f->u.real.d); + write_real_w0 (dtp, p, kind, FMT_G, f->u.real.d); else write_d (dtp, f, p, kind); break; diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index eacd1f79715..5ebe83b0dbd 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -1720,25 +1720,32 @@ write_real (st_parameter_dt *dtp, const char *source, int kind) compensate for the extra digit. */ void -write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d) +write_real_w0 (st_parameter_dt *dtp, const char *source, int kind, + format_token fmt, int d) { fnode f; char buf_stack[BUF_STACK_SZ]; char str_buf[BUF_STACK_SZ]; char *buffer, *result; size_t buf_size, res_len, flt_str_len; - int comp_d; + int comp_d = 0; set_fnode_default (dtp, &f, kind); if (d > 0) f.u.real.d = d; + f.format = fmt; + + /* For FMT_G, Compensate for extra digits when using scale factor, d + is not specified, and the magnitude is such that E editing + is used. */ + if (fmt == FMT_G) + { + if (dtp->u.p.scale_factor > 0 && d == 0) + comp_d = 1; + else + comp_d = 0; + } - /* Compensate for extra digits when using scale factor, d is not - specified, and the magnitude is such that E editing is used. */ - if (dtp->u.p.scale_factor > 0 && d == 0) - comp_d = 1; - else - comp_d = 0; dtp->u.p.g0_no_blanks = 1; /* Precision for snprintf call. */ @@ -1750,7 +1757,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d) buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind); get_float_string (dtp, &f, source , kind, comp_d, buffer, - precision, buf_size, result, &flt_str_len); + precision, buf_size, result, &flt_str_len); write_float_string (dtp, result, flt_str_len); dtp->u.p.g0_no_blanks = 0;