From eba5aec8e347d75013268de658efa1c7af93123a Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Tue, 8 Nov 2016 17:10:56 +0100 Subject: [PATCH] re PR fortran/77596 ([F03] procedure pointer component with implicit interface can point to a function) 2016-11-08 Janus Weil PR fortran/77596 * expr.c (gfc_check_pointer_assign): Add special check for procedure- pointer component with absent interface. 2016-11-08 Janus Weil PR fortran/77596 * gfortran.dg/proc_ptr_comp_46.f90: New test. From-SVN: r241972 --- gcc/fortran/ChangeLog | 6 ++++ gcc/fortran/expr.c | 27 +++++++++++------ gcc/testsuite/ChangeLog | 5 ++++ .../gfortran.dg/proc_ptr_comp_46.f90 | 29 +++++++++++++++++++ 4 files changed, 58 insertions(+), 9 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 535a5c15c89..d3c16994cca 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2016-11-08 Janus Weil + + PR fortran/77596 + * expr.c (gfc_check_pointer_assign): Add special check for procedure- + pointer component with absent interface. + 2016-11-07 Thomas Koenig PR fortran/78226 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index ba79190daf1..f059c3c1efa 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3445,7 +3445,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { 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_expr *rvalue) } } - 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_expr *rvalue) 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_expr *rvalue) 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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f3893ea852d..721b8f2ea6a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-11-08 Janus Weil + + PR fortran/77596 + * gfortran.dg/proc_ptr_comp_46.f90: New test. + 2016-11-08 Bin Cheng * gcc.dg/vect/pr56541.c: Xfail on !vect_cond_mixed targets. diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90 new file mode 100644 index 00000000000..c01b8221210 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR 77596: [F03] procedure pointer component with implicit interface can point to a function +! +! Contributed by toK + +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