From 99827b5ca0ce4582940da66a23f737b70d0d8c41 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Mon, 10 Apr 2017 22:28:23 +0200 Subject: [PATCH] re PR fortran/80046 ([F03] Explicit interface required: pointer argument) 2017-04-10 Janus Weil PR fortran/80046 * expr.c (gfc_check_pointer_assign): Check if procedure pointer components in a pointer assignment need an explicit interface. 2017-04-10 Janus Weil PR fortran/80046 * gfortran.dg/proc_ptr_comp_48.f90: New test case. From-SVN: r246823 --- gcc/fortran/ChangeLog | 6 +++ gcc/fortran/expr.c | 48 ++++++++++++------- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/proc_ptr_comp_48.f90 | 47 ++++++++++++++++++ 4 files changed, 90 insertions(+), 16 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_48.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e1057d72eb8..7825295745b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2017-04-10 Janus Weil + + PR fortran/80046 + * expr.c (gfc_check_pointer_assign): Check if procedure pointer + components in a pointer assignment need an explicit interface. + 2017-03-18 Nicolas Koenig PR fortran/69498 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 0e5f04d0bdf..c8be9513af5 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3595,25 +3595,41 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return false; } + /* F08:7.2.2.4 (4) */ + if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) + { + if (comp1 && !s1) + { + gfc_error ("Explicit interface required for component %qs at %L: %s", + comp1->name, &lvalue->where, err); + return false; + } + else if (s1->attr.if_source == IFSRC_UNKNOWN) + { + gfc_error ("Explicit interface required for %qs at %L: %s", + s1->name, &lvalue->where, err); + return false; + } + } + if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) + { + if (comp2 && !s2) + { + gfc_error ("Explicit interface required for component %qs at %L: %s", + comp2->name, &rvalue->where, err); + return false; + } + else if (s2->attr.if_source == IFSRC_UNKNOWN) + { + gfc_error ("Explicit interface required for %qs at %L: %s", + s2->name, &rvalue->where, err); + return false; + } + } + if (s1 == s2 || !s1 || !s2) return true; - /* F08:7.2.2.4 (4) */ - if (s1->attr.if_source == IFSRC_UNKNOWN - && gfc_explicit_interface_required (s2, err, sizeof(err))) - { - gfc_error ("Explicit interface required for %qs at %L: %s", - s1->name, &lvalue->where, err); - return false; - } - if (s2->attr.if_source == IFSRC_UNKNOWN - && gfc_explicit_interface_required (s1, err, sizeof(err))) - { - gfc_error ("Explicit interface required for %qs at %L: %s", - s2->name, &rvalue->where, err); - return false; - } - if (!gfc_compare_interfaces (s1, s2, name, 0, 1, err, sizeof(err), NULL, NULL)) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9f940907e45..51fd41e0abb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-04-10 Janus Weil + + PR fortran/80046 + * gfortran.dg/proc_ptr_comp_48.f90: New test case. + 2017-04-10 David Edelsohn * g++.dg/torture/pr79905.C: Add -maltivec option. diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_48.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_48.f90 new file mode 100644 index 00000000000..de73b197ad8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_48.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! PR 80046: [F03] Explicit interface required: pointer argument +! +! Contributed by Joachim Herb + +program p + implicit none + + type :: Node_t + procedure(NodeCloner), nopass, pointer :: cloneProc => NULL() + procedure(), nopass, pointer :: noIfc => NULL() + end type + + interface + subroutine NodeCloner( tgt, src ) + import Node_t + type(Node_t), pointer, intent(out) :: tgt + type(Node_t), intent(in) :: src + end subroutine + end interface + + type(Node_t) :: node + procedure(NodeCloner), pointer :: cloneNode + procedure(), pointer :: noIfc + + cloneNode => node%noIfc ! { dg-error "Explicit interface required" } + node%noIfc => cloneNode ! { dg-error "Explicit interface required" } + + noIfc => node%cloneProc ! { dg-error "Explicit interface required" } + node%cloneProc => noIfc ! { dg-error "Explicit interface required" } + + node%cloneProc => node%noIfc ! { dg-error "Explicit interface required" } + node%noIfc => node%cloneProc ! { dg-error "Explicit interface required" } + + ! the following cases are legal + + node%noIfc => node%noIfc + node%cloneProc => node%cloneProc + + cloneNode => node%cloneProc + node%cloneProc => cloneNode + + noIfc => node%noIfc + node%noIfc => noIfc + +end