From eabd9d9167ce36fe441dee0d5efbca494b303652 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Tue, 13 Aug 2019 18:35:33 +0000 Subject: [PATCH] re PR fortran/89647 (Host associated procedure unable to be used as binding target) 2019-08-13 Steven G. Kargl PR fortran/89647 resolve.c (resolve_typebound_procedure): Allow host associated procedure to be a binding target. While here, wrap long line. 2019-08-13 Steven G. Kargl PR fortran/89647 * gfortran.dg/pr89647.f90: New test. From-SVN: r274393 --- gcc/fortran/ChangeLog | 6 +++++ gcc/fortran/resolve.c | 24 +++++++++++++++++-- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/pr89647.f90 | 33 +++++++++++++++++++++++++++ 4 files changed, 66 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr89647.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d5e44a77d5d..6a908eb88a0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2019-08-13 Steven G. Kargl + + PR fortran/89647 + resolve.c (resolve_typebound_procedure): Allow host associated + procedure to be a binding target. While here, wrap long line. + 2019-08-13 Steven G. Kargl PR fortran/87993 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d9ad8884271..bd379b696a0 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13583,14 +13583,34 @@ resolve_typebound_procedure (gfc_symtree* stree) } else { + /* If proc has not been resolved at this point, proc->name may + actually be a USE associated entity. See PR fortran/89647. */ + if (!proc->resolved + && proc->attr.function == 0 && proc->attr.subroutine == 0) + { + gfc_symbol *tmp; + gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp); + if (tmp && tmp->attr.use_assoc) + { + proc->module = tmp->module; + proc->attr.proc = tmp->attr.proc; + proc->attr.function = tmp->attr.function; + proc->attr.subroutine = tmp->attr.subroutine; + proc->attr.use_assoc = tmp->attr.use_assoc; + proc->ts = tmp->ts; + proc->result = tmp->result; + } + } + /* Check for F08:C465. */ if ((!proc->attr.subroutine && !proc->attr.function) || (proc->attr.proc != PROC_MODULE && proc->attr.if_source != IFSRC_IFBODY) || proc->attr.abstract) { - gfc_error ("%qs must be a module procedure or an external procedure with" - " an explicit interface at %L", proc->name, &where); + gfc_error ("%qs must be a module procedure or an external " + "procedure with an explicit interface at %L", + proc->name, &where); goto error; } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6f193c7ab33..e7ec05b55bc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-08-13 Steven G. Kargl + + PR fortran/89647 + * gfortran.dg/pr89647.f90: New test. + 2019-08-13 Steven G. Kargl PR fortran/87993 diff --git a/gcc/testsuite/gfortran.dg/pr89647.f90 b/gcc/testsuite/gfortran.dg/pr89647.f90 new file mode 100644 index 00000000000..1d4dc2d0582 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr89647.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Code contributed by Ian Harvey + MODULE m1 + IMPLICIT NONE + PUBLIC :: False + PUBLIC :: True + CONTAINS + FUNCTION False() RESULT(b) + LOGICAL :: b + b = .FALSE. + END FUNCTION False + + FUNCTION True() RESULT(b) + LOGICAL :: b + b = .TRUE. + END FUNCTION True + END MODULE m1 + + MODULE m2 + USE m1 + IMPLICIT NONE + TYPE, ABSTRACT :: t_parent + CONTAINS + PROCEDURE(False), DEFERRED, NOPASS :: Binding + END TYPE t_parent + CONTAINS + SUBROUTINE s + TYPE, EXTENDS(t_parent) :: t_extension + CONTAINS + PROCEDURE, NOPASS :: Binding => True + END TYPE t_extension + END SUBROUTINE s + END MODULE m2 -- 2.30.2