From 66e80a9847b3e16d4c619ba8da9f3dba891cff34 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@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
@@ -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;
@@ -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;
}
@@ -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);
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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