diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 27 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90 | 29 |
4 files changed, 58 insertions, 9 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 535a5c1..d3c1699 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2016-11-08 Janus Weil <janus@gcc.gnu.org> + + PR fortran/77596 + * expr.c (gfc_check_pointer_assign): Add special check for procedure- + pointer component with absent interface. + 2016-11-07 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/78226 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index ba79190..f059c3c 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 f3893ea..721b8f2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-11-08 Janus Weil <janus@gcc.gnu.org> + + PR fortran/77596 + * gfortran.dg/proc_ptr_comp_46.f90: New test. + 2016-11-08 Bin Cheng <bin.cheng@arm.com> * 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 0000000..c01b822 --- /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 <t.kondic@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 |