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

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

