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 130c3df2e46103ae0c0a6707bfa7477f5c9c807b..2de3532f3f0b6b0693afc94cf0f914d2ceeb0189 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/91471

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 436dd102f3bbcc307fa019422137aac3b60b14f8..5f12fe17b02d15822d304fab2d410aaeb436d22d 100644 (file)
--- 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 0a2bbc17473f8aeb5aaef1a0d6d38d322ce73a0a..1ab8b9e0ab035637b5d06efab13b94b8959b1a71 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/91471

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" }