summaryrefslogtreecommitdiff
path: root/gcc/fortran/interface.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/interface.c')
-rw-r--r--gcc/fortran/interface.c31
1 files changed, 20 insertions, 11 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 587b09cdf8c..201961d6355 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2779,12 +2779,14 @@ 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). */
+ (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)
+ gfc_intrinsic_op op, const char* uop,
+ const char ** gname)
{
gfc_actual_arglist* base;
@@ -2850,6 +2852,7 @@ matching_typebound_op (gfc_expr** tb_base,
if (matches)
{
*tb_base = base->expr;
+ *gname = g->specific_st->name;
return g->specific;
}
}
@@ -2868,11 +2871,12 @@ matching_typebound_op (gfc_expr** tb_base,
static void
build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
- gfc_expr* base, gfc_typebound_proc* target)
+ gfc_expr* base, gfc_typebound_proc* target,
+ const char *gname)
{
e->expr_type = EXPR_COMPCALL;
e->value.compcall.tbp = target;
- e->value.compcall.name = "operator"; /* Should not matter. */
+ e->value.compcall.name = gname ? gname : "$op";
e->value.compcall.actual = actual;
e->value.compcall.base_object = base;
e->value.compcall.ignore_pass = 1;
@@ -2898,6 +2902,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
gfc_namespace *ns;
gfc_user_op *uop;
gfc_intrinsic_op i;
+ const char *gname;
sym = NULL;
@@ -2905,6 +2910,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
actual->expr = e->value.op.op1;
*real_error = false;
+ gname = NULL;
if (e->value.op.op2 != NULL)
{
@@ -2970,7 +2976,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
/* 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);
+ i, e->value.op.uop->name, &gname);
else
switch (i)
{
@@ -2978,10 +2984,10 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
case INTRINSIC_##comp: \
case INTRINSIC_##comp##_OS: \
tbo = matching_typebound_op (&tb_base, actual, \
- INTRINSIC_##comp, NULL); \
+ INTRINSIC_##comp, NULL, &gname); \
if (!tbo) \
tbo = matching_typebound_op (&tb_base, actual, \
- INTRINSIC_##comp##_OS, NULL); \
+ INTRINSIC_##comp##_OS, NULL, &gname); \
break;
CHECK_OS_COMPARISON(EQ)
CHECK_OS_COMPARISON(NE)
@@ -2992,7 +2998,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
#undef CHECK_OS_COMPARISON
default:
- tbo = matching_typebound_op (&tb_base, actual, i, NULL);
+ tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
break;
}
@@ -3003,7 +3009,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
gfc_try result;
gcc_assert (tb_base);
- build_compcall_for_operator (e, actual, tb_base, tbo);
+ build_compcall_for_operator (e, actual, tb_base, tbo, gname);
result = gfc_resolve_expr (e);
if (result == FAILURE)
@@ -3050,6 +3056,9 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
gfc_actual_arglist *actual;
gfc_expr *lhs, *rhs;
gfc_symbol *sym;
+ const char *gname;
+
+ gname = NULL;
lhs = c->expr1;
rhs = c->expr2;
@@ -3085,7 +3094,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
/* See if we find a matching type-bound assignment. */
tbo = matching_typebound_op (&tb_base, actual,
- INTRINSIC_ASSIGN, NULL);
+ INTRINSIC_ASSIGN, NULL, &gname);
/* If there is one, replace the expression with a call to it and
succeed. */
@@ -3093,7 +3102,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
{
gcc_assert (tb_base);
c->expr1 = gfc_get_expr ();
- build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
+ build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
c->expr1->value.compcall.assign = 1;
c->expr2 = NULL;
c->op = EXEC_COMPCALL;