Fortran: Fix ICE in check_interface [PR87908]

2025-09-24  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87908
	* interface.cc (check_interface0): If a vtable is found in the
	interface list, check that it is either a subroutine or a
	function. Let resolve.cc do any further checking.

gcc/testsuite/
	PR fortran/87908
	* gfortran.dg/pr87908.f90: New test.

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index ef5a17d0af45f0b324141ee39b0e2833b9e4db0b..41c941726e229f7e1a45a0000607f190163f151f 100644 (file)
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1968,6 +1968,25 @@ check_interface0 (gfc_interface *p, const char *interface_name)
   psave = p;
   for (; p; p = p->next)
     {
+      if (p->sym->attr.vtab)
+       {
+         bool found = false;
+         gfc_component *c = p->sym->ts.u.derived->components;
+         for (; c; c = c->next)
+           {
+             if (c->name[0] == '_')
+               continue;
+             /* This check seems to be as much as can sensibly be done here.
+                If there is more than one proc_pointer components, resolution
+                of the call will select the right one.  */
+             if (c->attr.proc_pointer && c->ts.interface
+                 && (c->attr.subroutine || c->attr.function))
+               found = true;
+           }
+         if (found)
+           continue;
+       }
+
       /* Make sure all symbols in the interface have been defined as
         functions or subroutines.  */
       if (((!p->sym->attr.function && !p->sym->attr.subroutine)

diff --git a/gcc/testsuite/gfortran.dg/pr87908.f90 b/gcc/testsuite/gfortran.dg/pr87908.f90
new file mode 100644 (file)
index 0000000..6fdc109
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr87908.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+!
+! Check the fix for pr87908, which used to fail with error:
+! Procedure ‘__vtab_m_T’ in generic interface '_dtio_formatted_read' at (1) is
+! neither function nor subroutine.
+!
+! Contributed by David Bolvansky  <david.bolvansky@gmail.com>
+!
+module m
+   type t
+      character(34) :: c
+   contains
+      procedure :: g
+      generic :: read(formatted) => g
+   end type
+   integer :: ctr = 0
+contains
+   subroutine s (unit, x)
+      integer, intent(in) :: unit
+      integer, intent(in) :: x(:)
+      interface read(formatted)
+         procedure g
+      end interface
+   end
+   subroutine g (dtv, unit, iotype, v_list, iostat, iomsg)
+      class(t), intent(inout) :: dtv
+      integer, intent(in) :: unit
+      character(*), intent(in) :: iotype
+      integer, intent(in) :: v_list(:)
+      integer, intent(out) :: iostat
+      character(*), intent(inout) :: iomsg
+      read (unit, '(a)', iostat=iostat, iomsg=iomsg) dtv%c
+      ctr = ctr + 1
+   end
+end
+
+  use m
+  type(t) :: x
+  open (10, status = 'scratch')
+  write(10, fmt=*) "Mary had a little lamb            "
+  write(10, fmt=*) "whose fleece was as white as gold "
+  rewind(10)
+  read(10, fmt=*) x
+  if (trim(x%c) /= "Mary had a little lamb") stop 1
+  read(10, fmt=*) x
+  if (trim(x%c) /= "whose fleece was as white as gold") stop 2
+  close(10)
+  if (ctr /= 2) stop 3
+end