Hi all, here is a simple patch for the accepts-invalid problem of PR77596. Regtests cleanly on x86_64-linux-gnu. Ok for trunk?
Cheers, Janus 2016-11-08 Janus Weil <ja...@gcc.gnu.org> PR fortran/77596 * expr.c (gfc_check_pointer_assign): Add special check for procedure- pointer component with absent interface. 2016-11-08 Janus Weil <ja...@gcc.gnu.org> PR fortran/77596 * gfortran.dg/proc_ptr_comp_46.f90: New test.
Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (Revision 241956) +++ gcc/fortran/expr.c (Arbeitskopie) @@ -3445,7 +3445,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex { char err[200]; gfc_symbol *s1,*s2; - gfc_component *comp; + gfc_component *comp1, *comp2; const char *name; attr = gfc_expr_attr (rvalue); @@ -3549,9 +3549,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex } } - comp = gfc_get_proc_ptr_comp (lvalue); - if (comp) - s1 = comp->ts.interface; + comp1 = gfc_get_proc_ptr_comp (lvalue); + if (comp1) + s1 = comp1->ts.interface; else { s1 = lvalue->symtree->n.sym; @@ -3559,18 +3559,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex s1 = s1->ts.interface; } - comp = gfc_get_proc_ptr_comp (rvalue); - if (comp) + comp2 = gfc_get_proc_ptr_comp (rvalue); + if (comp2) { if (rvalue->expr_type == EXPR_FUNCTION) { - s2 = comp->ts.interface->result; + s2 = comp2->ts.interface->result; name = s2->name; } else { - s2 = comp->ts.interface; - name = comp->name; + s2 = comp2->ts.interface; + name = comp2->name; } } else if (rvalue->expr_type == EXPR_FUNCTION) @@ -3591,6 +3591,15 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex if (s2 && s2->attr.proc_pointer && s2->ts.interface) s2 = s2->ts.interface; + /* Special check for the case of absent interface on the lvalue. + * All other interface checks are done below. */ + if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) + { + gfc_error ("Interface mismatch in procedure pointer assignment " + "at %L: '%s' is not a subroutine", &rvalue->where, name); + return false; + } + if (s1 == s2 || !s1 || !s2) return true;
! { dg-do compile } ! ! PR 77596: [F03] procedure pointer component with implicit interface can point to a function ! ! Contributed by toK <t.kon...@leeds.ac.uk> program xxx implicit none type tf procedure(), nopass, pointer :: fp end type tf call ass() contains integer function ff(x) integer, intent(in) :: x ff = x + 1 end function ff subroutine ass() type(tf) :: p p%fp=>ff ! { dg-error "is not a subroutine" } call p%fp(3) end subroutine ass end