diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 7b86a338bc1..bf151dae743 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -1789,6 +1789,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) @@ -2425,12 +2433,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..b3f1d7741f3 --- /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 +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