[Patch, fortran] PR96102 - ICE in check_host_association, at fortran/resolve.c:5994

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

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

The attached patch builds on a draft posted by Steve Kargl. I have left the
gcc_assert in place just in case my imagination was too limited to generate
an ICE.

Regtests OK on FC31/x86_64 - OK for trunk?

Paul

[-- Attachment #2: Change.Logs --]
[-- Type: application/octet-stream, Size: 322 bytes --]

This patch fixes PR96102. See the explanatory comment in the testcase.

2020-08-05  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/96102
	* resolve.c (check_host_association): Replace the gcc_assert
	with an error for internal procedures.

gcc/testsuite/
	PR fortran/96102
	* gfortran.dg/pr96102.f90: New test.

[-- Attachment #3: submit.diff --]
[-- Type: text/x-patch, Size: 745 bytes --]

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2751c0ccf62..4046bed1863 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5993,6 +5993,17 @@ check_host_association (gfc_expr *e)
 		if (ref->type == REF_ARRAY && ref->next == NULL)
 		  break;
 
+	      if ((ref == NULL || ref->type != REF_ARRAY)
+		  && old_sym->attr.flavor == FL_VARIABLE
+		  && sym->attr.proc == PROC_INTERNAL)
+		{
+		  gfc_error ("%qs at %L is being host associated into "
+			     "a contained procedure with an internal "
+			     "procedure of the same name", sym->name,
+			      &sym->declared_at);
+		  return false;
+		}
+
 	      gcc_assert (ref->type == REF_ARRAY);
 
 	      /* Grab the start expressions from the array ref and

[-- Attachment #4: pr96102.f90 --]
[-- Type: text/x-fortran, Size: 721 bytes --]

! { dg-do compile }
!
! Test the fix for PR96102 in which the two lines with IF statements
! errors previously caused a segfault.
!
! Contributed by Gerhardt Steinmetz  <gscfq@t-online.de>
!
!
module m
   type mytype
     integer :: i
   end type
   type(mytype) :: d = mytype (42) ! { dg-error "is host associated" }
   integer :: n = 2                ! { dg-error "is host associated" }
contains
   subroutine s
      if ( n /= 0 ) stop 1    ! { dg-error "internal procedure of the same name" }
      if ( d%i /= 0 ) stop 2  ! { dg-error "internal procedure of the same name" }
   contains
      integer function n()
         n = 0
      end
      type(mytype) function d()
         d = mytype (0)
      end
   end
end