From patchwork Wed Feb 23 22:21:43 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1596920 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: bilbo.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=GKFyA8pT; dkim-atps=neutral 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+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) 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 bilbo.ozlabs.org (Postfix) with ESMTPS id 4K3rBw1JvPz9s8s for ; Thu, 24 Feb 2022 09:22:46 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id BDF673858425 for ; Wed, 23 Feb 2022 22:22:44 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org BDF673858425 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1645654964; bh=WZOIUYcyc0ILuelG9loVlJNwh0Dj96810c5Kr8UGJZ4=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=GKFyA8pTOYT4gnm3NStwX26QUBGq5LEDBPob8Y5CHQ3LPhgUiDFPbYhXbt5956gxi qneLI6w9Uslab8jcxUBoBQdm4E4F9NX7dwwJlwR5Npcc1HOlkO1+FO5Ap+Jv8XpSKM /SGnR7gBAf3Wb1lyb8DnSoIeQdIW1Mk0Q+6funEk= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.17.21]) by sourceware.org (Postfix) with ESMTPS id AD0BA3858D28; Wed, 23 Feb 2022 22:21:44 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org AD0BA3858D28 X-UI-Sender-Class: 01bb95c1-4bf8-414a-932a-4f6e2808ef9c Received: from [79.251.15.46] ([79.251.15.46]) by web-mail.gmx.net (3c-app-gmx-bap14.server.lan [172.19.172.84]) (via HTTP); Wed, 23 Feb 2022 23:21:43 +0100 MIME-Version: 1.0 Message-ID: To: fortran , gcc-patches Subject: [PATCH] PR fortran/84519 - [F2018] STOP and ERROR STOP statements with QUIET specifier Date: Wed, 23 Feb 2022 23:21:43 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:+iXTpCzlpDzaAmLqgN3kfYL9q/w++DmthJtGJFzZb6zpFxDkeAbINVQ2JNmw5A5+DsHae wryfMal18wTIYzAn2O9t9YqyA112BlM/T7fo1GIxfTmIkxyhz+Jqr7d1fvD+TluDzcZLLBg+YkGC PqBgvurUDZPV0CG7mwcSSz8SAFZJnsAlWycmYTbAT/3RLoxpPeW8bZfG2P8sHJlGJdbzO6U8CWn4 dMCa8PZz1/L8AHZD24I+Qi9BqEQkP1rz3cTY5PF9OFszP53O0MNmoMvGdniFJozVfQu9P3xq/Dsg bQ= X-UI-Out-Filterresults: notjunk:1;V03:K0:EzLbglLSm9s=:Ak76J+zxaamSTXNTsUt18G Dezfbi4XZzSyvy+lKU2IqrDOoVsJiOtsc+4Yx8uE6rtqMFI6kjv2XqPE5Ch1b/6PuwnU26QCK Mv1vG+gs5o9IuzmeE1wvyGFgjaCL6ibe30PA0djGachIWc2d5BW1OjCzSN0D37vyWXYs0ljvJ sKOL0FrhICL28oZ2rvL1H0AU2QRIdcckWAaqOZo4uVuaY7aSkhCoxtKwH+PAKvLrDwwWfZs/P iP7BjucmxSnrDqOWB6exnYNvClW145aZkna3TUDI//uQsohyTChKGx5A9SacQlOVZwLa2UCVZ n2rNpliqXTqr7Y45u7IxXP2ZI3EU7DTxbCUENsZEM+/1wy8jq8+sacQVyuvh78g5IKZz+Ot8u rCkv5WIikxoy0vVx6tLGIQKpnKmwUWW1FfCnYD8BPoIkrMW1LaSBRn4+YJEWaLvuzR7h4xuIx qyqlqrHlSt6CEShhort0MmGFnFilFZq+aaxmcX5/moOAsM/Azm5i1qXELxNhr/ym1IXBWPFZc wLpxmzs+I3jcg9O2A1PwWbA4WbB//spqORTInIaqEChwRpSo++dmf3qHo0c37Cqf9dtAT6Cp3 RtmzP1TQ48JiQmUKEPJqSUKu3304ym37LY3BvKB7v/2RhuUGx0cRb2oZASyJFw0OSweIFyaab xfa/cunwhMnoyFamy1RlPJvIFojy8mU8g5s3X28lFQ5YCEgUg+1Mocr+PWn6Sl4omZWJeJt1n D0pk9pU/tsuTUoYSwTiWA1Re65zH2vgQ4Yeh2/ERw35Cpc9dGNnqjOi+pXdWu7PDWTzSJJ2QV b8Fc0Tc X-Spam-Status: No, score=-11.0 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) 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: , X-Patchwork-Original-From: Harald Anlauf via Gcc-patches From: Harald Anlauf Reply-To: Harald Anlauf Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" Dear Fortranners, Fortran 2018 added a QUIET= specifier to STOP and ERROR STOP statements. Janne already implemented the library side code four (4!) years ago, but so far the frontend implementation was missing. Furthermore, F2018 allows for non-default-integer stopcode expressions (finally!). The attached patch provides this implementation. That was not too much fun for the following reasons: - fixed format vs. free format - F95 and F2003 apparently did not require a blank between STOP and stopcode, while F2008+ do require it. This should explain for the three testcases. Regtested on x86_64-pc-linux-gnu. OK for mainline? One step closer to F2018! Thanks, Harald From 66e80a9847b3e16d4c619ba8da9f3dba891cff34 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Wed, 23 Feb 2022 23:08:29 +0100 Subject: [PATCH] Fortran: frontend code for F2018 QUIET specifier to STOP and ERROR STOP Fortran 2018 allows for a QUIET specifier to the STOP and ERROR STOP statements. Whilst the gfortran library code provides support for this specifier for quite some time, the frontend implementation was missing. gcc/fortran/ChangeLog: PR fortran/84519 * dump-parse-tree.cc (show_code_node): Dump QUIET specifier when present. * match.cc (gfc_match_stopcode): Implement parsing of F2018 QUIET specifier. F2018 stopcodes may have non-default integer kind. * trans-stmt.cc (gfc_trans_stop): Pass QUIET specifier to call of library function. gcc/testsuite/ChangeLog: PR fortran/84519 * gfortran.dg/stop_1.f90: New test. * gfortran.dg/stop_2.f: New test. * gfortran.dg/stop_3.f90: New test. --- gcc/fortran/dump-parse-tree.cc | 5 +++ gcc/fortran/match.cc | 62 +++++++++++++++++++++++----- gcc/fortran/trans-stmt.cc | 21 ++++++++-- gcc/testsuite/gfortran.dg/stop_1.f90 | 44 ++++++++++++++++++++ gcc/testsuite/gfortran.dg/stop_2.f | 31 ++++++++++++++ gcc/testsuite/gfortran.dg/stop_3.f90 | 22 ++++++++++ 6 files changed, 172 insertions(+), 13 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/stop_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/stop_2.f create mode 100644 gcc/testsuite/gfortran.dg/stop_3.f90 diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 2a2f9901b08..322416e6556 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -2370,6 +2370,11 @@ show_code_node (int level, gfc_code *c) show_expr (c->expr1); else fprintf (dumpfile, "%d", c->ext.stop_code); + if (c->expr2 != NULL) + { + fputs (" QUIET=", dumpfile); + show_expr (c->expr2); + } break; diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 8edfe4a3a2d..715a74eba51 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -2978,6 +2978,13 @@ Fortran 2008 has R856 allstop-stmt is ALL STOP [ stop-code ] R857 stop-code is scalar-default-char-constant-expr or scalar-int-constant-expr +Fortran 2018 has + + R1160 stop-stmt is STOP [ stop-code ] [ , QUIET = scalar-logical-expr] + R1161 error-stop-stmt is + ERROR STOP [ stop-code ] [ , QUIET = scalar-logical-expr] + R1162 stop-code is scalar-default-char-expr + or scalar-int-expr For free-form source code, all standards contain a statement of the form: @@ -2994,8 +3001,10 @@ static match gfc_match_stopcode (gfc_statement st) { gfc_expr *e = NULL; + gfc_expr *quiet = NULL; match m; bool f95, f03, f08; + char c; /* Set f95 for -std=f95. */ f95 = (gfc_option.allow_std == GFC_STD_OPT_F95); @@ -3006,11 +3015,16 @@ gfc_match_stopcode (gfc_statement st) /* Set f08 for -std=f2008. */ f08 = (gfc_option.allow_std == GFC_STD_OPT_F08); - /* Look for a blank between STOP and the stop-code for F2008 or later. */ - if (gfc_current_form != FORM_FIXED && !(f95 || f03)) - { - char c = gfc_peek_ascii_char (); + /* Plain STOP statement? */ + if (gfc_match_eos () == MATCH_YES) + goto checks; + + /* Look for a blank between STOP and the stop-code for F2008 or later. + But allow for F2018's ,QUIET= specifier. */ + c = gfc_peek_ascii_char (); + if (gfc_current_form != FORM_FIXED && !(f95 || f03) && c != ',') + { /* Look for end-of-statement. There is no stop-code. */ if (c == '\n' || c == '!' || c == ';') goto done; @@ -3023,7 +3037,12 @@ gfc_match_stopcode (gfc_statement st) } } - if (gfc_match_eos () != MATCH_YES) + if (c == ' ') + { + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + } + if (c != ',') { int stopcode; locus old_locus; @@ -3053,11 +3072,20 @@ gfc_match_stopcode (gfc_statement st) goto cleanup; if (m == MATCH_NO) goto syntax; + } - if (gfc_match_eos () != MATCH_YES) - goto syntax; + if (gfc_match (" , quiet = %e", &quiet) == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2018, "QUIET= specifier for %s at %L", + gfc_ascii_statement (st), &quiet->where)) + goto cleanup; } + if (gfc_match_eos () != MATCH_YES) + goto syntax; + +checks: + if (gfc_pure (NULL)) { if (st == ST_ERROR_STOP) @@ -3133,10 +3161,22 @@ gfc_match_stopcode (gfc_statement st) goto cleanup; } - if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind) + if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind + && !gfc_notify_std (GFC_STD_F2018, + "STOP code at %L must be default integer KIND=%d", + &e->where, (int) gfc_default_integer_kind)) + goto cleanup; + } + + if (quiet != NULL) + { + if (!gfc_simplify_expr (quiet, 0)) + goto cleanup; + + if (quiet->rank != 0) { - gfc_error ("STOP code at %L must be default integer KIND=%d", - &e->where, (int) gfc_default_integer_kind); + gfc_error ("QUIET specifier at %L must be a scalar LOGICAL", + &quiet->where); goto cleanup; } } @@ -3159,6 +3199,7 @@ done: } new_st.expr1 = e; + new_st.expr2 = quiet; new_st.ext.stop_code = -1; return MATCH_YES; @@ -3169,6 +3210,7 @@ syntax: cleanup: gfc_free_expr (e); + gfc_free_expr (quiet); return MATCH_ERROR; } diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 30b6bd5dd2a..e1307aaab66 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -652,11 +652,26 @@ gfc_trans_stop (gfc_code *code, bool error_stop) { gfc_se se; tree tmp; + tree quiet; /* Start a new block for this statement. */ gfc_init_se (&se, NULL); gfc_start_block (&se.pre); + if (code->expr2) + { + if (code->expr2->ts.type != BT_LOGICAL || code->expr2->rank != 0) + { + gfc_error ("QUIET specifier at %L must be a scalar LOGICAL", + &code->expr2->where); + return NULL_TREE; + } + gfc_conv_expr_val (&se, code->expr2); + quiet = fold_convert (boolean_type_node, se.expr); + } + else + quiet = boolean_false_node; + if (code->expr1 == NULL) { tmp = build_int_cst (size_type_node, 0); @@ -669,7 +684,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop) ? gfor_fndecl_caf_stop_str : gfor_fndecl_stop_string), 3, build_int_cst (pchar_type_node, 0), tmp, - boolean_false_node); + quiet); } else if (code->expr1->ts.type == BT_INTEGER) { @@ -683,7 +698,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop) ? gfor_fndecl_caf_stop_numeric : gfor_fndecl_stop_numeric), 2, fold_convert (integer_type_node, se.expr), - boolean_false_node); + quiet); } else { @@ -698,7 +713,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop) : gfor_fndecl_stop_string), 3, se.expr, fold_convert (size_type_node, se.string_length), - boolean_false_node); + quiet); } gfc_add_expr_to_block (&se.pre, tmp); diff --git a/gcc/testsuite/gfortran.dg/stop_1.f90 b/gcc/testsuite/gfortran.dg/stop_1.f90 new file mode 100644 index 00000000000..3e00455ba4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/stop_1.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } + + implicit none + logical :: q = .false. + integer(2) :: p = 99 + real :: x = 0. + character(5) :: s = "stopp" + print *, "Hello" + stop 1, quiet=.false. + stop 2, quiet=q + stop 3, quiet=f(x) + stop; stop! + stop ;stop 4! + stop 5; stop 6 + stop 7 ;stop 8 + stop 1_1; stop 2_2; stop 4_4; stop 8_8 + stop&! + &;stop;&! + stop&! + s& + ; stop "x";&! + ; st&! + &op&! + p + stop s + if(f(x))then;stop 9,quiet=.false.;else;stop 10;endif + error stop 4, quiet=.true. + error stop 5 , quiet=.true. + error stop s, quiet=.true. + stop "last " // s, quiet=.false._2 + stop, quiet=any([.false.]) + stop , quiet=any([f(x)]) + stop "stopp" , quiet=any([f(x)]) + stop s, quiet=all([f(x)]) + stop42, quiet=.false. ! { dg-error "Blank required" } + stop"stopp" , quiet=any([f(x)]) ! { dg-error "Blank required" } + stop 8, quiet=([f(x)]) ! { dg-error "must be a scalar LOGICAL" } +contains + logical function f(x) + real, intent(in) :: x + f = .false. + end function f +end diff --git a/gcc/testsuite/gfortran.dg/stop_2.f b/gcc/testsuite/gfortran.dg/stop_2.f new file mode 100644 index 00000000000..24fb91350cd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/stop_2.f @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } + + implicit none + logical :: q = .false. + integer(2) :: p = 99 + real :: x = 0. + character(5) :: s = "stopp" + stop 1, quiet=.false. + stop 2, quiet=q + stop 3, quiet=f(x) + stop42,quiet=.false. + error stop 4, quiet=.true. + error stop 5 , quiet=.true. + stop1_1;stop2_2;stop4_4;stop8_8 + stopp;stops + st + &op42 + stop, quiet=any([.false.]) + stop , quiet=any([f(x)]) + stop"stopp",quiet=any([f(x)]) + stop "stopp" , quiet=any([f(x)]) + s to ps,quiet=all([f(x)]) + e r r o r s t o p 4 3 , q u i e t = . t r u e . + errorstop"stopp",quiet=.not.f(x) + contains + logical function f(x) + real, intent(in) :: x + f = .false. + end function f + end diff --git a/gcc/testsuite/gfortran.dg/stop_3.f90 b/gcc/testsuite/gfortran.dg/stop_3.f90 new file mode 100644 index 00000000000..bc153dd3455 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/stop_3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! F95 and F2003 do not require a blank after STOP + + implicit none + integer, parameter :: p = 99 + character(*), parameter :: s = "stopp" + stop1 + stop2! + stop3;stop4! + stopp + stop&! + &;stop;&! + stop&! + s& + ;stop"x";&! + ;st&! + &op&! + p + stops + stop"last " // s +end -- 2.34.1