diff options
Diffstat (limited to 'gcc/fortran/interface.c')
| -rw-r--r-- | gcc/fortran/interface.c | 31 |
1 files changed, 20 insertions, 11 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 587b09c..201961d 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; |