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-09-01  Steven G. Kargl  <kargl@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-09-01  Mark Eggleston  <markeggleston@gcc.gnu.org>

gcc/testsuite

	PR fortran/95398
	* gfortran.dg/pr95398.f90: New test.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6caddcf4ef02c5e826f7ede4984921d848173dd1..e4232717e42c4ae3eea49adcdeb3edeb66d5184a 100644 (file)
--- 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 (file)
index 0000000..81cc076
--- /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 }
+