Please find attach a fix for PR95398. The original patch was by Steve
Kargl.
OK to commit?
[PATCH] Fortran : ICE on invalid code PR95398
The CLASS_DATA macro is used to shorten the code accessing the derived
components of an expressions type specification. If the type is not
BT_CLASS the derived pointer is NULL resulting in an ICE. To avoid
dereferencing a NULL pointer the type should be BT_CLASS.
2020-08-26 Steven G. Kargl <ka...@gcc.gnu.org>
gcc/fortran
PR fortran/95398
* resolve.c (resolve_select_type): Add check for BT_CLASS
type before using the CLASS_DATA macro which will have a
NULL pointer to derive components if it isn't BT_CLASS.
2020-08-26 Mark Eggleston <markeggles...@gcc.gnu.org>
gcc/testsuite
PR fortran/95398
* gfortran/pr95398.f90: New test.
--
https://www.codethink.co.uk/privacy.html
>From 9460e5033d1f20efa8b6dc6c892a085de46105d3 Mon Sep 17 00:00:00 2001
From: Mark Eggleston <markeggles...@gcc.gnu.org>
Date: Mon, 1 Jun 2020 08:15:31 +0100
Subject: [PATCH] Fortran : ICE on invalid code PR95398
The CLASS_DATA macro is used to shorten the code accessing the derived
components of an expressions type specification. If the type is not
BT_CLASS the derived pointer is NULL resulting in an ICE. To avoid
dereferencing a NULL pointer the type should be BT_CLASS.
2020-08-26 Steven G. Kargl <ka...@gcc.gnu.org>
gcc/fortran
PR fortran/95398
* resolve.c (resolve_select_type): Add check for BT_CLASS
type before using the CLASS_DATA macro which will have a
NULL pointer to derive components if it isn't BT_CLASS.
2020-08-26 Mark Eggleston <markeggles...@gcc.gnu.org>
gcc/testsuite
PR fortran/95398
* gfortran/pr95398.f90: New test.
---
gcc/fortran/resolve.c | 4 ++-
gcc/testsuite/gfortran.dg/pr95398.f90 | 53 +++++++++++++++++++++++++++++++++++
2 files changed, 56 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/pr95398.f90
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6caddcf4ef0..e4232717e42 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9259,7 +9259,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
}
- if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
+ if (code->expr2->rank
+ && code->expr1->ts.type == BT_CLASS
+ && CLASS_DATA (code->expr1)->as)
CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
/* F2008: C803 The selector expression must not be coindexed. */
diff --git a/gcc/testsuite/gfortran.dg/pr95398.f90 b/gcc/testsuite/gfortran.dg/pr95398.f90
new file mode 100644
index 00000000000..81cc076c15c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr95398.f90
@@ -0,0 +1,53 @@
+! { dg-do compile }
+
+program test
+ implicit none
+
+ type :: t1
+ integer :: i
+ end type
+
+ type, extends(t1) :: t2
+ end type
+
+ class(t1), allocatable :: array1(:,:)
+ class(t2), allocatable :: array2(:,:)
+
+ allocate(array1(3,3))
+ allocate(array2(3,3))
+
+ select type(b => foo(1))
+ type is (t1)
+ b%i = 1
+ type is (t2)
+ call sub_with_in_and_inout_param(b,b)
+ end select
+
+ contains
+
+ function foo(i)
+ integer :: U(2)
+ integer :: i
+ class(t1), POINTER :: foo(:)
+ ALLOCATE(foo(2))
+ U = [ 1,2 ]
+ if (i>0) then
+ foo => array1(2,U)
+ else
+ foo => array2(2,U)
+ end if
+ end function
+
+ subroutine sub_with_in_and_inout_param(y, z)
+ type(t2), INTENT(IN) :: y(:)
+ class(t2), INTENT(INOUT) :: z(:)
+ z%i = 10
+ end subroutine
+
+end
+
+! { dg-error "cannot be used in a variable definition context .assignment." " " { target *-*-* } 21 }
+! { dg-error "cannot be used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 23 }
+! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 35 }
+! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 37 }
+
--
2.11.0
