[gcc r17-2099] fortran: [PR126018] Fix rejects character function invocation as stop code

[Jerry DeLisle]

https://gcc.gnu.org/g:b6de3eb243c91b6503d95cc1942f55378ae6cbae

commit r17-2099-gb6de3eb243c91b6503d95cc1942f55378ae6cbae
Author: Jerry DeLisle <jvdelisle@gcc.gnu.org>
Date:   Wed Jul 1 14:03:23 2026 -0700

    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:
---
 gcc/fortran/match.cc                               | 23 ++++++++++++----------
 gcc/fortran/resolve.cc                             | 19 ++++++++++++++++++
 gcc/testsuite/gfortran.dg/stop_function_code_1.f90 | 14 +++++++++++++
 3 files changed, 46 insertions(+), 10 deletions(-)

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index be376a8c0625..4471c1b13b57 100644
--- 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 9eb022d608d8..4fc7b5a4d740 100644
--- 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
index 000000000000..6f69f54e35a5
--- /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