From patchwork Fri Feb 20 21:50:53 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 442140 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 9CDFC140129 for ; Sat, 21 Feb 2015 08:51:20 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:cc:subject:references :in-reply-to:content-type; q=dns; s=default; b=NgxOeTP3fO5ClvR7A M7d74b3VLK3JnYnzlH6qftWSVjCYxZsi+i3/NAaK5cSjqRzJfDx1DXuh0KKg3+IE ak3IgcLayP2TQO+j3uZ6PgXFQ7n3yH1Tm4eUZxfxCOkTnBbySaJ82vquGrAp7hLa E4szZ8a1GPRcEotp5HMdymYMWU= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:cc:subject:references :in-reply-to:content-type; s=default; bh=RtdPQnNjFr2PTcoo3PxO+Wo +67Y=; b=MSzxElbStJWyeSpzc8rhZ0PzWzJjastNkZbmRH9jv57G14QSQ8fjmaz FuMbwg6PyOB7NkaNutOaMK1qS2pYSI4Yr4ooTeExMhMFbyKGjFDi2fcsYUXDTYnR RB7Zjk1ENTCQ2yGxO13XaDMHZ1ScdpDFR1iUyhQbSsx2lSoqfnss= Received: (qmail 24025 invoked by alias); 20 Feb 2015 21:51:06 -0000 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 Received: (qmail 24007 invoked by uid 89); 20 Feb 2015 21:51:06 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.4 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, RP_MATCHES_RCVD, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: smtp22.services.sfr.fr Received: from smtp22.services.sfr.fr (HELO smtp22.services.sfr.fr) (93.17.128.10) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Fri, 20 Feb 2015 21:51:04 +0000 Received: from filter.sfr.fr (localhost [86.72.15.254]) by msfrf2202.sfr.fr (SMTP Server) with ESMTP id 546D67000149; Fri, 20 Feb 2015 22:51:00 +0100 (CET) Authentication-Results: sfrmc.priv.atos.fr; dkim=none (no signature); dkim-adsp=none (no policy) header.from=mikael.morin@sfr.fr Received: from tolstoi.localhost (254.15.72.86.rev.sfr.net [86.72.15.254]) (using TLSv1 with cipher DHE-RSA-AES128-SHA (128/128 bits)) (No client certificate requested) by msfrf2202.sfr.fr (SMTP Server) with ESMTP id 8B801700011A; Fri, 20 Feb 2015 22:50:59 +0100 (CET) X-SFR-UUID: 20150220215059571.8B801700011A@msfrf2202.sfr.fr Message-ID: <54E7AC3D.40401@sfr.fr> Date: Fri, 20 Feb 2015 22:50:53 +0100 From: Mikael Morin User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:31.0) Gecko/20100101 Thunderbird/31.4.0 MIME-Version: 1.0 To: Bernd Edlinger , "gcc-patches@gcc.gnu.org" , "fortran@gcc.gnu.org" CC: Dominique d'Humieres , Tobias Burnus Subject: Re: [PATCH] Fix PR64980 and PR61960 References: In-Reply-To: X-IsSubscribed: yes Le 16/02/2015 21:18, Bernd Edlinger a écrit : > > again, with attachments, > sorry. > > >> >> Hi, >> >> >> this patch fixes PR64980 and PR61960 at the same time. >> >> The unreduced test case for PR64230 is also included, because a previous version >> of this patch caused this test to fail but the complete test suite passed without any >> indication of any problem. >> Hello Bernd, I think the testcases can do without any VIEW_CONVERT_EXPR at all. I'm currently trying to avoid them with the attached patch, which is not free of regressions unfortunately. Give me couple of days to see whether I can push this to the end. Otherwise, your patch will be good enough. Mikael Index: trans-expr.c =================================================================== --- trans-expr.c (révision 220717) +++ trans-expr.c (copie de travail) @@ -496,81 +496,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_exp } -/* Create a new class container, which is required as scalar coarrays - have an array descriptor while normal scalars haven't. Optionally, - NULL pointer checks are added if the argument is OPTIONAL. */ - -static void -class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e, - gfc_typespec class_ts, bool optional) -{ - tree var, ctree, tmp; - stmtblock_t block; - gfc_ref *ref; - gfc_ref *class_ref; - - gfc_init_block (&block); - - class_ref = NULL; - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS) - class_ref = ref; - } - - if (class_ref == NULL - && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) - tmp = e->symtree->n.sym->backend_decl; - else - { - /* Remove everything after the last class reference, convert the - expression and then recover its tailend once more. */ - gfc_se tmpse; - ref = class_ref->next; - class_ref->next = NULL; - gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, e); - class_ref->next = ref; - tmp = tmpse.expr; - } - - var = gfc_typenode_for_spec (&class_ts); - var = gfc_create_var (var, "class"); - - ctree = gfc_class_vptr_get (var); - gfc_add_modify (&block, ctree, - fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp))); - - ctree = gfc_class_data_get (var); - tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp)); - gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp)); - - /* Pass the address of the class object. */ - parmse->expr = gfc_build_addr_expr (NULL_TREE, var); - - if (optional) - { - tree cond = gfc_conv_expr_present (e->symtree->n.sym); - tree tmp2; - - tmp = gfc_finish_block (&block); - - gfc_init_block (&block); - tmp2 = gfc_class_data_get (var); - gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), - null_pointer_node)); - tmp2 = gfc_finish_block (&block); - - tmp = build3_loc (input_location, COND_EXPR, void_type_node, - cond, tmp, tmp2); - gfc_add_expr_to_block (&parmse->pre, tmp); - } - else - gfc_add_block_to_block (&parmse->pre, &block); -} - - /* Takes an intrinsic type expression and returns the address of a temporary class object of the 'declared' type. */ void @@ -686,6 +611,9 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_e } +static void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref); + + /* Takes a scalarized class array expression and returns the address of a temporary scalar class object of the 'declared' type. @@ -706,30 +634,28 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr tree var; tree tmp; tree vptr; + tree orig_expr = parmse->expr; tree cond = NULL_TREE; gfc_ref *ref; - gfc_ref *class_ref; + gfc_ref **class_subref; stmtblock_t block; bool full_array = false; gfc_init_block (&block); - class_ref = NULL; + if (e->symtree + && e->symtree->n.sym->ts.type == BT_CLASS) + class_subref = &e->ref; + else + class_subref = NULL; + for (ref = e->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS) - class_ref = ref; - - if (ref->next == NULL) - break; + class_subref = &ref->next; } - if ((ref == NULL || class_ref == ref) - && (!class_ts.u.derived->components->as - || class_ts.u.derived->components->as->rank != -1)) - return; - /* Test for FULL_ARRAY. */ if (e->rank == 0 && gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension) @@ -765,9 +691,57 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr } else { - if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree)) + if (!class_ts.u.derived->components->as) + { + gfc_symbol *dt_sym; + gfc_symbol *dummy_sym = class_ts.u.derived->components->ts.u.derived; + gfc_ref ref; + + if ((*class_subref) + && (*class_subref)->next) + { + gcc_assert ((*class_subref)->next->type == REF_ARRAY); + dt_sym = e->ts.u.derived->components->ts.u.derived; + } + else + dt_sym = e->ts.u.derived; + + memset (&ref, 0, sizeof (ref)); + + while (!gfc_compare_derived_types (dt_sym, dummy_sym)) + { + if (POINTER_TYPE_P (TREE_TYPE (parmse->expr))) + parmse->expr = build_fold_indirect_ref_loc (input_location, + parmse->expr); + + ref.u.c.component = dt_sym->components; + ref.u.c.sym = dt_sym; + gfc_conv_component_ref (parmse, &ref); + + if (!POINTER_TYPE_P (TREE_TYPE (parmse->expr))) + parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); + + gcc_assert (dt_sym->components->ts.type == BT_CLASS + || dt_sym->components->ts.type == BT_DERIVED); + dt_sym = dt_sym->components->ts.u.derived; + } + } + + if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)) + && !POINTER_TYPE_P (TREE_TYPE (ctree))) + parmse->expr = build_fold_indirect_ref_loc (input_location, + parmse->expr); + + if (TYPE_CANONICAL (TREE_TYPE (ctree)) + != TYPE_CANONICAL (TREE_TYPE (parmse->expr)) + || TYPE_MAIN_VARIANT (TREE_TYPE (ctree)) + != TYPE_MAIN_VARIANT (TREE_TYPE (parmse->expr)) + || (TREE_TYPE (ctree) != TREE_TYPE (parmse->expr) + && AGGREGATE_TYPE_P (ctree))) parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, TREE_TYPE (ctree), parmse->expr); + else if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree)) + parmse->expr = fold_convert (TREE_TYPE (ctree), parmse->expr); gfc_add_modify (&block, ctree, parmse->expr); } @@ -796,19 +770,18 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr First we have to find the corresponding class reference. */ tmp = NULL_TREE; - if (class_ref == NULL - && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) - tmp = e->symtree->n.sym->backend_decl; + if (*class_subref == NULL) + tmp = orig_expr; else { /* Remove everything after the last class reference, convert the expression and then recover its tailend once more. */ gfc_se tmpse; - ref = class_ref->next; - class_ref->next = NULL; + gfc_ref *r = *class_subref; + *class_subref = NULL; gfc_init_se (&tmpse, NULL); gfc_conv_expr (&tmpse, e); - class_ref->next = ref; + *class_subref = r; tmp = tmpse.expr; } @@ -841,7 +814,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr { gfc_init_block (&block); - tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var)); + if (!class_ts.u.derived->components->as) + tmp2 = gfc_class_data_get (var); + else + tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var)); + gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), null_pointer_node)); tmp2 = gfc_finish_block (&block); @@ -3783,10 +3760,6 @@ gfc_apply_interface_mapping_to_expr (gfc_interface expr->symtree = sym->new_sym; else if (sym->expr) gfc_replace_expr (expr, gfc_copy_expr (sym->expr)); - /* Replace base type for polymorphic arguments. */ - if (expr->ref && expr->ref->type == REF_COMPONENT - && sym->expr && sym->expr->ts.type == BT_CLASS) - expr->ref->u.c.sym = sym->expr->ts.u.derived; } /* ...and to subexpressions in expr->value. */ @@ -4522,72 +4495,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * } else { - if (e->ts.type == BT_CLASS && fsym - && fsym->ts.type == BT_CLASS - && (!CLASS_DATA (fsym)->as - || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK) - && CLASS_DATA (e)->attr.codimension) - { - gcc_assert (!CLASS_DATA (fsym)->attr.codimension); - gcc_assert (!CLASS_DATA (fsym)->as); - gfc_add_class_array_ref (e); - parmse.want_coarray = 1; - gfc_conv_expr_reference (&parmse, e); - class_scalar_coarray_to_class (&parmse, e, fsym->ts, - fsym->attr.optional - && e->expr_type == EXPR_VARIABLE); - } - else if (e->ts.type == BT_CLASS && fsym - && fsym->ts.type == BT_CLASS - && !CLASS_DATA (fsym)->as - && !CLASS_DATA (e)->as - && (CLASS_DATA (fsym)->attr.class_pointer - != CLASS_DATA (e)->attr.class_pointer - || CLASS_DATA (fsym)->attr.allocatable - != CLASS_DATA (e)->attr.allocatable)) - { - type = gfc_typenode_for_spec (&fsym->ts); - var = gfc_create_var (type, fsym->name); - gfc_conv_expr (&parmse, e); - if (fsym->attr.optional - && e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.optional) - { - stmtblock_t block; - tree cond; - tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr); - cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, - fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - gfc_start_block (&block); - gfc_add_modify (&block, var, - fold_build1_loc (input_location, - VIEW_CONVERT_EXPR, - type, parmse.expr)); - gfc_add_expr_to_block (&parmse.pre, - fold_build3_loc (input_location, - COND_EXPR, void_type_node, - cond, gfc_finish_block (&block), - build_empty_stmt (input_location))); - parmse.expr = gfc_build_addr_expr (NULL_TREE, var); - parmse.expr = build3_loc (input_location, COND_EXPR, - TREE_TYPE (parmse.expr), - cond, parmse.expr, - fold_convert (TREE_TYPE (parmse.expr), - null_pointer_node)); - } - else - { - gfc_add_modify (&parmse.pre, var, - fold_build1_loc (input_location, - VIEW_CONVERT_EXPR, - type, parmse.expr)); - parmse.expr = gfc_build_addr_expr (NULL_TREE, var); - } - } - else - gfc_conv_expr_reference (&parmse, e); + gfc_conv_expr_reference (&parmse, e); /* Catch base objects that are not variables. */ if (e->ts.type == BT_CLASS @@ -4599,10 +4507,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * /* 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 - && e->ts.type == BT_CLASS - && ((CLASS_DATA (fsym)->as - && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) - || CLASS_DATA (e)->attr.dimension)) + && e->ts.type == BT_CLASS + && !gfc_compare_derived_types (fsym->ts.u.derived, + e->ts.u.derived)) gfc_conv_class_to_class (&parmse, e, fsym->ts, false, fsym->attr.intent != INTENT_IN && (CLASS_DATA (fsym)->attr.class_pointer