[gcc r12-10416] Fortran: Add error for subroutine passed to a variable dummy [PR106999]

[Paul Thomas <pault@gcc.gnu.org>]

https://gcc.gnu.org/g:d72e9f90e370538b057690b16c1e65350dbbb75c

commit r12-10416-gd72e9f90e370538b057690b16c1e65350dbbb75c
Author: Paul Thomas <pault@gcc.gnu.org>
Date:   Tue Apr 2 15:53:29 2024 +0100

    Fortran: Add error for subroutine passed to a variable dummy [PR106999]
    
    2024-04-02  Paul Thomas  <pault@gcc.gnu.org>
    
    gcc/fortran
            PR fortran/106999
            * interface.cc (gfc_compare_interfaces): Add error for a
            subroutine proc pointer passed to a variable formal.
            (compare_parameter): If a procedure pointer is being passed to
            a non-procedure formal arg, and there is an an interface, use
            gfc_compare_interfaces to check and provide a more useful error
            message.
    
    gcc/testsuite/
            PR fortran/106999
            * gfortran.dg/pr106999.f90: New test.
    
    (cherry picked from commit a7aa9455a8b9cb080649a7357b7360f2d99bcbf1)

Diff:
---
 gcc/fortran/interface.cc               | 20 +++++++++++++++++++-
 gcc/testsuite/gfortran.dg/pr106999.f90 | 33 +++++++++++++++++++++++++++++++++
 2 files changed, 52 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 874acb914f3..0c4cd385d56 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1746,6 +1746,14 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
       return false;
     }
 
+  if (s2->attr.subroutine && s1->attr.flavor == FL_VARIABLE)
+    {
+      if (errmsg != NULL)
+	snprintf (errmsg, err_len, "subroutine proc pointer '%s' passed "
+		  "to dummy variable '%s'", name2, s1->name);
+      return false;
+    }
+
   /* Do strict checks on all characteristics
      (for dummy procedures and procedure pointer assignments).  */
   if (!generic_flag && strict_flag)
@@ -2381,12 +2389,22 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
     {
       gfc_symbol *act_sym = actual->symtree->n.sym;
 
-      if (formal->attr.flavor != FL_PROCEDURE)
+      if (formal->attr.flavor != FL_PROCEDURE && !act_sym->ts.interface)
 	{
 	  if (where)
 	    gfc_error ("Invalid procedure argument at %L", &actual->where);
 	  return false;
 	}
+      else if (act_sym->ts.interface
+	       && !gfc_compare_interfaces (formal, act_sym->ts.interface,
+					   act_sym->name, 0, 1, err,
+					   sizeof(err),NULL, NULL))
+	{
+	  if (where)
+	    gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
+			   " %s", formal->name, &actual->where, err);
+	  return false;
+	}
 
       if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
 				   sizeof(err), NULL, NULL))
diff --git a/gcc/testsuite/gfortran.dg/pr106999.f90 b/gcc/testsuite/gfortran.dg/pr106999.f90
new file mode 100644
index 00000000000..f05a27006f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr106999.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! Test the fix for PR106999
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+program p
+   type t
+      integer :: i
+      procedure(g), pointer :: f
+   end type
+   class(t), allocatable :: y, z
+   procedure(g), pointer :: ff
+   allocate (z)
+   z%i = 42
+   z%f => g
+   ff => g
+   call r(z%f)
+   call s(z%f) ! { dg-error "Interface mismatch in dummy procedure" }
+   call s(ff)  ! { dg-error "Interface mismatch in dummy procedure" }
+contains
+   subroutine g(x)
+      class(t) :: x
+      x%i = 84
+   end
+   subroutine r(x)
+      procedure(g) :: x
+      print *, "in r"
+      allocate (y)
+      call x(y)
+      print *, y%i
+   end
+   subroutine s(x)
+      class(*) :: x
+   end subroutine
+end