From: Steven G. Kargl <kargl@gcc.gnu.org>
Date: Sat, 17 Aug 2019 14:27:07 +0000 (+0000)
Subject: re PR fortran/78719 ([F03] ICE in gfc_get_symbol_decl, at fortran/trans-decl.c:1438)
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=1c3925e32aea0046e01f844f2519c47caa7aa63b;p=gcc.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: r274604
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 130c3df2e46..2de3532f3f0 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/91471
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 436dd102f3b..5f12fe17b02 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1363,9 +1363,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 0a2bbc17473..1ab8b9e0ab0 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/91471
diff --git a/gcc/testsuite/gfortran.dg/pr78719_1.f90 b/gcc/testsuite/gfortran.dg/pr78719_1.f90
new file mode 100644
index 00000000000..f5a99c23eee
--- /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 00000000000..59abebedd16
--- /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 00000000000..8e7f6ac9781
--- /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" }