From: Steven G. Kargl <kargl@gcc.gnu.org>
Date: Sat, 17 Aug 2019 18:11:58 +0000 (+0000)
Subject: re PR fortran/78719 ([F03] ICE in gfc_get_symbol_decl, at fortran/trans-decl.c:1438)
X-Git-Tag: releases/gcc-9.3.0~712
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=a5d319be20d09caa8342957e942c7bcfe6f3f20e;p=thirdparty%2Fgcc.git

re PR fortran/78719 ([F03] ICE in gfc_get_symbol_decl, at fortran/trans-decl.c:1438)

2019-08-17  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/78719
	* decl.c (get_proc_name): Check for a CLASS entity when trying to
	add attributes to an entity that already has an explicit interface.

2019-08-17  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/78719
	* gfortran.dg/pr78719_1.f90: New test.
	* gfortran.dg/pr78719_2.f90: Ditto.
	* gfortran.dg/pr78719_3.f90: Ditto.

From-SVN: r274610
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 24db61b369f2..a98a11244808 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2019-08-17  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/78719
+	* decl.c (get_proc_name): Check for a CLASS entity when trying to
+	add attributes to an entity that already has an explicit interface.
+
 2019-08-17  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/82992
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index cf09420cfbe4..3513d177e5e8 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1335,9 +1335,9 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
 	}
 
       /* Trap declarations of attributes in encompassing scope.  The
-	 signature for this is that ts.kind is set.  Legitimate
-	 references only set ts.type.  */
-      if (sym->ts.kind != 0
+	 signature for this is that ts.kind is nonzero for no-CLASS
+	 entity.  For a CLASS entity, ts.kind is zero.  */
+      if ((sym->ts.kind != 0 || sym->ts.type == BT_CLASS)
 	  && !sym->attr.implicit_type
 	  && sym->attr.proc == 0
 	  && gfc_current_ns->parent != NULL
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fdd9aa9d95ae..b9a88f974bf3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2019-08-17  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/78719
+	* gfortran.dg/pr78719_1.f90: New test.
+	* gfortran.dg/pr78719_2.f90: Ditto.
+	* gfortran.dg/pr78719_3.f90: Ditto.
+
 2019-08-17  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/82992
diff --git a/gcc/testsuite/gfortran.dg/pr78719_1.f90 b/gcc/testsuite/gfortran.dg/pr78719_1.f90
new file mode 100644
index 000000000000..f5a99c23eeee
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr78719_1.f90
@@ -0,0 +1,29 @@
+! { dg-do run }
+! PR fortran/78719
+! Code contributed by Gerhard Steinmetz 
+program p
+
+   type t
+      integer :: n
+   end type
+
+   abstract interface
+      subroutine h
+      end
+   end interface
+
+   procedure(h), pointer :: s
+
+   s => f
+   call s
+   s => g
+   call s
+
+   contains
+
+      subroutine f
+      end
+
+      subroutine g
+      end
+end program p
diff --git a/gcc/testsuite/gfortran.dg/pr78719_2.f90 b/gcc/testsuite/gfortran.dg/pr78719_2.f90
new file mode 100644
index 000000000000..59abebedd169
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr78719_2.f90
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! PR fortran/78719
+! Code contributed by Gerhard Steinmetz 
+program p
+
+   type t
+      integer :: n
+   end type
+
+   real :: g
+
+   abstract interface
+      subroutine h
+      end
+   end interface
+
+   procedure(h), pointer :: s
+
+   s => f
+   call s
+   s => g            ! { dg-error "Invalid procedure pointer" }
+   call s
+
+   contains
+
+      subroutine f
+      end
+
+      subroutine g   ! { dg-error "has an explicit interface" }
+      end
+
+end program p        ! { dg-error "Syntax error" }
diff --git a/gcc/testsuite/gfortran.dg/pr78719_3.f90 b/gcc/testsuite/gfortran.dg/pr78719_3.f90
new file mode 100644
index 000000000000..8e7f6ac9781e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr78719_3.f90
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! PR fortran/78719
+! Code contributed by Gerhard Steinmetz 
+program p
+
+   type t
+      integer :: n
+   end type
+
+   class(t) :: g     ! { dg-error "must be dummy, allocatable or pointer" }
+
+   abstract interface
+      subroutine h
+      end
+   end interface
+
+   procedure(h), pointer :: s
+
+   s => f
+   call s
+   s => g            ! { dg-error "Invalid procedure pointer" }
+   call s
+
+   contains
+
+      subroutine f
+      end
+
+      subroutine g   ! { dg-error "has an explicit interface" }
+      end
+
+end program p        ! { dg-error "Syntax error" }