From patchwork Wed Jul 10 09:17:44 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 1958779 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=thzUo5UX; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; 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 [IPv6:2620:52:3:1:0:246e:9693:128c]) (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 4WJsjC0rbKz1yNy for ; Wed, 10 Jul 2024 19:18:23 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id ECF6D3870938 for ; Wed, 10 Jul 2024 09:18:20 +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.19]) by sourceware.org (Postfix) with ESMTPS id 99DD73865C21; Wed, 10 Jul 2024 09:17:48 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 99DD73865C21 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 99DD73865C21 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.15.19 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1720603072; cv=none; b=fbywl0tuZD9u4rWcD3KgPz/x/12lZnccantzZeQTzPfX51QQP8yEq0fhRCBMQ1DLnWy8jV6RX5/bXlleC2iNTlUtEqWUOwjITEgl0BvER8XmOMcGe3J/vZ7iUzrYftNyqbyl98lEH960QNUD2NHk0eW0NK3fPcHlp+/BdftQk0Y= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1720603072; c=relaxed/simple; bh=TEx2DQbwoMZgyUqWLZYRx9NDhKq/LZBORIY8Ky2QKL4=; h=DKIM-Signature:Date:From:To:Subject:Message-ID:MIME-Version; b=sy63HXxGoZW8wJ/5afVisfGJww/6ry0TUxu3jwdqxQWmXDCbbUa6kRqKWww5v1GDclIWxqGuvESeFRijvdepquQmWs0/ZSBAd6x8O9c3TycGTlca4cR/AQSrS4+3EIXSsVy+9NqADilFBvyMkO5McPtW5/hvitWHp62XSHvUhAc= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmx.de; s=s31663417; t=1720603067; x=1721207867; i=vehre@gmx.de; bh=K3gNuLoGJ3Mo3v0w4oCK8RZxPan/0nY91iUBUkzj+Mw=; h=X-UI-Sender-Class:Date:From:To:Subject:Message-ID:MIME-Version: Content-Type:cc:content-transfer-encoding:content-type:date:from: message-id:mime-version:reply-to:subject:to; b=thzUo5UX68JOtmfzeljZOlYoJ2Ol+byqvSVVx8g1wa//zpaHjXzurCo/IXW4/7Lm ORLTtmjLCNiaFOZBzw695f30ZNlvDAAurXOMJrJ2f5seMVkbLDaS6n2XFl3mA9dcN bSy/V0QsbcPVNgPMnrOz1UOgqpWM/XDcL2oU6FfAoLl4N4oJp537pj6dGutZcW9nF zwglwqJaC45nojsgE3n1QXgxliNIHhI0a0JxJBWcsxWqNkE8kca2n9s6t5daIZBze XYD7hcwMAG1Vm6KblJpa6BxUAc3u9lm0RCydn+IoVGth88yhRa+/GmsF1Z434QtzN XAic00tZ+y4PPMbP1w== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from vepi2 ([80.141.179.142]) by mail.gmx.net (mrgmx004 [212.227.17.190]) with ESMTPSA (Nemesis) id 1N8GMk-1sN9yN0lkG-00vWag; Wed, 10 Jul 2024 11:17:47 +0200 Date: Wed, 10 Jul 2024 11:17:44 +0200 From: Andre Vehreschild To: GCC-Fortran-ML , GCC-Patches-ML Subject: [Fortran, Patch, PR78466, coarray, v1] Fix Explicit cobounds of a procedures parameter not respected Message-ID: <20240710111744.0e13e848@vepi2> X-Mailer: Claws Mail 4.3.0 (GTK 3.24.41; x86_64-redhat-linux-gnu) MIME-Version: 1.0 X-Provags-ID: V03:K1:WMeyRJbVIv84GA9FMbRYC6hvMTPbSPcr02i1maC1BjNDAI+yXlx 3BJ9bf4u0B1exYhIV49Qg0fnYGNzeTZ/M/DF8p/Bmca8H+DPjk4KihbypWq6dTMZlnjx+tL eejyNEwTrBYsoFclW4OlgUWzR7Rb0QeW6rw5tpz/RhvXPiy51mSXRQkfGvPZbZce7lQaXwv 7tHy1uAWIT0jvCFvW6VLQ== UI-OutboundReport: notjunk:1;M01:P0:4yTXZo61Gb4=;0v08EVRFqxHuqMA7xp3I5Xghvst hjqp8Z3W++uMVWpWWRyaz1gUN9NWRrCsikOUMjvjFtfnGG2+Y8T73cpVGGlgX5ObN9GgBk3gs BVCXlb3WLBBJfdMFacfkFKNbIy8yL6hGrz96HgvrNdfekejAO5RFbBKtdSStbhxIgVa6bUv9t bTUuPkDRswcYj8AFYSb9EnezMfhAOsHTh4kAriSp5FDBCv4DKWotDwCI+Fo56VXiuc/Lq+Wjt Yl8eW10jkNcWu7IqdG/YXWBwRWA4kncxJlF1X9jbrtO8A7MMNgDppSH01yG4YinkjD5rjWvuw GzKrfrUljdlX4jQxZSFhWpMe+YQuW3TnXInJIwm/g/3WYRq9Y8YRTpADK7AZX3euDtyIDAVvu sgDuoWaVSHxfuv5+9FjyzwSuD471tv67+v1QByVUw/n8TDyWIhnzvZop3YADk+0W1k3m2CKqH aul30TV4bN+fc2LtoS/6LnuFL3PDdVpjTYZ+XiOGu2x/Ic/H2nGO5H+DDMG7uNfU/+fdDRvKO +Kzeil0d/gwZhpADqTuo5U1VXfyzSoJXQZ4abuyeqmH32K2SSshTqCbnjC1jhWAmJXxC4d33i UkDGq0/EXeN5PwL8MXIeDRIrNc8TMN5X35M7dqC5MTd3qAIh9W76fjDgQU2WMUQ2Fwu9Ls1gq 6sFZxXJlvCnz/saItW2itfGkPHb5RNcMYSymAG4r68qgshSQHDaQ+Om6cfjs3Jl9lAM1KfIIu FfWCXYtMafqXBESSD/jNdekG9int7WhsemkkpEPvpIAkGu1vR2wRZFf2MUQ1HHsoKEPqV7RSt dcLX7lMtVA7rjmlRO8mDVxTXwSRldcWiDvJyPrTLEZmZ8= X-Spam-Status: No, score=-9.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_SHORT, RCVD_IN_BARRACUDACENTRAL, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H2, SPF_HELO_NONE, SPF_PASS, TXREP 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 patch fixes explicit cobounds of procedure parameters not respected. The central issue is, that class (array) types store their attributes and `as` in the first component of the derived type. This made comparison of existing types harder and gfortran confused generated trees for different cobounds. The attached patch fixes this. Note, the patch is based on https://gcc.gnu.org/pipermail/fortran/2024-July/060645.html . Without it the test poly_run_2 fails. Regtests ok on x86_64-pc-linux-gnu/Fedora 39. Ok for mainline? This patch also fixes PR fortran/80774. Regards, Andre --- Andre Vehreschild * Email: vehre ad gmx dot de From 32d8a8da4e1e6120c515932878994514e04c909d Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Thu, 31 Dec 2020 10:40:30 +0100 Subject: [PATCH] Fortran: Fix Explicit cobounds of a procedures parameter not respected [PR78466] Explicit cobounds of class array procedure parameters were not taken into account. Furthermore were different cobounds in distinct procedure parameter lists mixed up, i.e. the last definition was taken for all. The bounds are now regenerated when tree's and expr's bounds do not match. PR fortran/78466 PR fortran/80774 gcc/fortran/ChangeLog: * array.cc (gfc_compare_array_spec): Take cotype into account. * class.cc (gfc_build_class_symbol): Coarrays are also arrays. * gfortran.h (IS_CLASS_COARRAY_OR_ARRAY): New macro to detect regular and coarray class arrays. * interface.cc (compare_components): Take codimension into account. * resolve.cc (resolve_symbol): Improve error message. * simplify.cc (simplify_bound_dim): Remove duplicate. * trans-array.cc (gfc_trans_array_cobounds): Coarrays are also arrays. (gfc_trans_array_bounds): Same. (gfc_trans_dummy_array_bias): Same. (get_coarray_as): Get the as having a non-zero codim. (is_explicit_coarray): Detect explicit coarrays. (gfc_conv_expr_descriptor): Create a new descriptor for explicit coarrays. * trans-decl.cc (gfc_build_qualified_array): Coarrays are also arrays. (gfc_build_dummy_array_decl): Same. (gfc_get_symbol_decl): Same. (gfc_trans_deferred_vars): Same. * trans-expr.cc (class_scalar_coarray_to_class): Get the descriptor from the correct location. (gfc_conv_variable): Pick up the descriptor when needed. * trans-types.cc (gfc_is_nodesc_array): Coarrays are also arrays. (gfc_get_nodesc_array_type): Indentation fix only. (cobounds_match_decl): Match a tree's bounds to the expr's bounds and return true, when they match. (gfc_get_derived_type): Create a new type tree/descriptor, when the cobounds of the existing declaration and expr to not match. This happends for class arrays in parameter list, when there are different cobound declarations. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/poly_run_1.f90: Activate old test code. * gfortran.dg/coarray/poly_run_2.f90: Activate test. It was stopping before and passing without an error. --- gcc/fortran/array.cc | 3 + gcc/fortran/class.cc | 8 +- gcc/fortran/gfortran.h | 5 ++ gcc/fortran/interface.cc | 7 ++ gcc/fortran/resolve.cc | 3 +- gcc/fortran/simplify.cc | 2 - gcc/fortran/trans-array.cc | 53 ++++++++++++- gcc/fortran/trans-decl.cc | 20 ++--- gcc/fortran/trans-expr.cc | 34 ++++++--- gcc/fortran/trans-types.cc | 74 ++++++++++++++++--- .../gfortran.dg/coarray/poly_run_1.f90 | 33 ++++----- .../gfortran.dg/coarray/poly_run_2.f90 | 28 ++++--- 12 files changed, 207 insertions(+), 63 deletions(-) diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index e9934f1491b..79c774d59a0 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -1017,6 +1017,9 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) if (as1->type != as2->type) return 0; + if (as1->cotype != as2->cotype) + return 0; + if (as1->type == AS_EXPLICIT) for (i = 0; i < as1->rank + as1->corank; i++) { diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index abe89630be3..b9dcc0a3d98 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -709,8 +709,12 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, work on the declared type. All array type other than deferred shape or assumed rank are added to the function namespace to ensure that they are properly distinguished. */ - if (attr->dummy && !attr->codimension && (*as) - && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK)) + if (attr->dummy && (*as) + && ((!attr->codimension + && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK)) + || (attr->codimension + && !((*as)->cotype == AS_DEFERRED + || (*as)->cotype == AS_ASSUMED_RANK)))) { char *sname; ns = gfc_current_ns; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ed1213a41cb..2b56615dfbc 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -4043,6 +4043,11 @@ bool gfc_may_be_finalized (gfc_typespec); && CLASS_DATA (sym) \ && CLASS_DATA (sym)->attr.dimension \ && !CLASS_DATA (sym)->attr.class_pointer) +#define IS_CLASS_COARRAY_OR_ARRAY(sym) \ + (sym->ts.type == BT_CLASS && CLASS_DATA (sym) \ + && (CLASS_DATA (sym)->attr.dimension \ + || CLASS_DATA (sym)->attr.codimension) \ + && !CLASS_DATA (sym)->attr.class_pointer) #define IS_POINTER(sym) \ (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \ ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer) diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index bf151dae743..b592fe4f6c7 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -518,12 +518,19 @@ compare_components (gfc_component *cmp1, gfc_component *cmp2, if (cmp1->attr.dimension != cmp2->attr.dimension) return false; + if (cmp1->attr.codimension != cmp2->attr.codimension) + return false; + if (cmp1->attr.allocatable != cmp2->attr.allocatable) return false; if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0) return false; + if (cmp1->attr.codimension + && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0) + return false; + if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER) { gfc_charlen *l1 = cmp1->ts.u.cl; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 4f4fafa4217..503029364c1 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -16909,7 +16909,8 @@ resolve_symbol (gfc_symbol *sym) && !class_attr.allocatable && as && as->cotype == AS_DEFERRED) { gfc_error ("Coarray variable %qs at %L shall not have codimensions with " - "deferred shape", sym->name, &sym->declared_at); + "deferred shape without allocatable", sym->name, + &sym->declared_at); return; } else if (class_attr.codimension && class_attr.allocatable && as diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 7a5d31c01a6..fca72659d99 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -4115,8 +4115,6 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, goto returnNull; } - result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - /* Then, we need to know the extent of the given dimension. */ if (coarray || (ref->u.ar.type == AR_FULL && !ref->next)) { diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 0fffa07495c..05dabc21d3a 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -6838,7 +6838,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, gfc_se se; gfc_array_spec *as; - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; for (dim = as->rank; dim < as->rank + as->corank; dim++) { @@ -6887,7 +6887,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, int dim; - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; size = gfc_index_one_node; offset = gfc_index_zero_node; @@ -7230,7 +7230,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, int no_repack; bool optional_arg; gfc_array_spec *as; - bool is_classarray = IS_CLASS_ARRAY (sym); + bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym); /* Do nothing for pointer and allocatable arrays. */ if ((sym->ts.type != BT_CLASS && sym->attr.pointer) @@ -7906,6 +7906,51 @@ walk_coarray (gfc_expr *e) return ss; } +gfc_array_spec * +get_coarray_as (const gfc_expr *e) +{ + gfc_array_spec *as; + gfc_symbol *sym = e->symtree->n.sym; + gfc_component *comp; + + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension) + as = CLASS_DATA (sym)->as; + else if (sym->attr.codimension) + as = sym->as; + else + as = nullptr; + + for (gfc_ref *ref = e->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + comp = ref->u.c.component; + if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension) + as = CLASS_DATA (comp)->as; + else if (comp->ts.type != BT_CLASS && comp->attr.codimension) + as = comp->as; + break; + + case REF_ARRAY: + case REF_SUBSTRING: + case REF_INQUIRY: + break; + } + } + + return as; +} + +bool +is_explicit_coarray (gfc_expr *expr) +{ + if (!gfc_is_coarray (expr)) + return false; + + gfc_array_spec *cas = get_coarray_as (expr); + return cas && cas->cotype == AS_EXPLICIT; +} /* Convert an array for passing as an actual argument. Expressions and vector subscripts are evaluated and stored in a temporary, which is then @@ -8020,6 +8065,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (need_tmp) full = 0; + else if (is_explicit_coarray (expr)) + full = 0; else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) { /* Create a new descriptor if the array doesn't have one. */ diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 54ab60b4935..e6ac7f25b3b 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1016,7 +1016,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) gfc_namespace* procns; symbol_attribute *array_attr; gfc_array_spec *as; - bool is_classarray = IS_CLASS_ARRAY (sym); + bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym); type = TREE_TYPE (decl); array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; @@ -1134,7 +1134,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type)); } - if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE + if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE && as->rank != 0 && as->type != AS_ASSUMED_SIZE) { GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest); @@ -1238,7 +1238,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) gfc_packed packed; int n; bool known_size; - bool is_classarray = IS_CLASS_ARRAY (sym); + bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym); /* Use the array as and attr. */ as = is_classarray ? CLASS_DATA (sym)->as : sym->as; @@ -1760,7 +1760,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then responsible to extract it from there, when the descriptor is desired. */ - if (IS_CLASS_ARRAY (sym) + if (IS_CLASS_COARRAY_OR_ARRAY (sym) && (!DECL_LANG_SPECIFIC (sym->backend_decl) || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) { @@ -1775,10 +1775,11 @@ gfc_get_symbol_decl (gfc_symbol * sym) if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) gfc_add_assign_aux_vars (sym); - if (sym->ts.type == BT_CLASS && sym->backend_decl) - GFC_DECL_CLASS(sym->backend_decl) = 1; + if (sym->ts.type == BT_CLASS && sym->backend_decl + && !IS_CLASS_COARRAY_OR_ARRAY (sym)) + GFC_DECL_CLASS (sym->backend_decl) = 1; - return sym->backend_decl; + return sym->backend_decl; } if (sym->result == sym && sym->attr.assign @@ -4889,9 +4890,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1; } else if ((sym->attr.dimension || sym->attr.codimension - || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))) + || (IS_CLASS_COARRAY_OR_ARRAY (sym) + && !CLASS_DATA (sym)->attr.allocatable))) { - bool is_classarray = IS_CLASS_ARRAY (sym); + bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym); symbol_attribute *array_attr; gfc_array_spec *as; array_type type_of_array; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 21ec7033e40..60495f199dc 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1018,7 +1018,10 @@ class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e, 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)); + tmp = gfc_conv_descriptor_data_get ( + gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp))) + ? tmp + : GFC_DECL_SAVED_DESCRIPTOR (tmp))); gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp)); /* Pass the address of the class object. */ @@ -3125,7 +3128,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) bool first_time = true; sym = expr->symtree->n.sym; - is_classarray = IS_CLASS_ARRAY (sym); + is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym); ss = se->ss; if (ss != NULL) { @@ -3216,11 +3219,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived->attr.is_class) - se->class_container = se->expr; + { + if (is_classarray && DECL_LANG_SPECIFIC (se->expr) + && GFC_DECL_SAVED_DESCRIPTOR (se->expr)) + se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr); + else + se->class_container = se->expr; + } /* Dereference the expression, where needed. */ - se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only, - is_classarray); + if (se->class_container && CLASS_DATA (sym)->attr.codimension + && !CLASS_DATA (sym)->attr.dimension) + se->expr + = gfc_maybe_dereference_var (sym, se->class_container, + se->descriptor_only, is_classarray); + else + se->expr + = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only, + is_classarray); ref = expr->ref; } @@ -3263,11 +3279,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) case REF_COMPONENT: ts = &ref->u.c.component->ts; - if (first_time && is_classarray && sym->attr.dummy - && se->descriptor_only - && !CLASS_DATA (sym)->attr.allocatable - && !CLASS_DATA (sym)->attr.class_pointer - && CLASS_DATA (sym)->as + if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy + && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable + && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK && strcmp ("_data", ref->u.c.component->name) == 0) /* Skip the first ref of a _data component, because for class diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 0ef67723fcd..42a7934db9d 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1381,7 +1381,7 @@ gfc_is_nodesc_array (gfc_symbol * sym) { symbol_attribute *array_attr; gfc_array_spec *as; - bool is_classarray = IS_CLASS_ARRAY (sym); + bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym); array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; as = is_classarray ? CLASS_DATA (sym)->as : sym->as; @@ -1752,7 +1752,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, else tmp = NULL_TREE; if (n < as->rank + as->corank - 1) - GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; + GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; } if (known_offset) @@ -2584,6 +2584,53 @@ gfc_get_union_type (gfc_symbol *un) return typenode; } +bool +cobounds_match_decl (const gfc_symbol *derived) +{ + tree arrtype, tmp; + gfc_array_spec *as; + + if (!derived->backend_decl) + return false; + /* Care only about coarray declarations. Everything else is ok with us. */ + if (!derived->components || strcmp (derived->components->name, "_data") != 0) + return true; + if (!derived->components->attr.codimension) + return true; + + arrtype = TREE_TYPE (TYPE_FIELDS (derived->backend_decl)); + as = derived->components->as; + if (GFC_TYPE_ARRAY_CORANK (arrtype) != as->corank) + return false; + + for (int dim = as->rank; dim < as->rank + as->corank; ++dim) + { + /* Check lower bound. */ + tmp = TYPE_LANG_SPECIFIC (arrtype)->lbound[dim]; + if (!tmp || !INTEGER_CST_P (tmp)) + return false; + if (as->lower[dim]->expr_type != EXPR_CONSTANT + || as->lower[dim]->ts.type != BT_INTEGER) + return false; + if (*tmp->int_cst.val != mpz_get_si (as->lower[dim]->value.integer)) + return false; + + /* Check upper bound. */ + tmp = TYPE_LANG_SPECIFIC (arrtype)->ubound[dim]; + if (!tmp && !as->upper[dim]) + continue; + + if (!tmp || !INTEGER_CST_P (tmp)) + return false; + if (as->upper[dim]->expr_type != EXPR_CONSTANT + || as->upper[dim]->ts.type != BT_INTEGER) + return false; + if (*tmp->int_cst.val != mpz_get_si (as->upper[dim]->value.integer)) + return false; + } + + return true; +} /* Build a tree node for a derived type. If there are equal derived types, with different local names, these are built @@ -2601,10 +2648,15 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen) gfc_component *c; gfc_namespace *ns; tree tmp; - bool coarray_flag; + bool coarray_flag, class_coarray_flag; coarray_flag = flag_coarray == GFC_FCOARRAY_LIB && derived->module && !derived->attr.vtype; + class_coarray_flag = derived->components + && derived->components->ts.type == BT_DERIVED + && strcmp (derived->components->name, "_data") == 0 + && derived->components->attr.codimension + && derived->components->as->cotype == AS_EXPLICIT; gcc_assert (!derived->attr.pdt_template); @@ -2693,13 +2745,14 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen) /* derived->backend_decl != 0 means we saw it before, but its components' backend_decl may have not been built. */ - if (derived->backend_decl) + if (derived->backend_decl + && (!class_coarray_flag || cobounds_match_decl (derived))) { /* Its components' backend_decl have been built or we are seeing recursion through the formal arglist of a procedure pointer component. */ if (TYPE_FIELDS (derived->backend_decl)) - return derived->backend_decl; + return derived->backend_decl; else if (derived->attr.abstract && derived->attr.proc_pointer_comp) { @@ -2781,7 +2834,7 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen) } } - if (TYPE_FIELDS (derived->backend_decl)) + if (!class_coarray_flag && TYPE_FIELDS (derived->backend_decl)) return derived->backend_decl; /* Build the type member list. Install the newly created RECORD_TYPE @@ -2888,12 +2941,13 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen) DECL_PACKED (field) |= TYPE_PACKED (typenode); gcc_assert (field); - if (!c->backend_decl) + /* Overwrite for class array to supply different bounds for different + types. */ + if (class_coarray_flag || !c->backend_decl) c->backend_decl = field; - if (c->attr.pointer && c->attr.dimension - && !(c->ts.type == BT_DERIVED - && strcmp (c->name, "_data") == 0)) + if (c->attr.pointer && (c->attr.dimension || c->attr.codimension) + && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0)) GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1; } diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 index 43525d96663..f5354b89ca5 100644 --- a/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 @@ -14,7 +14,7 @@ else end if if (allocated(A)) i = 5 call s(A) -!call st(A) ! FIXME +call st(A) ! FIXME contains @@ -30,22 +30,21 @@ end subroutine s subroutine st(x) class(t) :: x(:)[4,2:*] -! FIXME -! if (any (lcobound(x) /= [1, 2])) STOP 7 -! if (lcobound(x, dim=1) /= 1) STOP 8 -! if (lcobound(x, dim=2) /= 2) STOP 9 -! if (this_image() == 1) then -! if (any (this_image(x) /= lcobound(x))) STOP 10 -! if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11 -! if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12 -! end if -! if (num_images() == 1) then -! if (any (ucobound(x) /= [4, 2])) STOP 13 -! if (ucobound(x, dim=1) /= 4) STOP 14 -! if (ucobound(x, dim=2) /= 2) STOP 15 -! else -! if (ucobound(x,dim=1) /= 4) STOP 16 -! end if + if (any (lcobound(x) /= [1, 2])) STOP 7 + if (lcobound(x, dim=1) /= 1) STOP 8 + if (lcobound(x, dim=2) /= 2) STOP 9 + if (this_image() == 1) then + if (any (this_image(x) /= lcobound(x))) STOP 10 + if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11 + if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12 + end if + if (num_images() == 1) then + if (any (ucobound(x) /= [4, 2])) STOP 13 + if (ucobound(x, dim=1) /= 4) STOP 14 + if (ucobound(x, dim=2) /= 2) STOP 15 + else + if (ucobound(x,dim=1) /= 4) STOP 16 + end if end subroutine st end diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 index 48a6f7b4cc0..37347cba6aa 100644 --- a/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 @@ -6,16 +6,16 @@ type t end type t class(t), allocatable :: A[:,:] allocate (A[1:4,-5:*]) -if (allocated(A)) stop if (any (lcobound(A) /= [1, -5])) STOP 1 if (num_images() == 1) then if (any (ucobound(A) /= [4, -5])) STOP 2 else if (ucobound(A,dim=1) /= 4) STOP 3 end if -if (allocated(A)) i = 5 + call s(A) -call st(A) +call s2(A) +call sa(A) contains subroutine s(x) class(t) :: x[4,2:*] @@ -26,14 +26,24 @@ subroutine s(x) if (ucobound(x,dim=1) /= 4) STOP 6 end if end subroutine s -subroutine st(x) - class(t) :: x[:,:] - if (any (lcobound(x) /= [1, -5])) STOP 7 +subroutine s2(x) + ! Check that different cobounds are set correctly. + class(t) :: x[2:5,7:*] + if (any (lcobound(x) /= [2, 7])) STOP 7 + if (num_images() == 1) then + if (any (ucobound(x) /= [5, 7])) STOP 8 + else + if (ucobound(x,dim=1) /= 5) STOP 9 + end if +end subroutine s2 +subroutine sa(x) + class(t), allocatable :: x[:,:] + if (any (lcobound(x) /= [1, -5])) STOP 10 if (num_images() == 1) then - if (any (ucobound(x) /= [4, -5])) STOP 8 + if (any (ucobound(x) /= [4, -5])) STOP 11 else - if (ucobound(x,dim=1) /= 4) STOP 9 + if (ucobound(x,dim=1) /= 4) STOP 12 end if -end subroutine st +end subroutine sa end -- 2.45.2