From 916b809fbfdd2740006270baf549bf22fe9ec3c4 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. * resolve.cc (gfc_resolve_code): Add checks for QUIET argument. * 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. * gfortran.dg/stop_4.f90: New test. --- gcc/fortran/dump-parse-tree.cc | 5 +++ gcc/fortran/match.cc | 64 +++++++++++++++++++++++----- gcc/fortran/resolve.cc | 9 ++++ gcc/fortran/trans-stmt.cc | 15 +++++-- gcc/testsuite/gfortran.dg/stop_1.f90 | 44 +++++++++++++++++++ gcc/testsuite/gfortran.dg/stop_2.f | 31 ++++++++++++++ gcc/testsuite/gfortran.dg/stop_3.f90 | 22 ++++++++++ gcc/testsuite/gfortran.dg/stop_4.f90 | 14 ++++++ 8 files changed, 190 insertions(+), 14 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 create mode 100644 gcc/testsuite/gfortran.dg/stop_4.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/resolve.cc b/gcc/fortran/resolve.cc index 451bc97df43..753aa27e23f 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -11944,8 +11944,17 @@ start: case EXEC_END_NESTED_BLOCK: case EXEC_CYCLE: case EXEC_PAUSE: + break; + case EXEC_STOP: case EXEC_ERROR_STOP: + if (code->expr2 != NULL + && (code->expr2->ts.type != BT_LOGICAL + || code->expr2->rank != 0)) + gfc_error ("QUIET specifier at %L must be a scalar LOGICAL", + &code->expr2->where); + break; + case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 30b6bd5dd2a..79096816c6e 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -652,11 +652,20 @@ 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) + { + 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 +678,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 +692,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 +707,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 diff --git a/gcc/testsuite/gfortran.dg/stop_4.f90 b/gcc/testsuite/gfortran.dg/stop_4.f90 new file mode 100644 index 00000000000..f01b3ae16c1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/stop_4.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original -std=f2018" } +! Check that the QUIET specifier to shut up a STOP statement is passed properly + +program p + logical(1) :: q = .true. ! using kind=1 to simplify scanning of tree dump + stop 0, quiet=q + stop 1, quiet=.true. + stop 2 ! the "noisy" default +end program p + +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(0, q\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(1, 1\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(2, 0\\)" "original" } }