Hi all,
here is a patch which adds an interface check for procedure pointer
components as acual arguments. Such a check is there already for
ordinary procedures and procedure pointers, but missing for PPCs. It
checks the interface of the actual argument versus the interface of
the dummy procedure, according to the usual rules.
Regtested on x86_64-unknown-linux-gnu. Ok for trunk?
Cheers,
Janus
2015-01-06 Janus Weil <ja...@gcc.gnu.org>
PR fortran/64508
* interface.c (compare_parameter): Interface check for
procedure-pointer component as actual argument.
2015-01-06 Janus Weil <ja...@gcc.gnu.org>
PR fortran/64508
* gfortran.dg/proc_ptr_comp_41.f90: New.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (Revision 219261)
+++ gcc/fortran/interface.c (Arbeitskopie)
@@ -1922,6 +1922,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a
{
gfc_ref *ref;
bool rank_check, is_pointer;
+ char err[200];
+ gfc_component *ppc;
/* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
procs c_f_pointer or c_f_procpointer, and we need to accept most
@@ -1942,7 +1944,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a
if (actual->ts.type == BT_PROCEDURE)
{
- char err[200];
gfc_symbol *act_sym = actual->symtree->n.sym;
if (formal->attr.flavor != FL_PROCEDURE)
@@ -1976,6 +1977,19 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a
return 1;
}
+ ppc = gfc_get_proc_ptr_comp (actual);
+ if (ppc)
+ {
+ if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1,
+ err, sizeof(err), NULL, NULL))
+ {
+ if (where)
+ gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
+ formal->name, &actual->where, err);
+ return 0;
+ }
+ }
+
/* F2008, C1241. */
if (formal->attr.pointer && formal->attr.contiguous
&& !gfc_is_simply_contiguous (actual, true))
! { dg-do compile }
!
! PR 64508: [F03] interface check missing for procedure pointer component as actual argument
!
! Contributed by Janus Weil <ja...@gcc.gnu.org>
TYPE :: parent
END TYPE
TYPE, EXTENDS(parent) :: extension
procedure(extension_proc), pointer :: ppc
END TYPE
CLASS(extension), ALLOCATABLE :: x
CALL some_proc(x%ppc) ! { dg-error "Interface mismatch in dummy procedure" }
contains
SUBROUTINE parent_proc(arg)
CLASS(parent), INTENT(IN) :: arg
END SUBROUTINE
SUBROUTINE extension_proc(arg)
CLASS(extension), INTENT(IN) :: arg
END SUBROUTINE
SUBROUTINE some_proc(proc)
PROCEDURE(parent_proc) :: proc
TYPE(Parent) :: a
CALL proc(a)
END SUBROUTINE
end
