From: Jerry DeLisle <jvdelisle@gcc.gnu.org>
Date: Wed, 1 Jul 2026 21:03:23 +0000 (-0700)
Subject: fortran: [PR126018] Fix rejects character function invocation as stop code
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=b6de3eb243c91b6503d95cc1942f55378ae6cbae;p=thirdparty%2Fgcc.git

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 be376a8c062..4471c1b13b5 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 9eb022d608d..4fc7b5a4d74 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 00000000000..6f69f54e35a
--- /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