From 5c0ba546b828cd8f59f250830abaf4fa9f0d881b Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sun, 11 Jan 2015 18:31:22 +0100 Subject: [PATCH] re PR fortran/64508 ([F03] interface check missing for procedure pointer component as actual argument) 2015-01-11 Janus Weil PR fortran/64508 * interface.c (compare_parameter): Interface check for procedure-pointer component as actual argument. 2015-01-11 Janus Weil PR fortran/64508 * gfortran.dg/proc_ptr_comp_41.f90: New. From-SVN: r219431 --- gcc/fortran/ChangeLog | 6 ++++ gcc/fortran/interface.c | 16 ++++++++- gcc/testsuite/ChangeLog | 5 +++ .../gfortran.dg/proc_ptr_comp_41.f90 | 34 +++++++++++++++++++ 4 files changed, 60 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_41.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c21b46ee996..b525ff40ba8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2015-01-11 Janus Weil + + PR fortran/64508 + * interface.c (compare_parameter): Interface check for + procedure-pointer component as actual argument. + 2015-01-10 Thomas Schwinge * gfortran.texi: Update for libgomp being renamed from "GNU OpenMP diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index a1ecdba9737..ca9751fa096 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1922,6 +1922,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { 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 *actual, 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 *actual, 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)) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 84d2423b947..a7c24ce0caa 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-01-11 Janus Weil + + PR fortran/64508 + * gfortran.dg/proc_ptr_comp_41.f90: New. + 2015-01-11 Segher Boessenkool * gcc.target/powerpc/recip-test.h (_ARCH_PPC64): Use __LP64__ instead. diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_41.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_41.f90 new file mode 100644 index 00000000000..e282fc1832d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_41.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR 64508: [F03] interface check missing for procedure pointer component as actual argument +! +! Contributed by Janus Weil + + 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 -- 2.30.2