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 24db61b369f2b30750f5e503f072ec16859c8417..a98a11244808a5a373cd8e2636f6f6caf5b89100 100644 (file)
--- 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 cf09420cfbe45de5c09c8f7e61be171f6e09d894..3513d177e5e89bdf42ec5d5072a6dd38b0c46cdf 100644 (file)
--- 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 fdd9aa9d95aea3debc90eab24ce33aed93188223..b9a88f974bf386d29690e36c093d9de4851b82b5 100644 (file)
--- 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 (file)
index 0000000..f5a99c2
--- /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 (file)
index 0000000..59abebe
--- /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 (file)
index 0000000..8e7f6ac
--- /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" }