From: Paul Thomas <pault@gcc.gnu.org>
Date: Mon, 10 Aug 2020 05:19:25 +0000 (+0100)
Subject: This patch fixes PR96102. See the explanatory comment in the testcase.
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=e6d42dd6cbf14f5859c0fb8b33a8a61d5906dafe;p=thirdparty%2Fgcc.git

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

2020-08-10  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.
---

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2751c0ccf62f..6caddcf4ef02 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5993,6 +5993,16 @@ check_host_association (gfc_expr *e)
 		if (ref->type == REF_ARRAY && ref->next == NULL)
 		  break;
 
+	      if ((ref == NULL || ref->type != REF_ARRAY)
+		  && sym->attr.proc == PROC_INTERNAL)
+		{
+		  gfc_error ("%qs at %L is host associated at %L into "
+			     "a contained procedure with an internal "
+			     "procedure of the same name", sym->name,
+			      &old_sym->declared_at, &e->where);
+		  return false;
+		}
+
 	      gcc_assert (ref->type == REF_ARRAY);
 
 	      /* Grab the start expressions from the array ref and
diff --git a/gcc/testsuite/gfortran.dg/pr96102.f90 b/gcc/testsuite/gfortran.dg/pr96102.f90
new file mode 100644
index 000000000000..0cf52226d852
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr96102.f90
@@ -0,0 +1,27 @@
+! { dg-do compile }
+!
+! Test the fix for PR96102 in which the two lines with 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