Fortran: Fix ICE arising from PDT class components [PR107142]

2025-12-11  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/107142
	* match.cc (gfc_match_type_spec): Change original declaration
	to static match_type_spec and call from gfc_match_type_spec,
	where the gfc_current_ns is stashed and restored after call.
	(gfc_match_type_is): Before emitting the syntax error message
	check if there are any pending error messages and use them
	instead.

gcc/testsuite
	PR fortran/107142
	* gfortran.dg/pdt_78.f03: New test.

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index e009c82b0bd049dc27998e9d13a7374c02e6b0f4..666eef4c937554352f3c5bf68f1e0f8e763aeb25 100644 (file)
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -2305,8 +2305,8 @@ match_derived_type_spec (gfc_typespec *ts)
    the implicit_flag is not needed, so it was removed. Derived types are
    identified by their name alone.  */
 
-match
-gfc_match_type_spec (gfc_typespec *ts)
+static match
+match_type_spec (gfc_typespec *ts)
 {
   match m;
   locus old_locus;
@@ -2516,6 +2516,17 @@ kind_selector:
 }
 
 
+match
+gfc_match_type_spec (gfc_typespec *ts)
+{
+  match m;
+  gfc_namespace *old_ns = gfc_current_ns;
+  m = match_type_spec (ts);
+  gfc_current_ns = old_ns;
+  return m;
+}
+
+
 /******************** FORALL subroutines ********************/
 
 /* Free a list of FORALL iterators.  */
@@ -7941,7 +7952,9 @@ gfc_match_type_is (void)
   return MATCH_YES;
 
 syntax:
-  gfc_error ("Syntax error in TYPE IS specification at %C");
+
+  if (!gfc_error_check ())
+    gfc_error ("Syntax error in TYPE IS specification at %C");
 
 cleanup:
   if (c != NULL)

diff --git a/gcc/testsuite/gfortran.dg/pdt_78.f03 b/gcc/testsuite/gfortran.dg/pdt_78.f03
new file mode 100644 (file)
index 0000000..27e405d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_78.f03
@@ -0,0 +1,23 @@
+! { dg-do compile }
+!
+! Test the fix for PR107142, which used to ICE after a syntax error.
+!
+! Contributed by Arseny Solokha  <asolokha@gmx.com>
+!
+module c1162a
+  type pdt(kind,len)
+    integer, kind :: kind
+    integer, len :: len
+  end type
+ contains
+  subroutine foo(x)
+    class(pdt(kind = 1, len = :)), allocatable :: x
+    select type (x)
+      type is (pdt(kind = *, len = *)) ! { dg-error "does not have a default value" }
+      type is (pdt(kind = :, len = *)) ! { dg-error "does not have a default value" }
+    end select
+    select type (x)
+      type is (pdt(kind = 1, len = *)) ! This, of course, is OK
+    end select
+  end subroutine
+end module