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.

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 2a2f9901b085ee9a2f8439b1ce3701f47a4a9ae2..322416e65567597cb93cfe79cfcf4a92920b7e0c 100644 (file)
--- 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 8edfe4a3a2dfdad4d6a1f65cbf568ae181ea22cf..715a74eba51f3bd8dd255cc4b71f0edb6a9dbff0 100644 (file)
--- 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 451bc97df433786b7cee1877b95c55e97a2b39df..753aa27e23f6bb0087a791dcc2c344737f3979f0 100644 (file)
--- 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 30b6bd5dd2a37acbfea2df5bd9e31b47ee51830e..79096816c6e9fcf6dac3ec68b960d596c1598583 100644 (file)
--- 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 (file)
index 0000000..3e00455
--- /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 (file)
index 0000000..24fb913
--- /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 (file)
index 0000000..bc153dd
--- /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 (file)
index 0000000..f01b3ae
--- /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" } }