fortran: [PR126018] Fix rejects character function invocation as stop code

Expressions used in stop codes can be functions as long as they resolve to
integer or character.

	PR fortran/126018

gcc/fortran/ChangeLog:

	* match.cc (gfc_match_stopcode): Adjust the f2008 error check.If the
	STOP code expr type is unknown, do not error. It will be checked in
	gfc_resolve_code.
	* resolve.cc (gfc_resolve_code): Add checks for EXEC_STOP and
	EXEC_ERROR_STOP.

gcc/testsuite/ChangeLog:

	* gfortran.dg/stop_function_code_1.f90: New test.

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index be376a8c0625529e0b38b5e213ca967a3b468a52..4471c1b13b577033ae009d163768bed24a1d5c05 100644 (file)
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -3960,19 +3960,22 @@ checks:
          goto cleanup;
        }
 
-      /* Use the machinery for an initialization expression to reduce the
-        stop-code to a constant.  */
-      gfc_reduce_init_expr (e);
-
-      /* Test for F2008 style STOP stop-code.  */
-      if (e->expr_type != EXPR_CONSTANT && f08)
+      /* If this is F2008, it could be an init expression.  */
+      if (f08)
        {
-         gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
-                    "INTEGER constant expression", &e->where);
-         goto cleanup;
+         gfc_reduce_init_expr (e);
+         if (e->expr_type != EXPR_CONSTANT)
+           {
+             gfc_error ("STOP code at %L must be a scalar constant "
+                        "expression", &e->where);
+             goto cleanup;
+           }
        }
 
-      if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
+      /* For types known at parse time, check immediately.  For BT_UNKNOWN
+        (e.g. a forward-referenced contained function) defer to resolve.  */
+      if (e->ts.type != BT_UNKNOWN
+         && !(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
        {
          gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
                     &e->where);

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 9eb022d608d89e16f065bdb9a5802b2cb943e284..4fc7b5a4d740bbc843e90db1e6aa332e109fb94c 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -14376,6 +14376,25 @@ start:
 
        case EXEC_STOP:
        case EXEC_ERROR_STOP:
+         if (code->expr1 != NULL && t)
+           {
+             if (!(code->expr1->ts.type == BT_CHARACTER
+                   || code->expr1->ts.type == BT_INTEGER))
+               gfc_error ("STOP code at %L must be either INTEGER or CHARACTER "
+                          "type", &code->expr1->where);
+             else if (code->expr1->rank != 0)
+               gfc_error ("STOP code at %L must be scalar",
+                          &code->expr1->where);
+             else if (code->expr1->ts.type == BT_CHARACTER
+                      && code->expr1->ts.kind != gfc_default_character_kind)
+               gfc_error ("STOP code at %L must be default character KIND=%d",
+                          &code->expr1->where, (int) gfc_default_character_kind);
+             else if (code->expr1->ts.type == BT_INTEGER
+                      && code->expr1->ts.kind != gfc_default_integer_kind)
+               gfc_notify_std (GFC_STD_F2018, "STOP code at %L must be default "
+                               "integer KIND=%d", &code->expr1->where,
+                               (int) gfc_default_integer_kind);
+           }
          if (code->expr2 != NULL
              && (code->expr2->ts.type != BT_LOGICAL
                  || code->expr2->rank != 0))

diff --git a/gcc/testsuite/gfortran.dg/stop_function_code_1.f90 b/gcc/testsuite/gfortran.dg/stop_function_code_1.f90
new file mode 100644 (file)
index 0000000..6f69f54
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/stop_function_code_1.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+! PR fortran/126018 - Stop code may be a function call (CHARACTER or INTEGER)
+program p
+  implicit none
+  error stop character_stop ()   ! was: "must be either INTEGER or CHARACTER"
+  stop integer_stop ()           ! likewise for integer
+contains
+  character (1) function character_stop ()
+    character_stop = "a"
+  end function character_stop
+  integer function integer_stop ()
+    integer_stop = 1
+  end function integer_stop
+end program p