From patchwork Mon Aug 12 12:11:03 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 1971558 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=gmx.de header.i=vehre@gmx.de header.a=rsa-sha256 header.s=s31663417 header.b=FH/tlWUN; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4WjD0Y4B85z1yXl for ; Mon, 12 Aug 2024 22:12:13 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 6B7F23858C35 for ; Mon, 12 Aug 2024 12:12:11 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.15.18]) by sourceware.org (Postfix) with ESMTPS id 2A2763858D34; Mon, 12 Aug 2024 12:11:06 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2A2763858D34 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 2A2763858D34 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.15.18 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723464674; cv=none; b=B3DhFjJeC3J+zPLDy4o/UBk3E9NtG8/kicRt3kyLGr6u7LWUE7qUC46rkXFLGY95KW/NZ4NJ1lL2lJ/G7ODUKAnapvNeDm2DYn4chRXw4L6epC/RCIcHviU0XY4CJseyLbYZgWEtLI3Dq76QCq7wUzGpJ/cOP2OlavF1Yh+GniI= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723464674; c=relaxed/simple; bh=wpr5m4Jz79arm0pwzFLX5rOX6qxMbVF1ST/DPc+u+lQ=; h=DKIM-Signature:Date:From:To:Subject:Message-ID:MIME-Version; b=rnTEK0sMEFPoa3dedfjiZ5aeRmZ4Jo5jLAtorc32YVF7N6dgBZ/6ZW82ozVNB2xWaJci7P28+vrCi0yVZcfj8I0E5hMvhxDmfX1jyQXOSX3c2ejtMszwD759wua1rNlRcg4f8gAHi760+GwodIY76NRNa4VFyVA+027xMrB8nE4= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmx.de; s=s31663417; t=1723464663; x=1724069463; i=vehre@gmx.de; bh=a8sl7BOjLO2vaTluIywev2d68CMplb2ZPr+3MqEPr1k=; h=X-UI-Sender-Class:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:cc:content-transfer-encoding: content-type:date:from:message-id:mime-version:reply-to:subject: to; b=FH/tlWUNYWWO07AKlfU9RjjCQpDXPhSbEUM2oGNbORjmvQeumDVyHX8tp9+P6FEb z5d+PD6rGGQbt6EjLtGNoK25rmFWulJXRH2/FASn4C7UFoPuwC3VBtVDRcOOUlavk FHb7j46gacC8lF1qeEGdwHgYQbdf26Tb2p5qBMAiETAjQ3GHoC8EFCXyfvOIyNItg wk0mXxEuNi0RE+SEql2xjgnV0e0AjVWuSYkVeSBXw2CggAMpD/aQY+wA04J/oqJDX J0VANnd5u/vCrLUgeHFZETuA9ENBS2f5rJxgsxhxG0J4XhexTnRQfopp2aDjl0erc k1ISbs1sKh0bero0Uw== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from vepi2 ([79.194.172.234]) by mail.gmx.net (mrgmx005 [212.227.17.190]) with ESMTPSA (Nemesis) id 1Mq2nA-1rrRUj2e8o-00n0BZ; Mon, 12 Aug 2024 14:11:03 +0200 Date: Mon, 12 Aug 2024 14:11:03 +0200 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Cc: Paul Richard Thomas Subject: [Fortran, Patch, PR110033, v1] Fix associate for coarrays Message-ID: <20240812141103.45548d5b@vepi2> X-Mailer: Claws Mail 4.3.0 (GTK 3.24.43; x86_64-redhat-linux-gnu) MIME-Version: 1.0 X-Provags-ID: V03:K1:+qS1pC0fSeHzJzx7i6d7fiA35TNyVP8Aa4lP/hq0JPsodFQxh77 DJ+yx7+PTmP+ERH/Fu8tJZy4C887hHqdP/beDi32YBn2PHrOLui4sH982FyuHi8jcDCb/kz hFzRkDKPVaMWTW1QAxtdyHRZH3WUWngx+6J/Qq/0fMXbqgF7cMCUWjcKYe5/+68RSRc3TMf 4+7HvlYDfX2AWKuEm7TaQ== UI-OutboundReport: notjunk:1;M01:P0:v5dZvT0A5hE=;cXJ4xLBGwRGCTIn9EsRgDoqZwsE OKxDtQ7t55AKNYhzUSwOqx/7ziv5oooI47bhrHFH5hEQFOrA3MbEnzpiXUobgzvB7+4Bzgu+h HAPuuKxxQvDZQIDCu/BJlrOIym/HaXhrfo965pThYSxuqspPQUgdQej6ZmrZC0hrMTbHJ7d6m FJj61k6xmUDJadZPpp4fgV/Nx9YCKMMnPejGKcXZQKNH8iUi7H+Bo/yOPwtEUGGKHMg/JmPtS YpkPeEP8iXo+Lh0W6JhdFHlOJ/pl+x5EyJqiHtdYeu5wlPz8l6fFunsdfRnqPSNiHBxIghKXB yH8WJJVC+4Xmnv4WTTCA6zuFovIT3fbkXrRdFVRIsXjNAAE3+SkEhOp5OHcI4FEzAUtYxNnyW NJk0cT3O08G+FiFYYUtvU5Umsn8t/L88fUhJSxVEWoH5anpjpfQ0VtqxTyHcUoFpA9FFJi1yT bh9tfqAAiHbycih/JXfBnINRzw3vYxqlOrh94tYWMJttqKGPgHwmTOXIB8X6YARIulme+K+dF d2mAn8rYrQjk4jsCY1Z6PdNaFxpsMQdZldxP2f0VqMwyK8wQoXgqQBH2s1+zN2AnbfSYcCa8y kb8XI43Dh1YFO4X8W06E/hNsjL/NteQFSKRRod/jdm5IbFdwvNEoWvjatHhq9Gde1VqvEvv6J qJw1sZjK/JZv+0nFoh4QHpvsTUHTthY0YAtMw4WptEgUPA9I1KZSukUEjCq1E9crF+LQ8YkRk t9oXAsb6P7p4DTXZRMDRIPN58FwVvASQPJtZvZ66NpBuRNdbWjBjGxqNSecNwR7OSWkOXhwTY mNJF0BYXUyZ2UWrbxCz+WWow== X-Spam-Status: No, score=-11.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SCC_5_SHORT_WORD_LINES, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org Hi all, the attached two patches fix ASSOCIATE for coarrays, i.e. that a coarray associated to a variable is also a coarray in the block of the ASSOCIATE command. The patch has two parts: 1. pr110033p1_1.patch: Adds a corank member to the gfc_expr structure. I decided to add it here and keep track of the corank of an expression, because calling gfc_get_corank was getting to expensive with the associate patch. This patch also improves the usage of coarrays in select type/rank constructs. 2. pr110033p2_1.patch: The changes and testcase for PR 110033. In essence the coarray is not detected correctly on the expression to associate to and therefore not propagated correctly into the block of the ASSOCIATE command. The patch adds correct treatment for propagating the coarray token into the block, too. The costs of tracking the corank along side to the rank of an expression are about 30 seconds real user time (i.e. time's "real" row) on a rather old Intel i7-5775C@3.3GHz with 24G RAM that was used for work during the test. If need be I can tuned that more. Regtests ok on x86_64-pc-linux-gnu / Fedora 39. Ok for mainline? Regards, Andre --- Andre Vehreschild * Email: vehre ad gmx dot de From 95a2a34ce314e1a1b8f8d531035622a64ac707f8 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Wed, 24 Jul 2024 09:39:45 +0200 Subject: [PATCH 2/2] [Fortran] Fix Coarray in associate not a coarray. [PR110033] A coarray used in an associate did not become a coarray in the block of the associate. This patch fixes that and the same also in select type statements. PR fortran/110033 gcc/fortran/ChangeLog: * class.cc (gfc_is_class_scalar_expr): Coarray refs that ref only self, aka this image, are regarded as scalar, too. * resolve.cc (resolve_assoc_var): Ignore this image coarray refs and do not build a new class type. * trans-expr.cc (gfc_get_caf_token_offset): Get the caf token from the descriptor for associated variables. (gfc_conv_variable): Same. (gfc_trans_pointer_assignment): Assign token to temporary associate variable, too. (gfc_trans_scalar_assign): Add flag that assign is for associate and use it to assign the token. (is_assoc_assign): Detect that expressions are for associate assign. (gfc_trans_assignment_1): Treat associate assigns like pointer assignments where possible. * trans-stmt.cc (trans_associate_var): Set same_class only for class-targets. * trans.h (gfc_trans_scalar_assign): Add flag to trans_scalar_assign for marking associate assignments. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/associate_1.f90: New test. --- gcc/fortran/class.cc | 38 ++++---- gcc/fortran/resolve.cc | 40 ++++++--- gcc/fortran/trans-expr.cc | 87 +++++++++++++++---- gcc/fortran/trans-stmt.cc | 2 +- gcc/fortran/trans.h | 5 +- .../gfortran.dg/coarray/associate_1.f90 | 30 +++++++ 6 files changed, 157 insertions(+), 45 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray/associate_1.f90 diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index 88fbba2818a..f9e0d416e48 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -379,27 +379,33 @@ gfc_is_class_scalar_expr (gfc_expr *e) return false; /* Is this a class object? */ - if (e->symtree - && e->symtree->n.sym->ts.type == BT_CLASS - && CLASS_DATA (e->symtree->n.sym) - && !CLASS_DATA (e->symtree->n.sym)->attr.dimension - && (e->ref == NULL - || (e->ref->type == REF_COMPONENT - && strcmp (e->ref->u.c.component->name, "_data") == 0 - && e->ref->next == NULL))) + if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS + && CLASS_DATA (e->symtree->n.sym) + && !CLASS_DATA (e->symtree->n.sym)->attr.dimension + && (e->ref == NULL + || (e->ref->type == REF_COMPONENT + && strcmp (e->ref->u.c.component->name, "_data") == 0 + && (e->ref->next == NULL + || (e->ref->next->type == REF_ARRAY + && e->ref->next->u.ar.codimen > 0 + && e->ref->next->u.ar.dimen == 0 + && e->ref->next->next == NULL))))) return true; /* Or is the final reference BT_CLASS or _data? */ for (ref = e->ref; ref; ref = ref->next) { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS - && CLASS_DATA (ref->u.c.component) - && !CLASS_DATA (ref->u.c.component)->attr.dimension - && (ref->next == NULL - || (ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0 - && ref->next->next == NULL))) + if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component) + && !CLASS_DATA (ref->u.c.component)->attr.dimension + && (ref->next == NULL + || (ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0 + && (ref->next->next == NULL + || (ref->next->next->type == REF_ARRAY + && ref->next->next->u.ar.codimen > 0 + && ref->next->next->u.ar.dimen == 0 + && ref->next->next->next == NULL))))) return true; } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index b776d6149a7..423ce203123 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -9750,6 +9750,9 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) correct this now. */ gfc_typespec *ts = &target->ts; gfc_ref *ref; + /* Internal_ref is true, when this is ref'ing only _data and co-ref. + */ + bool internal_ref = true; for (ref = target->ref; ref != NULL; ref = ref->next) { @@ -9757,26 +9760,41 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) { case REF_COMPONENT: ts = &ref->u.c.component->ts; + internal_ref + = target->ref == ref && ref->next + && strncmp ("_data", ref->u.c.component->name, 5) == 0; break; case REF_ARRAY: if (ts->type == BT_CLASS) ts = &ts->u.derived->components->ts; + if (internal_ref && ref->u.ar.codimen > 0) + for (int i = ref->u.ar.dimen; + internal_ref + && i < ref->u.ar.dimen + ref->u.ar.codimen; + ++i) + internal_ref + = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE; break; default: break; } } - /* Create a scalar instance of the current class type. Because the - rank of a class array goes into its name, the type has to be - rebuilt. The alternative of (re-)setting just the attributes - and as in the current type, destroys the type also in other - places. */ - as = NULL; - sym->ts = *ts; - sym->ts.type = BT_CLASS; - attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; - gfc_change_class (&sym->ts, &attr, as, 0, 0); - sym->as = NULL; + /* Only rewrite the type of this symbol, when the refs are not the + internal ones for class and co-array this-image. */ + if (!internal_ref) + { + /* Create a scalar instance of the current class type. Because + the rank of a class array goes into its name, the type has to + be rebuilt. The alternative of (re-)setting just the + attributes and as in the current type, destroys the type also + in other places. */ + as = NULL; + sym->ts = *ts; + sym->ts.type = BT_CLASS; + attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; + gfc_change_class (&sym->ts, &attr, as, 0, 0); + sym->as = NULL; + } } } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index dd89d9cb5ea..8801a15c3a8 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2437,7 +2437,8 @@ gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl, { gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE - || expr->symtree->n.sym->attr.select_type_temporary); + || expr->symtree->n.sym->attr.select_type_temporary + || expr->symtree->n.sym->assoc); *token = gfc_conv_descriptor_token (caf_decl); } else if (DECL_LANG_SPECIFIC (caf_decl) @@ -3256,6 +3257,13 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) else se->string_length = sym->ts.u.cl->backend_decl; gcc_assert (se->string_length); + + /* For coarray strings return the pointer to the data and not the + descriptor. */ + if (sym->attr.codimension && sym->attr.associate_var + && !se->descriptor_only + && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE) + se->expr = gfc_conv_descriptor_data_get (se->expr); } /* Some expressions leak through that haven't been fixed up. */ @@ -10536,10 +10544,25 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_modify (&block, lse.expr, fold_convert (TREE_TYPE (lse.expr), rse.expr)); - /* Also set the tokens for pointer components in derived typed - coarrays. */ if (flag_coarray == GFC_FCOARRAY_LIB) - trans_caf_token_assign (&lse, &rse, expr1, expr2); + { + if (expr1->ref) + /* Also set the tokens for pointer components in derived typed + coarrays. */ + trans_caf_token_assign (&lse, &rse, expr1, expr2); + else if (gfc_caf_attr (expr1).codimension) + { + tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok; + + lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1); + rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2); + gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl, + NULL_TREE, expr1); + gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl, + NULL_TREE, expr2); + gfc_add_modify (&block, lhs_tok, rhs_tok); + } + } gfc_add_block_to_block (&block, &rse.post); gfc_add_block_to_block (&block, &lse.post); @@ -10981,8 +11004,9 @@ gfc_conv_string_parameter (gfc_se * se) the assignment from the temporary to the lhs. */ tree -gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, - bool deep_copy, bool dealloc, bool in_coarray) +gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts, + bool deep_copy, bool dealloc, bool in_coarray, + bool assoc_assign) { stmtblock_t block; tree tmp; @@ -11103,6 +11127,21 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); + if (in_coarray) + { + if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign) + { + gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr), + TYPE_LANG_SPECIFIC ( + TREE_TYPE (TREE_TYPE (rse->expr))) + ->caf_token); + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr))) + lse->expr = gfc_conv_array_data (lse->expr); + if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign + && !POINTER_TYPE_P (TREE_TYPE (rse->expr))) + rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr); + } gfc_add_modify (&block, lse->expr, fold_convert (TREE_TYPE (lse->expr), rse->expr)); } @@ -12290,6 +12329,15 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, } } +bool +is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs) +{ + if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE) + return false; + + return lhs->symtree->n.sym->assoc + && lhs->symtree->n.sym->assoc->target == rhs; +} /* Subroutine of gfc_trans_assignment that actually scalarizes the assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. @@ -12323,6 +12371,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr; bool is_poly_assign; bool realloc_flag; + bool assoc_assign = false; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -12378,6 +12427,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, || gfc_is_class_scalar_expr (expr2)) && lhs_attr.flavor != FL_PROCEDURE; + assoc_assign = is_assoc_assign (expr1, expr2); + realloc_flag = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1) && expr2->rank @@ -12471,11 +12522,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL); /* Translate the expression. */ - rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag - && lhs_caf_attr.codimension; + rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB + && (init_flag || assoc_assign) && lhs_caf_attr.codimension; + rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension; gfc_conv_expr (&rse, expr2); - /* Deal with the case of a scalar class function assigned to a derived type. */ + /* Deal with the case of a scalar class function assigned to a derived type. + */ if (gfc_is_alloc_class_scalar_function (expr2) && expr1->ts.type == BT_DERIVED) { @@ -12690,15 +12743,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, else gfc_add_block_to_block (&body, &rse.pre); + if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER + && assoc_assign) + tmp = gfc_trans_pointer_assignment (expr1, expr2); + /* If nothing else works, do it the old fashioned way! */ if (tmp == NULL_TREE) - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - gfc_expr_is_variable (expr2) - || scalar_to_array + tmp + = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + gfc_expr_is_variable (expr2) || scalar_to_array || expr2->expr_type == EXPR_ARRAY, - !(l_is_temp || init_flag) && dealloc, - expr1->symtree->n.sym->attr.codimension); - + !(l_is_temp || init_flag) && dealloc, + expr1->symtree->n.sym->attr.codimension, + assoc_assign); /* Add the lse pre block to the body */ gfc_add_block_to_block (&body, &lse.pre); diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 807fa8c6351..3b09a139dc0 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -1754,7 +1754,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) && e->ts.type == BT_CLASS && (gfc_is_class_scalar_expr (e) || gfc_is_class_array_ref (e, NULL)); - same_class = e->ts.type == BT_CLASS && sym->ts.type == BT_CLASS + same_class = class_target && sym->ts.type == BT_CLASS && strcmp (sym->ts.u.derived->name, e->ts.u.derived->name) == 0; unlimited = UNLIMITED_POLY (e); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index fdcce206756..d67fbe36a24 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -570,8 +570,9 @@ void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool, void gfc_conv_is_contiguous_expr (gfc_se *, gfc_expr *); /* Generate code for a scalar assignment. */ -tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool, - bool c = false); +tree +gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool, + bool = false, bool = false); /* Translate COMMON blocks. */ void gfc_trans_common (gfc_namespace *); diff --git a/gcc/testsuite/gfortran.dg/coarray/associate_1.f90 b/gcc/testsuite/gfortran.dg/coarray/associate_1.f90 new file mode 100644 index 00000000000..6eb55c91551 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/associate_1.f90 @@ -0,0 +1,30 @@ +!{ dg-do run } + +! Contributed by Neil Carlson +! Check PR110033 is fixed. + +program coarray_associate_1 + type t + integer :: b = -1 + logical :: l = .FALSE. + end type + + integer :: x[*] = 10 + class(t), allocatable :: c[:] + + associate (y => x) + y = -1 + y[1] = 35 + end associate + allocate(c[*]) + associate (f => c) + f%b = 17 + f[1]%l = .TRUE. + end associate + + if (x /= 35) stop 1 + + if (c%b /= 17) stop 2 + if (.NOT. c%l) stop 3 +end + -- 2.46.0