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 <anl...@gmx.de>
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
