From patchwork Sun Jul 18 18:05:00 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [fortran] PR42385 - [OOP] poylmorphic operators do not work Date: Sun, 18 Jul 2010 08:05:00 -0000 From: Paul Richard Thomas X-Patchwork-Id: 59171 Message-Id: To: fortran@gcc.gnu.org, gcc-patches The attached patch implements defined operators for CLASS objects. Along the way, I correct a buglet that nullified allocatable scalar results, thereby causing the testcase to fail. Boostrapped and regtested on x86_64/FC9 - OK for trunk? Paul 2010-07-18 Paul Thomas PR fortran/42385 * interface.c (matching_typebound_op): Add argument for the return of the generic name for the procedure. (build_compcall_for_operator): Add an argument for the generic name of an operator procedure and supply it to the expression. (gfc_extend_expr, gfc_extend_assign): Use the generic name in calls to the above procedures. * resolve.c (resolve_typebound_function): Catch procedure component calls for CLASS objects, check that the vtable is complete and insert the $vptr and procedure components, to make the call. (resolve_typebound_function): The same. * trans-decl.c (gfc_trans_deferred_vars): Do not deallocate an allocatable scalar if it is a result. 2010-07-18 Paul Thomas PR fortran/42385 * gfortran.dg/class_defined_operator_1.f03 : New test. Index: gcc/fortran/interface.c =================================================================== *** gcc/fortran/interface.c (revision 162285) --- gcc/fortran/interface.c (working copy) *************** gfc_find_sym_in_symtree (gfc_symbol *sym *** 2779,2790 **** /* 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; --- 2779,2792 ---- /* 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 *** 2850,2855 **** --- 2852,2858 ---- if (matches) { *tb_base = base->expr; + *gname = g->specific_st->name; return g->specific; } } *************** matching_typebound_op (gfc_expr** tb_bas *** 2868,2878 **** 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; --- 2871,2882 ---- 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 *** 2898,2903 **** --- 2902,2908 ---- gfc_namespace *ns; gfc_user_op *uop; gfc_intrinsic_op i; + const char *gname; sym = NULL; *************** gfc_extend_expr (gfc_expr *e, bool *real *** 2905,2910 **** --- 2910,2916 ---- 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 *** 2970,2976 **** /* 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) { --- 2976,2982 ---- /* 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 *** 2978,2987 **** 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) --- 2984,2993 ---- 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 *** 2992,2998 **** #undef CHECK_OS_COMPARISON default: ! tbo = matching_typebound_op (&tb_base, actual, i, NULL); break; } --- 2998,3004 ---- #undef CHECK_OS_COMPARISON default: ! tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); break; } *************** gfc_extend_expr (gfc_expr *e, bool *real *** 3003,3009 **** gfc_try result; gcc_assert (tb_base); ! build_compcall_for_operator (e, actual, tb_base, tbo); result = gfc_resolve_expr (e); if (result == FAILURE) --- 3009,3015 ---- 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 *** 3050,3055 **** --- 3056,3064 ---- 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 *** 3085,3091 **** /* 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. */ --- 3094,3100 ---- /* 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 *** 3093,3099 **** { 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; --- 3102,3108 ---- { 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; Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 162285) --- gcc/fortran/resolve.c (working copy) *************** resolve_typebound_function (gfc_expr* e) *** 5480,5487 **** --- 5480,5516 ---- 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) *** 5534,5546 **** --- 5563,5606 ---- 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); Index: gcc/testsuite/gfortran.dg/class_defined_operator_1.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_defined_operator_1.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_defined_operator_1.f03 (revision 0) *************** *** 0 **** --- 1,102 ---- + ! { dg-do run } + ! Test the fix for PR42385, in which CLASS defined operators + ! compiled but were not correctly dynamically dispatched. + ! + ! Contributed by Janus Weil + ! + 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