===================================================================
*************** resolve_typebound_call (gfc_code* c, con
/* Check that's really a SUBROUTINE. */
if (!c->expr1->value.compcall.tbp->subroutine)
{
! gfc_error ("%qs at %L should be a SUBROUTINE",
! c->expr1->value.compcall.name, &c->loc);
! return false;
}
if (!check_typebound_baseobject (c->expr1))
/* Check that's really a SUBROUTINE. */
if (!c->expr1->value.compcall.tbp->subroutine)
{
! if (!c->expr1->value.compcall.tbp->is_generic
! && c->expr1->value.compcall.tbp->u.specific
! && c->expr1->value.compcall.tbp->u.specific->n.sym
! && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
! c->expr1->value.compcall.tbp->subroutine = 1;
! else
! {
! gfc_error ("%qs at %L should be a SUBROUTINE",
! c->expr1->value.compcall.name, &c->loc);
! return false;
! }
}
if (!check_typebound_baseobject (c->expr1))
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86863, where the Type Bound Procedures were
+ ! not flagged as subroutines thereby causing an error at the call
+ ! statements.
+ !
+ ! Contributed by Damian Rouson <damian@sourceryinstitute.org>
+ !
+ module foo
+ implicit none
+ integer :: flag = 0
+ type bar
+ contains
+ procedure, nopass :: foobar
+ procedure, nopass :: barfoo
+ end type
+ contains
+ subroutine foobar
+ flag = 1
+ end subroutine
+ subroutine barfoo
+ flag = 0
+ end subroutine
+ end module
+
+ module foobartoo
+ implicit none
+ interface
+ module subroutine set(object)
+ use foo
+ implicit none
+ type(bar) object
+ end subroutine
+ module subroutine unset(object)
+ use foo
+ implicit none
+ type(bar) object
+ end subroutine
+ end interface
+ contains
+ module procedure unset
+ use foo, only : bar
+ call object%barfoo
+ end procedure
+ end module
+
+ submodule(foobartoo) subfoobar
+ contains
+ module procedure set
+ use foo, only : bar
+ call object%foobar
+ end procedure
+ end submodule
+
+ use foo
+ use foobartoo
+ type(bar) :: obj
+ call set(obj)
+ if (flag .ne. 1) stop 1
+ call unset(obj)
+ if (flag .ne. 0) stop 2
+ end