===================================================================
*************** gfc_find_sym_in_symtree (gfc_symbol *sym
/* See if the arglist to an operator-call contains a derived-type argument
with a matching type-bound operator. If so, return the matching specific
procedure defined as operator-target as well as the base-object to use
! (which is the found derived-type argument with operator). */
static gfc_typebound_proc*
matching_typebound_op (gfc_expr** tb_base,
gfc_actual_arglist* args,
! gfc_intrinsic_op op, const char* uop)
{
gfc_actual_arglist* base;
/* See if the arglist to an operator-call contains a derived-type argument
with a matching type-bound operator. If so, return the matching specific
procedure defined as operator-target as well as the base-object to use
! (which is the found derived-type argument with operator). The generic
! name, if any, is transmitted to the final expression via 'gname'. */
static gfc_typebound_proc*
matching_typebound_op (gfc_expr** tb_base,
gfc_actual_arglist* args,
! gfc_intrinsic_op op, const char* uop,
! const char ** gname)
{
gfc_actual_arglist* base;
*************** matching_typebound_op (gfc_expr** tb_bas
if (matches)
{
*tb_base = base->expr;
+ *gname = g->specific_st->name;
return g->specific;
}
}
*************** matching_typebound_op (gfc_expr** tb_bas
static void
build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
! gfc_expr* base, gfc_typebound_proc* target)
{
e->expr_type = EXPR_COMPCALL;
e->value.compcall.tbp = target;
! e->value.compcall.name = "operator"; /* Should not matter. */
e->value.compcall.actual = actual;
e->value.compcall.base_object = base;
e->value.compcall.ignore_pass = 1;
static void
build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
! gfc_expr* base, gfc_typebound_proc* target,
! const char *gname)
{
e->expr_type = EXPR_COMPCALL;
e->value.compcall.tbp = target;
! e->value.compcall.name = gname ? gname : "$op";
e->value.compcall.actual = actual;
e->value.compcall.base_object = base;
e->value.compcall.ignore_pass = 1;
*************** gfc_extend_expr (gfc_expr *e, bool *real
gfc_namespace *ns;
gfc_user_op *uop;
gfc_intrinsic_op i;
+ const char *gname;
sym = NULL;
*************** gfc_extend_expr (gfc_expr *e, bool *real
actual->expr = e->value.op.op1;
*real_error = false;
+ gname = NULL;
if (e->value.op.op2 != NULL)
{
*************** gfc_extend_expr (gfc_expr *e, bool *real
/* See if we find a matching type-bound operator. */
if (i == INTRINSIC_USER)
tbo = matching_typebound_op (&tb_base, actual,
! i, e->value.op.uop->name);
else
switch (i)
{
/* See if we find a matching type-bound operator. */
if (i == INTRINSIC_USER)
tbo = matching_typebound_op (&tb_base, actual,
! i, e->value.op.uop->name, &gname);
else
switch (i)
{
*************** gfc_extend_expr (gfc_expr *e, bool *real
case INTRINSIC_##comp: \
case INTRINSIC_##comp##_OS: \
tbo = matching_typebound_op (&tb_base, actual, \
! INTRINSIC_##comp, NULL); \
if (!tbo) \
tbo = matching_typebound_op (&tb_base, actual, \
! INTRINSIC_##comp##_OS, NULL); \
break;
CHECK_OS_COMPARISON(EQ)
CHECK_OS_COMPARISON(NE)
case INTRINSIC_##comp: \
case INTRINSIC_##comp##_OS: \
tbo = matching_typebound_op (&tb_base, actual, \
! INTRINSIC_##comp, NULL, &gname); \
if (!tbo) \
tbo = matching_typebound_op (&tb_base, actual, \
! INTRINSIC_##comp##_OS, NULL, &gname); \
break;
CHECK_OS_COMPARISON(EQ)
CHECK_OS_COMPARISON(NE)
*************** gfc_extend_expr (gfc_expr *e, bool *real
#undef CHECK_OS_COMPARISON
default:
! tbo = matching_typebound_op (&tb_base, actual, i, NULL);
break;
}
#undef CHECK_OS_COMPARISON
default:
! tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
break;
}
*************** gfc_extend_expr (gfc_expr *e, bool *real
gfc_try result;
gcc_assert (tb_base);
! build_compcall_for_operator (e, actual, tb_base, tbo);
result = gfc_resolve_expr (e);
if (result == FAILURE)
gfc_try result;
gcc_assert (tb_base);
! build_compcall_for_operator (e, actual, tb_base, tbo, gname);
result = gfc_resolve_expr (e);
if (result == FAILURE)
*************** gfc_extend_assign (gfc_code *c, gfc_name
gfc_actual_arglist *actual;
gfc_expr *lhs, *rhs;
gfc_symbol *sym;
+ const char *gname;
+
+ gname = NULL;
lhs = c->expr1;
rhs = c->expr2;
*************** gfc_extend_assign (gfc_code *c, gfc_name
/* See if we find a matching type-bound assignment. */
tbo = matching_typebound_op (&tb_base, actual,
! INTRINSIC_ASSIGN, NULL);
/* If there is one, replace the expression with a call to it and
succeed. */
/* See if we find a matching type-bound assignment. */
tbo = matching_typebound_op (&tb_base, actual,
! INTRINSIC_ASSIGN, NULL, &gname);
/* If there is one, replace the expression with a call to it and
succeed. */
*************** gfc_extend_assign (gfc_code *c, gfc_name
{
gcc_assert (tb_base);
c->expr1 = gfc_get_expr ();
! build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
c->expr1->value.compcall.assign = 1;
c->expr2 = NULL;
c->op = EXEC_COMPCALL;
{
gcc_assert (tb_base);
c->expr1 = gfc_get_expr ();
! build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
c->expr1->value.compcall.assign = 1;
c->expr2 = NULL;
c->op = EXEC_COMPCALL;
===================================================================
*************** resolve_typebound_function (gfc_expr* e)
gfc_symtree *st;
const char *name;
gfc_typespec ts;
+ gfc_expr *expr;
st = e->symtree;
+
+ /* Deal with typebound operators for CLASS objects. */
+ expr = e->value.compcall.base_object;
+ if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
+ && e->value.compcall.name)
+ {
+ /* Since the typebound operators are generic, we have to ensure
+ that any delays in resolution are corrected and that the vtab
+ is present. */
+ ts = expr->symtree->n.sym->ts;
+ declared = ts.u.derived;
+ c = gfc_find_component (declared, "$vptr", true, true);
+ if (c->ts.u.derived == NULL)
+ c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+ if (resolve_compcall (e, &name) == FAILURE)
+ return FAILURE;
+
+ /* Use the generic name if it is there. */
+ name = name ? name : e->value.function.esym->name;
+ e->symtree = expr->symtree;
+ expr->symtree->n.sym->ts.u.derived = declared;
+ gfc_add_component_ref (e, "$vptr");
+ gfc_add_component_ref (e, name);
+ e->value.function.esym = NULL;
+ return SUCCESS;
+ }
+
if (st == NULL)
return resolve_compcall (e, NULL);
*************** resolve_typebound_function (gfc_expr* e)
static gfc_try
resolve_typebound_subroutine (gfc_code *code)
{
+ gfc_symbol *declared;
+ gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
const char *name;
gfc_typespec ts;
+ gfc_expr *expr;
st = code->expr1->symtree;
+
+ /* Deal with typebound operators for CLASS objects. */
+ expr = code->expr1->value.compcall.base_object;
+ if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
+ && code->expr1->value.compcall.name)
+ {
+ /* Since the typebound operators are generic, we have to ensure
+ that any delays in resolution are corrected and that the vtab
+ is present. */
+ ts = expr->symtree->n.sym->ts;
+ declared = ts.u.derived;
+ c = gfc_find_component (declared, "$vptr", true, true);
+ if (c->ts.u.derived == NULL)
+ c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+ if (resolve_typebound_call (code, &name) == FAILURE)
+ return FAILURE;
+
+ /* Use the generic name if it is there. */
+ name = name ? name : code->expr1->value.function.esym->name;
+ code->expr1->symtree = expr->symtree;
+ expr->symtree->n.sym->ts.u.derived = declared;
+ gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_component_ref (code->expr1, name);
+ code->expr1->value.function.esym = NULL;
+ return SUCCESS;
+ }
+
if (st == NULL)
return resolve_typebound_call (code, NULL);
===================================================================
***************
+ ! { dg-do run }
+ ! Test the fix for PR42385, in which CLASS defined operators
+ ! compiled but were not correctly dynamically dispatched.
+ !
+ ! Contributed by Janus Weil <janus@gcc.gnu.org>
+ !
+ module foo_module
+ implicit none
+ private
+ public :: foo
+
+ type :: foo
+ integer :: foo_x
+ contains
+ procedure :: times => times_foo
+ procedure :: assign => assign_foo
+ generic :: operator(*) => times
+ generic :: assignment(=) => assign
+ end type
+
+ contains
+
+ function times_foo(this,factor) result(product)
+ class(foo) ,intent(in) :: this
+ class(foo) ,allocatable :: product
+ integer, intent(in) :: factor
+ allocate (product, source = this)
+ product%foo_x = -product%foo_x * factor
+ end function
+
+ subroutine assign_foo(lhs,rhs)
+ class(foo) ,intent(inout) :: lhs
+ class(foo) ,intent(in) :: rhs
+ lhs%foo_x = -rhs%foo_x
+ end subroutine
+
+ end module
+
+ module bar_module
+ use foo_module ,only : foo
+ implicit none
+ private
+ public :: bar
+
+ type ,extends(foo) :: bar
+ integer :: bar_x
+ contains
+ procedure :: times => times_bar
+ procedure :: assign => assign_bar
+ end type
+
+ contains
+ subroutine assign_bar(lhs,rhs)
+ class(bar) ,intent(inout) :: lhs
+ class(foo) ,intent(in) :: rhs
+ select type(rhs)
+ type is (bar)
+ lhs%bar_x = rhs%bar_x
+ lhs%foo_x = -rhs%foo_x
+ end select
+ end subroutine
+ function times_bar(this,factor) result(product)
+ class(bar) ,intent(in) :: this
+ integer, intent(in) :: factor
+ class(foo), allocatable :: product
+ select type(this)
+ type is (bar)
+ allocate(product,source=this)
+ select type(product)
+ type is(bar)
+ product%bar_x = 2*this%bar_x*factor
+ end select
+ end select
+ end function
+ end module
+
+ program main
+ use foo_module ,only : foo
+ use bar_module ,only : bar
+ implicit none
+ type(foo) :: unitf
+ type(bar) :: unitb
+
+ ! foo's assign negates, whilst its '*' negates and mutliplies.
+ unitf%foo_x = 1
+ call rescale(unitf, 42)
+ if (unitf%foo_x .ne. 42) call abort
+
+ ! bar's assign negates foo_x, whilst its '*' copies foo_x
+ ! and does a multiply by twice factor.
+ unitb%foo_x = 1
+ unitb%bar_x = 2
+ call rescale(unitb, 3)
+ if (unitb%bar_x .ne. 12) call abort
+ if (unitb%foo_x .ne. -1) call abort
+ contains
+ subroutine rescale(this,scale)
+ class(foo) ,intent(inout) :: this
+ integer, intent(in) :: scale
+ this = this*scale
+ end subroutine
+ end program