Dear All,
This is a straightforward patch that adds a last ditch attempt to find
a specific typebound procedure when all that has been found for a
derived type base object is 'deferred'. typebound_operator_7.f03 has
been extended to test derived type as well as class base objects.
Bootstrapped and regtested on x86_64/FC9 - OK for trunk?
Paul
2012-01-03 Paul Thomas <[email protected]>
PR fortran/PR48946
* resolve.c (resolve_typebound_static): If the typebound
procedure is 'deferred' have a go at finding the right specific
procedure in the derived type operator space itself.
2012-01-03 Paul Thomas <[email protected]>
PR fortran/PR48946
* gfortran.dg/typebound_operator_7.f03: Add test for derived
type typebound operators as well as class bound operators.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 182853)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_typebound_static (gfc_expr* e, g
*** 5614,5619 ****
--- 5614,5646 ----
e->ref = NULL;
e->value.compcall.actual = NULL;
+ /* If we find a deferred typebound procedure, check for derived types
+ that an over-riding typebound procedure has not been missed. */
+ if (e->value.compcall.tbp->deferred
+ && e->value.compcall.name
+ && !e->value.compcall.tbp->non_overridable
+ && e->value.compcall.base_object
+ && e->value.compcall.base_object->ts.type == BT_DERIVED)
+ {
+ gfc_symtree *st;
+ gfc_symbol *derived;
+
+ /* Use the derived type of the base_object. */
+ derived = e->value.compcall.base_object->ts.u.derived;
+ st = NULL;
+
+ /* Look for the typebound procedure 'name'. */
+ if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
+ st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
+ e->value.compcall.name);
+
+ /* Now find the specific name in the derived type namespace. */
+ if (st && st->n.tb && st->n.tb->u.specific)
+ gfc_find_sym_tree (st->n.tb->u.specific->name,
+ derived->ns, 1, &st);
+ if (st)
+ *target = st;
+ }
return SUCCESS;
}
Index: gcc/testsuite/gfortran.dg/typebound_operator_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/typebound_operator_7.f03 (revision 182853)
--- gcc/testsuite/gfortran.dg/typebound_operator_7.f03 (working copy)
***************
*** 1,5 ****
--- 1,6 ----
! { dg-do run }
! PR46328 - complex expressions involving typebound operators of class objects.
+ ! PR48946 - complex expressions involving typebound operators of derived types.
!
module field_module
implicit none
*************** end module
*** 87,103 ****
program main
use i_field_module
implicit none
! class(i_field) ,allocatable :: u
! allocate (u, source = i_field (99))
!
! u = u*2.
! u = (u*2.0*4.0) + u*4.0
! u = u%multiply_real (2.0)*4.0
! u = i_multiply_real (u, 2.0) * 4.0
!
! select type (u)
! type is (i_field); if (u%i .ne. 152064) call abort
! end select
end program
! { dg-final { cleanup-modules "field_module i_field_module" } }
--- 88,118 ----
program main
use i_field_module
implicit none
! call check_class_tbos
! call check_derived_type_tbos
! contains
! subroutine check_class_tbos
! class(i_field) ,allocatable :: u
! allocate (u, source = i_field (99))
! u = u*2.
! u = (u*2.0*4.0) + u*4.0
! u = u%multiply_real (2.0)*4.0
! u = i_multiply_real (u, 2.0) * 4.0
! select type (u)
! type is (i_field); if (u%i .ne. 152064) call abort
! end select
! deallocate (u)
! end subroutine
! subroutine check_derived_type_tbos
! type(i_field) ,allocatable :: u
! allocate (u, source = i_field (99))
! u = u*2.
! u = (u*2.0*4.0) + u*4.0
! u = u%multiply_real (2.0)*4.0
! u = i_multiply_real (u, 2.0) * 4.0
! if (u%i .ne. 152064) call abort
! deallocate (u)
! end subroutine
end program
! { dg-final { cleanup-modules "field_module i_field_module" } }
