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.

4 files changed, 78 insertions, 13 deletions

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 2a2f990..322416e 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 8edfe4a..715a74e 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 451bc97..753aa27 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 30b6bd5..7909681 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);