[PATCH] PR fortran/102332 - ICE in select_type_set_tmp, at fortran/match.c:6366

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 506 bytes --]

Dear all,

there are a couple of NULL pointer dereferences leading to improper
error recovery when trying to handle Gerhard's testcases involving
SELECT TYPE and invalid uses of CLASS variables.

The fixes look pretty obvious to me, but I'm submitting here to
check if there is more that should be done here.

(I was surprised to see that there are several different places
involved by rather simple variations in the basic test case.)

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Fortran-avoid-several-NULL-pointer-dereferences-duri.patch --]
[-- Type: text/x-patch, Size: 6242 bytes --]

From 4cda248202ea741bea1dd1ca4531aa15f423801b Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 27 Dec 2021 23:06:18 +0100
Subject: [PATCH] Fortran: avoid several NULL pointer dereferences during error
 recovery

gcc/fortran/ChangeLog:

	PR fortran/102332
	* expr.c (gfc_get_variable_expr): Avoid NULL pointer dereferences
	during handling of errors with invalid uses of CLASS variables.
	* match.c (select_type_set_tmp): Likewise.
	* primary.c (gfc_match_varspec): Likewise.
	* resolve.c (resolve_variable): Likewise.
	(resolve_select_type): Likewise.

gcc/testsuite/ChangeLog:

	PR fortran/102332
	* gfortran.dg/pr102332.f90: New test.
---
 gcc/fortran/expr.c                     |  3 +-
 gcc/fortran/match.c                    |  3 +-
 gcc/fortran/primary.c                  |  1 +
 gcc/fortran/resolve.c                  |  9 +++-
 gcc/testsuite/gfortran.dg/pr102332.f90 | 69 ++++++++++++++++++++++++++
 5 files changed, 81 insertions(+), 4 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr102332.f90

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b874607db1d..c1258e0eb06 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -5166,7 +5166,8 @@ gfc_get_variable_expr (gfc_symtree *var)

   if (var->n.sym->attr.flavor != FL_PROCEDURE
       && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
-	   || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
+	   || (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived
+	       && CLASS_DATA (var->n.sym)
 	       && CLASS_DATA (var->n.sym)->as)))
     {
       e->rank = var->n.sym->ts.type == BT_CLASS
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 617fb35c9cd..41faa53b97a 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -6363,7 +6363,8 @@ select_type_set_tmp (gfc_typespec *ts)
       sym = tmp->n.sym;
       gfc_add_type (sym, ts, NULL);

-      if (selector->ts.type == BT_CLASS && selector->attr.class_ok)
+      if (selector->ts.type == BT_CLASS && selector->attr.class_ok
+	  && selector->ts.u.derived && CLASS_DATA (selector))
 	{
 	  sym->attr.pointer
 		= CLASS_DATA (selector)->attr.class_pointer;
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index d873264a08e..1f63028d179 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2151,6 +2151,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	  && !(gfc_matching_procptr_assignment
 	       && sym->attr.flavor == FL_PROCEDURE))
       || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	  && sym->ts.u.derived && CLASS_DATA (sym)
 	  && (CLASS_DATA (sym)->attr.dimension
 	      || CLASS_DATA (sym)->attr.codimension)))
     {
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bff1b35446f..591e8186007 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5736,6 +5736,8 @@ resolve_variable (gfc_expr *e)
      can't be translated that way.  */
   if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
       && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
+      && sym->assoc->target->ts.u.derived
+      && CLASS_DATA (sym->assoc->target)
       && CLASS_DATA (sym->assoc->target)->as)
     {
       gfc_ref *ref = e->ref;
@@ -5799,7 +5801,8 @@ resolve_variable (gfc_expr *e)
   /* Like above, but for class types, where the checking whether an array
      ref is present is more complicated.  Furthermore make sure not to add
      the full array ref to _vptr or _len refs.  */
-  if (sym->assoc && sym->ts.type == BT_CLASS
+  if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
+      && CLASS_DATA (sym)
       && CLASS_DATA (sym)->attr.dimension
       && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
     {
@@ -9432,6 +9435,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)

       /* Check F03:C815.  */
       if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	  && selector_type
 	  && !selector_type->attr.unlimited_polymorphic
 	  && !gfc_type_is_extensible (c->ts.u.derived))
 	{
@@ -9442,7 +9446,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	}

       /* Check F03:C816.  */
-      if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic
+      if (c->ts.type != BT_UNKNOWN
+	  && selector_type && !selector_type->attr.unlimited_polymorphic
 	  && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
 	      || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
 	{
diff --git a/gcc/testsuite/gfortran.dg/pr102332.f90 b/gcc/testsuite/gfortran.dg/pr102332.f90
new file mode 100644
index 00000000000..f9557094083
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102332.f90
@@ -0,0 +1,69 @@
+! { dg-do compile }
+! PR fortran/102332 - ICE in select_type_set_tmp
+! Contributed by G.Steinmetz
+
+program p
+  type t
+     real :: a, b
+  end type
+  class(t), allocatable :: x ! Valid
+  select type (y => x)
+  type is (t)
+     y%a = 0
+  end select
+end
+
+subroutine s0 (x)
+  type t
+     real :: a, b
+  end type
+  class(t) :: x ! Valid
+  select type (y => x)
+  type is (t)
+     y%a = 0
+  end select
+end
+
+subroutine s1
+  type t
+     real :: a, b
+  end type
+  class(t) :: x         ! { dg-error "must be dummy, allocatable or pointer" }
+  select type (y => x)
+  type is (t)
+     y%a = 0
+  end select
+end
+
+subroutine s3
+  type t
+     real :: a, b
+  end type
+  class(t) :: x         ! { dg-error "must be dummy, allocatable or pointer" }
+  select type (y => x)
+  class is (t)
+     y%a = 0
+  end select
+end
+
+subroutine s2
+  type t
+     real :: a, b
+  end type
+  class(t) :: x         ! { dg-error "must be dummy, allocatable or pointer" }
+  select type (y => x)
+  type default          ! { dg-error "Expected" }
+     y%a = 0
+  end select
+end
+
+subroutine s4
+  type t
+     real :: a, b
+  end type
+  class(t) :: x         ! { dg-error "must be dummy, allocatable or pointer" }
+  select type (y => x)
+  class default
+     y%a = 0
+  end select
+end
--
2.26.2