From patchwork Fri Dec 30 19:27:04 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 133693 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 223BBB6FA6 for ; Sat, 31 Dec 2011 06:27:43 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1325878064; h=Comment: DomainKey-Signature:Received:Received:Received:Received: MIME-Version:Received:Received:Date:Message-ID:Subject:From:To: Cc:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=anFIInC MBlwAxcOi4DyF71nmNyM=; b=qhlhFA+SrkJDcB94sqVBeIXX5ql9nUHTdSuYD67 JPI0Dz6Xoes8RNYtslPTchq9VGiz/x/JSIIjOtDHZeyua9GaoTP70sD1gV0H5Ret g9yaO3u3DKMyOs4yXxePlxMMrDuevCLURKRDFqlsg4VR1VBpUga+xuGhns69w127 RCyU= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:MIME-Version:Received:Received:Date:Message-ID:Subject:From:To:Cc:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=q4RP/WdmZirGsbl4RLjhAXas0sGZa4+o1T0Xbd/ivfkuP2IatY0aWjAYBNDXFC bLwpmIY8HUfRRuRU9h89SiTwnCZFHGj5ursZx1O3LKaDIGt82HBr+WBFWMipxb3C oOzu8ha2CpGabgmUe9XlYoWtHq2uw9D/qgXfrZjWkTdNM=; Received: (qmail 22036 invoked by alias); 30 Dec 2011 19:27:29 -0000 Received: (qmail 22014 invoked by uid 22791); 30 Dec 2011 19:27:23 -0000 X-SWARE-Spam-Status: No, hits=-0.9 required=5.0 tests=AWL, BAYES_50, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, TW_TM, TW_VP, T_FILL_THIS_FORM_SHORT X-Spam-Check-By: sourceware.org Received: from mail-ee0-f47.google.com (HELO mail-ee0-f47.google.com) (74.125.83.47) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 30 Dec 2011 19:27:06 +0000 Received: by eeit10 with SMTP id t10so9706246eei.20 for ; Fri, 30 Dec 2011 11:27:04 -0800 (PST) MIME-Version: 1.0 Received: by 10.14.11.164 with SMTP id 36mr15790972eex.107.1325273224782; Fri, 30 Dec 2011 11:27:04 -0800 (PST) Received: by 10.14.100.5 with HTTP; Fri, 30 Dec 2011 11:27:04 -0800 (PST) Date: Fri, 30 Dec 2011 20:27:04 +0100 Message-ID: Subject: [Patch, fortran] PR46328 - [OOP] type-bound operator call with non-trivial polymorphic operand From: Paul Richard Thomas To: Tobias Burnus , fortran@gcc.gnu.org, gcc-patches Cc: Arjen Markus Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Dear All, This patch represents a rather complete fix for this PR. In fact, I suspect that it also fixes other PRs but I have been out of internet range for a week and have not been able to check. The processing of typebound operators has been made more straight forward here by the addition of a new field in gfc_expression to hold the base object expression. I tried to avoid this but ran into a mess of other problems in resolution, when I tried to do otherwise. It turns out that this works well,however, so another pointer in the gfc_expr seems a small price to pay. A big plus, which has not been tested in the testcase submitted but will be in future patches, is that the handling of the typebound operators and procedures now admits the base object changing dynamic type in the course of the call. Another essential part of the patch involves the triming of extraneous trailing references in the base object expressions, such as _vptrs and so on. Finally, the patch includes two extra bits: one brings back the nullification of newly assigned class array _data. (Tobias, is there a PR for this?); The other is to fix pointer assignment of class valued procedure pointers. This permits a fully elaborated version of Arjen Markus's pde solver to compile and run correctly - of which a bit more in one of two following emails to the fortran list. Bootstrapped and regtested on i686/Ubuntu 11.1 - OK for trunk? A Happy New Year to one and all! Paul 2011-12-30 Paul Thomas * trans-array.c (gfc_array_allocate): Null allocated memory of newly allocted class arrays. PR fortran/46328 * interface.c(build_compcall_for_operator): Add a type to the expression. * trans-expr.c (conv_base_obj_fcn_val): New function. (gfc_conv_procedure_call): Use base_expr to detect non-variable base objects and, ensuring that there is a temporary variable, build up the typebound call using conv_base_obj_fcn_val. (gfc_trans_class_assign): Pick out class procedure pointer assignments and do the assignment with no further prcessing. * gfortran.h : Add 'base_expr' field to gfc_expr. * resolve.c (get_declared_from_expr): Add 'types' argument to switch checking of derived types on or off. (resolve_typebound_generic_call): Set the new argument. (resolve_typebound_function, resolve_typebound_subroutine): Set 'types' argument for get_declared_from_expr appropriately. Identify base expression, if not a variable, in the argument list of class valued calls. Assign it to the 'base_expr' field of the final expression. Strip away all references after the last class reference. 2011-12-30 Paul Thomas PR fortran/46328 * gfortran.dg/typebound_operator_7.f03: New. Index: gcc/fortran/interface.c =================================================================== *** gcc/fortran/interface.c (revision 182566) --- gcc/fortran/interface.c (working copy) *************** *** 3256,3261 **** --- 3256,3269 ---- e->value.compcall.base_object = base; e->value.compcall.ignore_pass = 1; e->value.compcall.assign = 0; + if (e->ts.type == BT_UNKNOWN + && target->function) + { + if (target->is_generic) + e->ts = target->u.generic->specific->u.specific->n.sym->ts; + else + e->ts = target->u.specific->n.sym->ts; + } } *************** *** 3383,3389 **** gcc_assert (tb_base); build_compcall_for_operator (e, actual, tb_base, tbo, gname); - result = gfc_resolve_expr (e); if (result == FAILURE) return MATCH_ERROR; --- 3391,3396 ---- Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 182566) --- gcc/fortran/trans-array.c (working copy) *************** *** 5069,5074 **** --- 5069,5086 ---- gfc_add_expr_to_block (&se->pre, tmp); + if (expr->ts.type == BT_CLASS && expr3) + { + tmp = build_int_cst (unsigned_char_type_node, 0); + /* With class objects, it is best to play safe and null the + memory because we cannot know if dynamic types have allocatable + components or not. */ + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMSET), + 3, pointer, tmp, size); + gfc_add_expr_to_block (&se->pre, tmp); + } + /* Update the array descriptors. */ if (dimension) gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 182566) --- gcc/fortran/trans-expr.c (working copy) *************** *** 302,307 **** --- 302,480 ---- parmse->expr = gfc_build_addr_expr (NULL_TREE, var); } + + static tree + gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj) + { + gfc_actual_arglist *actual; + gfc_expr *ppc; + gfc_code *ppc_code; + tree res; + + actual = gfc_get_actual_arglist (); + actual->expr = gfc_copy_expr (rhs); + actual->next = gfc_get_actual_arglist (); + actual->next->expr = gfc_copy_expr (lhs); + ppc = gfc_copy_expr (obj); + gfc_add_vptr_component (ppc); + gfc_add_component_ref (ppc, "_copy"); + ppc_code = gfc_get_code (); + ppc_code->resolved_sym = ppc->symtree->n.sym; + /* Although '_copy' is set to be elemental in class.c, it is + not staying that way. Find out why, sometime.... */ + ppc_code->resolved_sym->attr.elemental = 1; + ppc_code->ext.actual = actual; + ppc_code->expr1 = ppc; + ppc_code->op = EXEC_CALL; + /* Since '_copy' is elemental, the scalarizer will take care + of arrays in gfc_trans_call. */ + res = gfc_trans_call (ppc_code, false, NULL, NULL, false); + gfc_free_statements (ppc_code); + return res; + } + + /* Special case for initializing a polymorphic dummy with INTENT(OUT). + A MEMCPY is needed to copy the full data from the default initializer + of the dynamic type. */ + + tree + gfc_trans_class_init_assign (gfc_code *code) + { + stmtblock_t block; + tree tmp; + gfc_se dst,src,memsz; + gfc_expr *lhs,*rhs,*sz; + + gfc_start_block (&block); + + lhs = gfc_copy_expr (code->expr1); + gfc_add_data_component (lhs); + + rhs = gfc_copy_expr (code->expr1); + gfc_add_vptr_component (rhs); + + /* Make sure that the component backend_decls have been built, which + will not have happened if the derived types concerned have not + been referenced. */ + gfc_get_derived_type (rhs->ts.u.derived); + gfc_add_def_init_component (rhs); + + if (code->expr1->ts.type == BT_CLASS + && CLASS_DATA (code->expr1)->attr.dimension) + tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); + else + { + sz = gfc_copy_expr (code->expr1); + gfc_add_vptr_component (sz); + gfc_add_size_component (sz); + + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_init_se (&memsz, NULL); + gfc_conv_expr (&dst, lhs); + gfc_conv_expr (&src, rhs); + gfc_conv_expr (&memsz, sz); + gfc_add_block_to_block (&block, &src.pre); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); + } + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); + } + + + /* Translate an assignment to a CLASS object + (pointer or ordinary assignment). */ + + tree + gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) + { + stmtblock_t block; + tree tmp; + gfc_expr *lhs; + gfc_expr *rhs; + gfc_ref *ref; + + gfc_start_block (&block); + + ref = expr1->ref; + while (ref && ref->next) + ref = ref->next; + + /* Class valued proc_pointer assignments do not need any further + preparation. */ + if (ref && ref->type == REF_COMPONENT + && ref->u.c.component->attr.proc_pointer + && expr2->expr_type == EXPR_VARIABLE + && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE + && op == EXEC_POINTER_ASSIGN) + goto assign; + + if (expr2->ts.type != BT_CLASS) + { + /* Insert an additional assignment which sets the '_vptr' field. */ + gfc_symbol *vtab = NULL; + gfc_symtree *st; + + lhs = gfc_copy_expr (expr1); + gfc_add_vptr_component (lhs); + + if (expr2->ts.type == BT_DERIVED) + vtab = gfc_find_derived_vtab (expr2->ts.u.derived); + else if (expr2->expr_type == EXPR_NULL) + vtab = gfc_find_derived_vtab (expr1->ts.u.derived); + gcc_assert (vtab); + + rhs = gfc_get_expr (); + rhs->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); + rhs->symtree = st; + rhs->ts = vtab->ts; + + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } + else if (CLASS_DATA (expr2)->attr.dimension) + { + /* Insert an additional assignment which sets the '_vptr' field. */ + lhs = gfc_copy_expr (expr1); + gfc_add_vptr_component (lhs); + + rhs = gfc_copy_expr (expr2); + gfc_add_vptr_component (rhs); + + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } + + /* Do the actual CLASS assignment. */ + if (expr2->ts.type == BT_CLASS + && !CLASS_DATA (expr2)->attr.dimension) + op = EXEC_ASSIGN; + else + gfc_add_data_component (expr1); + + assign: + + if (op == EXEC_ASSIGN) + tmp = gfc_trans_assignment (expr1, expr2, false, true); + else if (op == EXEC_POINTER_ASSIGN) + tmp = gfc_trans_pointer_assignment (expr1, expr2); + else + gcc_unreachable(); + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); + } + + /* End of prototype trans-class.c */ *************** *** 1976,1981 **** --- 2149,2179 ---- } + /* Convert a typebound function reference from a class object. */ + static void + conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr) + { + gfc_ref *ref; + tree var; + + if (TREE_CODE (base_object) != VAR_DECL) + { + var = gfc_create_var (TREE_TYPE (base_object), NULL); + gfc_add_modify (&se->pre, var, base_object); + } + se->expr = gfc_class_vptr_get (base_object); + se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + ref = expr->ref; + while (ref && ref->next) + ref = ref->next; + gcc_assert (ref && ref->type == REF_COMPONENT); + if (ref->u.c.sym->attr.extension) + conv_parent_component_references (se, ref); + gfc_conv_component_ref (se, ref); + se->expr = build_fold_addr_expr_loc (input_location, se->expr); + } + + static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { *************** *** 3084,3089 **** --- 3282,3288 ---- tree type; tree var; tree len; + tree base_object; VEC(tree,gc) *stringargs; tree result = NULL; gfc_formal_arglist *formal; *************** *** 3156,3161 **** --- 3355,3362 ---- != EXPR_CONSTANT); } + base_object = NULL_TREE; + /* Evaluate the arguments. */ for (arg = args; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) *************** *** 3301,3306 **** --- 3502,3514 ---- { gfc_conv_expr_reference (&parmse, e); + /* Catch base objects that are not variables. */ + if (e->ts.type == BT_CLASS + && e->expr_type != EXPR_VARIABLE + && expr && e == expr->base_expr) + base_object = build_fold_indirect_ref_loc (input_location, + parmse.expr); + /* A class array element needs converting back to be a class object, if the formal argument is a class object. */ if (fsym && fsym->ts.type == BT_CLASS *************** *** 4000,4006 **** arglist = retargs; /* Generate the actual call. */ ! conv_function_val (se, sym, expr); /* If there are alternate return labels, function type should be integer. Can't modify the type in place though, since it can be shared --- 4208,4217 ---- arglist = retargs; /* Generate the actual call. */ ! if (base_object == NULL_TREE) ! conv_function_val (se, sym, expr); ! else ! conv_base_obj_fcn_val (se, base_object, expr); /* If there are alternate return labels, function type should be integer. Can't modify the type in place though, since it can be shared *************** *** 5294,5300 **** return; } - gfc_conv_expr (se, expr); /* Create a temporary var to hold the value. */ --- 5505,5510 ---- *************** *** 6730,6887 **** { return gfc_trans_assignment (code->expr1, code->expr2, false, true); } - - - static tree - gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj) - { - gfc_actual_arglist *actual; - gfc_expr *ppc; - gfc_code *ppc_code; - tree res; - - actual = gfc_get_actual_arglist (); - actual->expr = gfc_copy_expr (rhs); - actual->next = gfc_get_actual_arglist (); - actual->next->expr = gfc_copy_expr (lhs); - ppc = gfc_copy_expr (obj); - gfc_add_vptr_component (ppc); - gfc_add_component_ref (ppc, "_copy"); - ppc_code = gfc_get_code (); - ppc_code->resolved_sym = ppc->symtree->n.sym; - /* Although '_copy' is set to be elemental in class.c, it is - not staying that way. Find out why, sometime.... */ - ppc_code->resolved_sym->attr.elemental = 1; - ppc_code->ext.actual = actual; - ppc_code->expr1 = ppc; - ppc_code->op = EXEC_CALL; - /* Since '_copy' is elemental, the scalarizer will take care - of arrays in gfc_trans_call. */ - res = gfc_trans_call (ppc_code, false, NULL, NULL, false); - gfc_free_statements (ppc_code); - return res; - } - - /* Special case for initializing a polymorphic dummy with INTENT(OUT). - A MEMCPY is needed to copy the full data from the default initializer - of the dynamic type. */ - - tree - gfc_trans_class_init_assign (gfc_code *code) - { - stmtblock_t block; - tree tmp; - gfc_se dst,src,memsz; - gfc_expr *lhs,*rhs,*sz; - - gfc_start_block (&block); - - lhs = gfc_copy_expr (code->expr1); - gfc_add_data_component (lhs); - - rhs = gfc_copy_expr (code->expr1); - gfc_add_vptr_component (rhs); - - /* Make sure that the component backend_decls have been built, which - will not have happened if the derived types concerned have not - been referenced. */ - gfc_get_derived_type (rhs->ts.u.derived); - gfc_add_def_init_component (rhs); - - if (code->expr1->ts.type == BT_CLASS - && CLASS_DATA (code->expr1)->attr.dimension) - tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); - else - { - sz = gfc_copy_expr (code->expr1); - gfc_add_vptr_component (sz); - gfc_add_size_component (sz); - - gfc_init_se (&dst, NULL); - gfc_init_se (&src, NULL); - gfc_init_se (&memsz, NULL); - gfc_conv_expr (&dst, lhs); - gfc_conv_expr (&src, rhs); - gfc_conv_expr (&memsz, sz); - gfc_add_block_to_block (&block, &src.pre); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); - } - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); - } - - - /* Translate an assignment to a CLASS object - (pointer or ordinary assignment). */ - - tree - gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) - { - stmtblock_t block; - tree tmp; - gfc_expr *lhs; - gfc_expr *rhs; - - gfc_start_block (&block); - - if (expr2->ts.type != BT_CLASS) - { - /* Insert an additional assignment which sets the '_vptr' field. */ - gfc_symbol *vtab = NULL; - gfc_symtree *st; - - lhs = gfc_copy_expr (expr1); - gfc_add_vptr_component (lhs); - - if (expr2->ts.type == BT_DERIVED) - vtab = gfc_find_derived_vtab (expr2->ts.u.derived); - else if (expr2->expr_type == EXPR_NULL) - vtab = gfc_find_derived_vtab (expr1->ts.u.derived); - gcc_assert (vtab); - - rhs = gfc_get_expr (); - rhs->expr_type = EXPR_VARIABLE; - gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); - rhs->symtree = st; - rhs->ts = vtab->ts; - - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - - gfc_free_expr (lhs); - gfc_free_expr (rhs); - } - else if (CLASS_DATA (expr2)->attr.dimension) - { - /* Insert an additional assignment which sets the '_vptr' field. */ - lhs = gfc_copy_expr (expr1); - gfc_add_vptr_component (lhs); - - rhs = gfc_copy_expr (expr2); - gfc_add_vptr_component (rhs); - - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - - gfc_free_expr (lhs); - gfc_free_expr (rhs); - } - - /* Do the actual CLASS assignment. */ - if (expr2->ts.type == BT_CLASS && !CLASS_DATA (expr2)->attr.dimension) - op = EXEC_ASSIGN; - else - gfc_add_data_component (expr1); - - if (op == EXEC_ASSIGN) - tmp = gfc_trans_assignment (expr1, expr2, false, true); - else if (op == EXEC_POINTER_ASSIGN) - tmp = gfc_trans_pointer_assignment (expr1, expr2); - else - gcc_unreachable(); - - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); - } --- 6940,6942 ---- Index: gcc/fortran/gfortran.h =================================================================== *** gcc/fortran/gfortran.h (revision 182566) --- gcc/fortran/gfortran.h (working copy) *************** *** 1697,1702 **** --- 1697,1706 ---- locus where; + /* Used to store the base expression in component calls, when the expression + is not a variable. */ + gfc_expr *base_expr; + /* is_boz is true if the integer is regarded as BOZ bitpatten and is_snan denotes a signalling not-a-number. */ unsigned int is_boz : 1, is_snan : 1; Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 182566) --- gcc/fortran/resolve.c (working copy) *************** *** 5623,5629 **** reference list. */ static gfc_symbol* get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, ! gfc_expr *e) { gfc_symbol *declared; gfc_ref *ref; --- 5623,5629 ---- reference list. */ static gfc_symbol* get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, ! gfc_expr *e, bool types) { gfc_symbol *declared; gfc_ref *ref; *************** *** 5639,5646 **** if (ref->type != REF_COMPONENT) continue; ! if (ref->u.c.component->ts.type == BT_CLASS ! || ref->u.c.component->ts.type == BT_DERIVED) { declared = ref->u.c.component->ts.u.derived; if (class_ref) --- 5639,5647 ---- if (ref->type != REF_COMPONENT) continue; ! if ((ref->u.c.component->ts.type == BT_CLASS ! || (types && ref->u.c.component->ts.type == BT_DERIVED)) ! && ref->u.c.component->attr.flavor != FL_PROCEDURE) { declared = ref->u.c.component->ts.u.derived; if (class_ref) *************** *** 5735,5741 **** success: /* Make sure that we have the right specific instance for the name. */ ! derived = get_declared_from_expr (NULL, NULL, e); st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); if (st) --- 5736,5742 ---- success: /* Make sure that we have the right specific instance for the name. */ ! derived = get_declared_from_expr (NULL, NULL, e, true); st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); if (st) *************** *** 5872,5877 **** --- 5873,5893 ---- overridable = !e->value.compcall.tbp->non_overridable; if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name) { + /* If the base_object is not a variable, the corresponding actual + argument expression must be stored in e->base_expression so + that the corresponding tree temporary can be used as the base + object in gfc_conv_procedure_call. */ + if (expr->expr_type != EXPR_VARIABLE) + { + gfc_actual_arglist *args; + + for (args= e->value.function.actual; args; args = args->next) + { + if (expr == args->expr) + expr = args->expr; + } + } + /* Since the typebound operators are generic, we have to ensure that any delays in resolution are corrected and that the vtab is present. */ *************** *** 5888,5896 **** --- 5904,5930 ---- name = name ? name : e->value.function.esym->name; e->symtree = expr->symtree; e->ref = gfc_copy_ref (expr->ref); + + /* Trim away the extraneous references that emerge from nested + use of interface.c (extend_expr). */ + get_declared_from_expr (&class_ref, NULL, e, false); + if (class_ref && class_ref->next) + { + gfc_free_ref_list (class_ref->next); + class_ref->next = NULL; + } + else if (e->ref && !class_ref) + { + gfc_free_ref_list (e->ref); + e->ref = NULL; + } + + /* Now use the procedure in the vtable. */ gfc_add_vptr_component (e); gfc_add_component_ref (e, name); e->value.function.esym = NULL; + if (expr->expr_type != EXPR_VARIABLE) + e->base_expr = expr; return SUCCESS; } *************** *** 5901,5907 **** return FAILURE; /* Get the CLASS declared type. */ ! declared = get_declared_from_expr (&class_ref, &new_ref, e); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) --- 5935,5941 ---- return FAILURE; /* Get the CLASS declared type. */ ! declared = get_declared_from_expr (&class_ref, &new_ref, e, true); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) *************** *** 5967,5972 **** --- 6001,6022 ---- overridable = !code->expr1->value.compcall.tbp->non_overridable; if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name) { + /* If the base_object is not a variable, the corresponding actual + argument expression must be stored in e->base_expression so + that the corresponding tree temporary can be used as the base + object in gfc_conv_procedure_call. */ + if (expr->expr_type != EXPR_VARIABLE) + { + gfc_actual_arglist *args; + + args= code->expr1->value.function.actual; + for (; args; args = args->next) + { + if (expr == args->expr) + expr = args->expr; + } + } + /* Since the typebound operators are generic, we have to ensure that any delays in resolution are corrected and that the vtab is present. */ *************** *** 5982,5990 **** --- 6032,6058 ---- name = name ? name : code->expr1->value.function.esym->name; code->expr1->symtree = expr->symtree; code->expr1->ref = gfc_copy_ref (expr->ref); + + /* Trim away the extraneous references that emerge from nested + use of interface.c (extend_expr). */ + get_declared_from_expr (&class_ref, NULL, code->expr1, false); + if (class_ref && class_ref->next) + { + gfc_free_ref_list (class_ref->next); + class_ref->next = NULL; + } + else if (code->expr1->ref && !class_ref) + { + gfc_free_ref_list (code->expr1->ref); + code->expr1->ref = NULL; + } + + /* Now use the procedure in the vtable. */ gfc_add_vptr_component (code->expr1); gfc_add_component_ref (code->expr1, name); code->expr1->value.function.esym = NULL; + if (expr->expr_type != EXPR_VARIABLE) + code->expr1->base_expr = expr; return SUCCESS; } *************** *** 5995,6001 **** return FAILURE; /* Get the CLASS declared type. */ ! get_declared_from_expr (&class_ref, &new_ref, code->expr1); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) --- 6063,6069 ---- return FAILURE; /* Get the CLASS declared type. */ ! get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) Index: gcc/testsuite/gfortran.dg/typebound_operator_7.f03 =================================================================== *** gcc/testsuite/gfortran.dg/typebound_operator_7.f03 (revision 0) --- gcc/testsuite/gfortran.dg/typebound_operator_7.f03 (revision 0) *************** *** 0 **** --- 1,103 ---- + ! { dg-do run } + ! PR46328 - complex expressions involving typebound operators of class objects. + ! + module field_module + implicit none + type ,abstract :: field + contains + procedure(field_op_real) ,deferred :: multiply_real + procedure(field_plus_field) ,deferred :: plus + procedure(assign_field) ,deferred :: assn + generic :: operator(*) => multiply_real + generic :: operator(+) => plus + generic :: ASSIGNMENT(=) => assn + end type + abstract interface + function field_plus_field(lhs,rhs) + import :: field + class(field) ,intent(in) :: lhs + class(field) ,intent(in) :: rhs + class(field) ,allocatable :: field_plus_field + end function + end interface + abstract interface + function field_op_real(lhs,rhs) + import :: field + class(field) ,intent(in) :: lhs + real ,intent(in) :: rhs + class(field) ,allocatable :: field_op_real + end function + end interface + abstract interface + subroutine assign_field(lhs,rhs) + import :: field + class(field) ,intent(OUT) :: lhs + class(field) ,intent(IN) :: rhs + end subroutine + end interface + end module + + module i_field_module + use field_module + implicit none + type, extends (field) :: i_field + integer :: i + contains + procedure :: multiply_real => i_multiply_real + procedure :: plus => i_plus_i + procedure :: assn => i_assn + end type + contains + function i_plus_i(lhs,rhs) + class(i_field) ,intent(in) :: lhs + class(field) ,intent(in) :: rhs + class(field) ,allocatable :: i_plus_i + integer :: m = 0 + select type (lhs) + type is (i_field); m = lhs%i + end select + select type (rhs) + type is (i_field); m = rhs%i + m + end select + allocate (i_plus_i, source = i_field (m)) + end function + function i_multiply_real(lhs,rhs) + class(i_field) ,intent(in) :: lhs + real ,intent(in) :: rhs + class(field) ,allocatable :: i_multiply_real + integer :: m = 0 + select type (lhs) + type is (i_field); m = lhs%i * int (rhs) + end select + allocate (i_multiply_real, source = i_field (m)) + end function + subroutine i_assn(lhs,rhs) + class(i_field) ,intent(OUT) :: lhs + class(field) ,intent(IN) :: rhs + select type (lhs) + type is (i_field) + select type (rhs) + type is (i_field) + lhs%i = rhs%i + end select + end select + end subroutine + end module + + 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" } } +