From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 107111 invoked by alias); 4 Mar 2015 19:30:29 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 107068 invoked by uid 89); 4 Mar 2015 19:30:28 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.5 required=5.0 tests=AWL,BAYES_00,FREEMAIL_FROM,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.19) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Wed, 04 Mar 2015 19:30:24 +0000 Received: from vepi2 ([88.75.104.20]) by mail.gmx.com (mrgmx003) with ESMTPSA (Nemesis) id 0MhRUQ-1Y6bmM3SOg-00MctR; Wed, 04 Mar 2015 20:30:18 +0100 Date: Wed, 04 Mar 2015 19:30:00 -0000 From: Andre Vehreschild To: GCC-Fortran-ML , GCC-Patches-ML , Antony Lewis Subject: Re: [Patch 2/2, v2, Fortran, pr60322 a.o.] [OOP] Incorrect bounds on polymorphic dummy array Message-ID: <20150304203015.23544479@vepi2> In-Reply-To: <20150226181721.50bf41c7@vepi2> References: <20150226181721.50bf41c7@vepi2> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/c8ythEJv_7UCpX_V=dpIksz" X-UI-Out-Filterresults: notjunk:1; X-SW-Source: 2015-03/txt/msg00242.txt.bz2 --MP_/c8ythEJv_7UCpX_V=dpIksz Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-length: 3326 Dear all, during his initial tests Dominique pointed out, that my patch did not fix all issues in the comments of pr60322. This new version of the patch fixes this issue now. The trick is to use a temporary array in the variable association of select type statements. The old code referenced the incoming array directly. This array may have an arbitrary base (i.e. lbound != 1) making indexing very difficult. Creating a temporary array descriptor for the associated variable allows for having the array base set to one (i.e., lbound == 1) making indexing fairly simple and adhere to the Fortran rules. The patch boostraps and regtests cleanly on x86_64-linux-gnu/F20. Note, you need to apply part 1 of this patch first. Part 1 can be found at: https://gcc.gnu.org/ml/fortran/2015-02/msg00105.html Regards, Andre On Thu, 26 Feb 2015 18:17:21 +0100 Andre Vehreschild wrote: > Hi all, > > here is the second part of the patch for pr60322. This patch also addresses > the issue reported in pr64692, ... (more to come). > > The patch fixes the incorrect bounds of polymorphic arrays used to call > functions and subroutines by using the same mechanism as regular arrays. In > fact most of the code for treating regular arrays is reused by simply > inserting the class array's symbol_attributes and gfc_array_specs into the > same routines, i.e., doing the switching whether a symbol is a class array or > a regular array and assigning the CLASS_DATA(sym).attr or sym.attr to the > symbol_attribute temporary variable introduced by the first part (same for > gfc_array_spec). The temporary array descriptor is then stored in the tree > and extracted were it is needed. > > This patch furthermore addresses an issue with elemental functions, where the > elemental function was not applied to class array members. By introducing the > temporary array this merely fixed itself. > > During fixing elemental function application, an issue about using the > polymorphic initializer popped up. The existing code would declare a variable > of the base type (not a reference or pointer to it), assign the _vptr's > _def_init to it and use the _vptr's _copy to copy the initializer into the > object to initialize. This had to be patched to use a pointer for the variable > and the correct addressing to be able to make use of the polymorphic init. > > Furthermore is the array offset in certain cases set to be -1. This helped to > get the addressing correct for subarrays of (unlimited polymorphic) objects, > where the array offset is used in a "select type" or other kind of association > and the with the offset set incorrectly wrong elements from the array were > selected. > > I had to fix two testcases, too: > - finalize_15: We agreed (including checking with other compilers) that the > value of an intent(out) variable should be that of its initializer and not > that of its finalizer. > - finalize_10: By using the temporary arrays the scan-tree-count expressions > had to be adapted, too. > > Thank you's go to: Tobias, Dominique and Paul for their support during > figuring what it going wrong and thorough testing and to Antony for reporting > the issue. > > Bootstraps and regtests ok on x86_64-linux-gnu/F20. > > Regards, > Andre -- Andre Vehreschild * Email: vehre ad gmx dot de --MP_/c8ythEJv_7UCpX_V=dpIksz Content-Type: application/octet-stream; name=pr60322_2.clog Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename=pr60322_2.clog Content-length: 3299 Z2NjL2ZvcnRyYW4vQ2hhbmdlTG9nOgoKMjAxNS0wMy0wNCAgQW5kcmUgVmVo cmVzY2hpbGQgIDx2ZWhyZUBnbXguZGU+CgoJKiBleHByLmMgKGdmY19sdmFs X2V4cHJfZnJvbV9zeW0pOiBDb2RlIHRvIHNlbGVjdCB0aGUgcmVndWxhciAK CW9yIGNsYXNzIGFycmF5IGFkZGVkLgoJKiBnZm9ydHJhbi5oOiBBZGRlZCBJ U19DTEFTU19BUlJBWSBtYWNyby4KCSogdHJhbnMtYXJyYXkuYyAoZ2ZjX2Fk ZF9sb29wX3NzX2NvZGUpOiBUcmVhdCBjbGFzcyBvYmplY3RzCglhbHdheXMg dG8gYmUgcmVmZXJlbmNlZC4KCShidWlsZF9jbGFzc19hcnJheV9yZWYpOiBB ZGFwdCByZXRyaWV2YWwgb2YgYXJyYXkgZGVzY3JpcHRvci4KCShidWlsZF9h cnJheV9yZWYpOiBTYW1lLgoJKGdmY190cmFuc19hcnJheV9jb2JvdW5kcyk6 IFNlbGVjdCBjb3JyZWN0IGdmY19hcnJheV9zcGVjIGZvcgoJcmVndWxhciBh bmQgY2xhc3MgYXJyYXlzLgoJKGdmY190cmFuc19hcnJheV9ib3VuZHMpOiBT YW1lLgoJKGdmY190cmFuc19kdW1teV9hcnJheV9iaWFzKTogU2FtZS4KCShn ZmNfY29udl9leHByX2Rlc2NyaXB0b3IpOiBTZXQgdGhlIGFycmF5J3Mgb2Zm c2V0IHRvIC0xIHdoZW4KCWxib3VuZCBpbiBpbm5lciBtb3N0IGRpbSBpcyAx IGFuZCBzeW1ib2wgbm9uLXBvaW50ZXIvYXNzb2MuCgkqIHRyYW5zLWRlY2wu YyAoZ2ZjX2J1aWxkX3F1YWxpZmllZF9hcnJheSk6IFNlbGVjdCBjb3JyZWN0 IAoJZ2ZjX2FycmF5X3NwZWMgZm9yIHJlZ3VsYXIgYW5kIGNsYXNzIGFycmF5 cy4KCShnZmNfYnVpbGRfZHVtbXlfYXJyYXlfZGVjbCk6IFNhbWUuCgkoZ2Zj X2dldF9zeW1ib2xfZGVjbCk6IEdldCBhIGR1bW15IGFycmF5IGZvciBjbGFz cyBhcnJheXMsIHRvby4KCShnZmNfdHJhbnNfZGVmZXJyZWRfdmFycyk6IFRl bGwgY29udl9leHByIHRoYXQgdGhlIGRlc2NyaXB0b3IgCglpcyBkZXNpcmVk LgoJKiB0cmFucy1leHByLmMgKGdmY19jbGFzc192cHRyX2dldCk6IEdldCB0 aGUgY2xhc3MgZGVzY3JpcHRvcgoJZnJvbSB0aGUgY29ycmVjdCBsb2NhdGlv biBmb3IgY2xhc3MgYXJyYXlzLgoJKGdmY19jbGFzc19sZW5fZ2V0KTogU2Ft ZS4gCgkoZ2ZjX2NvbnZfY2xhc3NfdG9fY2xhc3MpOiBQcmV2ZW50IGFjY2Vz cyB0byB1bnNldCBhcnJheSBkYXRhIAoJd2hlbiB0aGUgYXJyYXkgaXMgYW4g b3B0aW9uYWwgYXJndW1lbnQuCgkoZ2ZjX3RyYW5zX2NsYXNzX2luaXRfYXNz aWduKTogRW5zdXJlIHRoYXQgdGhlIHJhbmsgb2YgCglfZGVmX2luaXQgaXMg emVyby4KCShnZmNfY29udl92YXJpYWJsZSk6IE1ha2Ugc3VyZSB0aGUgdGVt cCBhcnJheSBkZXNjcmlwdG9yIGlzCiAgICAgICAgcmV0dXJuZWQgZm9yIGNs YXNzIGFycmF5cywgdG9vLCBhbmQgdGhhdCBjbGFzcyBhcnJheXMgYXJlCiAg ICAgICAgZGVyZWZlcmVuY2VkIGNvcnJlY3RseS4KCShnZmNfY29udl9wcm9j ZWR1cmVfY2FsbCk6IEZvciBwb2x5bW9ycGhpYyB0eXBlIGluaXRpYWxpemF0 aW9uCgl0aGUgaW5pdGlhbGl6ZXIgaGFzIHRvIGJlIGEgcG9pbnRlciB0byBf ZGVmX2luaXQgc3RvcmVkIGluIGEKCWR1bW15IHZhcmlhYmxlLCB3aGljaCB0 aGVuIG5lZWRzIHRvIGJlIHVzZWQgYnkgdmFsdWUuCgkqIHRyYW5zLWludHJp bnNpYy5jIChnZmNfY29udl9pbnRyaW5zaWNfc2l6ZW9mKTogVXNlIHRoZSAK CXRlbXBvcmFyeSBhcnJheSBkZXNjcmlwdG9yIGZvciBjbGFzcyBhcnJheXMs IHRvby4KCShnZmNfY29udl9pbnRyaW5zaWNfc3RvcmFnZV9zaXplKTogU2Ft ZS4KCSogdHJhbnMtc3RtdC5jICh0cmFuc19hc3NvY2lhdGVfdmFyKTogVXNl IGEgdGVtcG9yYXJ5IGFycmF5IGZvcgoJdGhlIGFzc29jaWF0ZSB2YXJpYWJs ZSBvZiBjbGFzcyBhcnJheXMsIHRvbywgbWFraW5nIHRoZSBhcnJheQoJb25l LWJhc2VkIChsYm91bmQgPT0gMSkuCgkqIHRyYW5zLXR5cGVzLmMgKGdmY19p c19ub2Rlc2NfYXJyYXkpOiBVc2UgdGhlIGNvcnJlY3QgCglhcnJheSBkYXRh LgoJKiB0cmFucy5jIChnZmNfYnVpbGRfYXJyYXlfcmVmKTogVXNlIHRoZSBk dW1teSBhcnJheSBkZXNjcmlwdG9yCgl3aGVuIHByZXNlbnQuCgpnY2MvdGVz dHN1aXRlL0NoYW5nZUxvZzoKCjIwMTUtMDMtMDQgIEFuZHJlIFZlaHJlc2No aWxkICA8dmVocmVAZ214LmRlPgoKCSogZ2ZvcnRyYW4uZGcvY2xhc3NfYXJy YXlfMjAuZjAzOiBOZXcgdGVzdC4KCSogZ2ZvcnRyYW4uZGcvZmluYWxpemVf MTAuZjkwOiBDb3JyZWN0ZWQgc2NhbiB0cmVlIGV4cHJlc3Npb25zCgl0byBj b3BlIHdpdGggdGVtcG9yYXJ5IGFycmF5IGhhbmRsZXMgZm9yIGNsYXNzIGFy cmF5cy4KCSogZ2ZvcnRyYW4uZGcvZmluYWxpemVfMTUuZjkwOiBGaXhpbmcg Y29tcGFyaXNpb24gdG8gbW9kZWwgCglpbml0aWFsaXphdGlvbiBjb3JyZWN0 bHkuCgkqIGdmb3J0cmFuLmRnL2ZpbmFsaXplXzI5LmYwODogTmV3IHRlc3Qu CgoK --MP_/c8ythEJv_7UCpX_V=dpIksz Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr60322_2.patch Content-length: 42485 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d28cf77..7f3a59d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4060,7 +4060,7 @@ gfc_lval_expr_from_sym (gfc_symbol *sym) lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); /* It will always be a full array. */ - as = sym->as; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; lval->rank = as ? as->rank : 0; if (lval->rank) gfc_add_full_array_ref (lval, as); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ff0054e..f55c691 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3198,6 +3198,11 @@ bool gfc_is_finalizable (gfc_symbol *, gfc_expr **); && CLASS_DATA (sym) \ && CLASS_DATA (sym)->ts.u.derived \ && CLASS_DATA (sym)->ts.u.derived->attr.unlimited_polymorphic) +#define IS_CLASS_ARRAY(sym) \ + (sym->ts.type == BT_CLASS \ + && CLASS_DATA (sym) \ + && CLASS_DATA (sym)->attr.dimension \ + && !CLASS_DATA (sym)->attr.class_pointer) /* frontend-passes.c */ diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0d4d7b2..22fc7c7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2495,11 +2495,14 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, case GFC_SS_REFERENCE: /* Scalar argument to elemental procedure. */ gfc_init_se (&se, NULL); - if (ss_info->can_be_null_ref) + if (ss_info->can_be_null_ref || (expr->symtree + && (expr->symtree->n.sym->ts.type == BT_DERIVED + || expr->symtree->n.sym->ts.type == BT_CLASS))) { /* If the actual argument can be absent (in other words, it can be a NULL reference), don't try to evaluate it; pass instead - the reference directly. */ + the reference directly. The reference is also needed when + expr is of type class or derived. */ gfc_conv_expr_reference (&se, expr); } else @@ -3046,7 +3049,14 @@ build_class_array_ref (gfc_se *se, tree base, tree index) return false; } else if (class_ref == NULL) - decl = expr->symtree->n.sym->backend_decl; + { + decl = expr->symtree->n.sym->backend_decl; + /* For class arrays the tree containing the class is stored in + GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. + For all others it's sym's backend_decl directly. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + } else { /* Remove everything after the last class reference, convert the @@ -3159,26 +3169,41 @@ build_array_ref (tree desc, tree offset, tree decl) { tree tmp; tree type; + tree cdecl; + bool classarray = false; + + /* For class arrays the class declaration is stored in the saved + descriptor. */ + if (INDIRECT_REF_P (desc) + && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) + && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) + cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( + TREE_OPERAND (desc, 0))); + else + cdecl = desc; /* Class container types do not always have the GFC_CLASS_TYPE_P but the canonical type does. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && TREE_CODE (desc) == COMPONENT_REF) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl)) + && TREE_CODE (cdecl) == COMPONENT_REF) { - type = TREE_TYPE (TREE_OPERAND (desc, 0)); + type = TREE_TYPE (TREE_OPERAND (cdecl, 0)); if (TYPE_CANONICAL (type) && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) - type = TYPE_CANONICAL (type); + { + type = TREE_TYPE (desc); + classarray = true; + } } else type = NULL; /* Class array references need special treatment because the assigned type size needs to be used to point to the element. */ - if (type && GFC_CLASS_TYPE_P (type)) + if (classarray) { - type = gfc_get_element_type (TREE_TYPE (desc)); - tmp = TREE_OPERAND (desc, 0); + type = gfc_get_element_type (type); + tmp = TREE_OPERAND (cdecl, 0); tmp = gfc_get_class_array_ref (offset, tmp); tmp = fold_convert (build_pointer_type (type), tmp); tmp = build_fold_indirect_ref_loc (input_location, tmp); @@ -5568,7 +5593,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, gfc_se se; gfc_array_spec *as; - as = sym->as; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; for (dim = as->rank; dim < as->rank + as->corank; dim++) { @@ -5611,7 +5636,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, int dim; - as = sym->as; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; size = gfc_index_one_node; offset = gfc_index_zero_node; @@ -5899,12 +5924,14 @@ 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); /* Do nothing for pointer and allocatable arrays. */ - if (sym->attr.pointer || sym->attr.allocatable) + if (sym->attr.pointer || sym->attr.allocatable + || (is_classarray && CLASS_DATA (sym)->attr.allocatable)) return; - if (sym->attr.dummy && gfc_is_nodesc_array (sym)) + if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym)) { gfc_trans_g77_array (sym, block); return; @@ -5917,8 +5944,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, type = TREE_TYPE (tmpdesc); gcc_assert (GFC_ARRAY_TYPE_P (type)); dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); - as = sym->as; + if (is_classarray) + /* For a class array the dummy array descriptor is in the _class + component. */ + dumdesc = gfc_class_data_get (dumdesc); + else + dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER @@ -6789,6 +6821,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) tree from; tree to; tree base; + bool onebased = false; ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; @@ -6930,6 +6963,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_array_index_type, to, tmp); from = gfc_index_one_node; } + onebased = integer_onep (from); gfc_conv_descriptor_lbound_set (&loop.pre, parm, gfc_rank_cst[dim], from); @@ -6986,13 +7020,27 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_get_dataptr_offset (&loop.pre, parm, desc, offset, subref_array_target, expr); - if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - && !se->data_not_needed) - || (se->use_offset && base != NULL_TREE)) + /* Force the offset to be -1, when the lower bound of the highest + dimension is one and the symbol is present and is not a + pointer/allocatable or associated. */ + if (onebased && se->use_offset + && expr->symtree + && !expr->symtree->n.sym->attr.allocatable + && !expr->symtree->n.sym->attr.pointer + && !expr->symtree->n.sym->attr.host_assoc + && !expr->symtree->n.sym->attr.use_assoc) { - /* Set the offset. */ - gfc_conv_descriptor_offset_set (&loop.pre, parm, base); + /* Set the offset to -1. */ + mpz_t minus_one; + mpz_init_set_si (minus_one, -1); + tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind); + gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); } + else if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + && !se->data_not_needed) + || (se->use_offset && base != NULL_TREE)) + /* Set the offset depending on base. */ + gfc_conv_descriptor_offset_set (&loop.pre, parm, base); else { /* Only the callee knows what the correct offset it, so just set diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index e571a17..64bdb11 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -813,10 +813,11 @@ 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); type = TREE_TYPE (decl); - array_attr = &sym->attr; - as = sym->as; + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; /* We just use the descriptor, if there is one. */ if (GFC_DESCRIPTOR_TYPE_P (type)) @@ -1022,10 +1023,11 @@ 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); /* Use the array as and attr. */ - as = sym->as; - array_attr = &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; /* The pointer attribute is always set on a _data component, therefore check the sym's attribute only. */ @@ -1038,24 +1040,27 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) if (sym->attr.result || sym->attr.dummy) gfc_defer_symbol_init (sym); - type = TREE_TYPE (dummy); + /* For a class array the array descriptor is in the _data component, while + for a regular array the TREE_TYPE of the dummy is a pointer to the + descriptor. */ + type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy) + : TREE_TYPE (dummy)); + /* type now is the array descriptor w/o any indirection. */ gcc_assert (TREE_CODE (dummy) == PARM_DECL - && POINTER_TYPE_P (type)); + && POINTER_TYPE_P (TREE_TYPE (dummy))); /* Do we know the element size? */ known_size = sym->ts.type != BT_CHARACTER || INTEGER_CST_P (sym->ts.u.cl->backend_decl); - if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))) + if (known_size && !GFC_DESCRIPTOR_TYPE_P (type)) { /* For descriptorless arrays with known element size the actual argument is sufficient. */ - gcc_assert (GFC_ARRAY_TYPE_P (type)); gfc_build_qualified_array (dummy, sym); return dummy; } - type = TREE_TYPE (type); if (GFC_DESCRIPTOR_TYPE_P (type)) { /* Create a descriptorless array pointer. */ @@ -1089,7 +1094,10 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) packed = PACKED_PARTIAL; } - type = gfc_typenode_for_spec (&sym->ts); + /* For classarrays the element type is required, but + gfc_typenode_for_spec () returns the array descriptor. */ + type = is_classarray ? gfc_get_element_type (type) + : gfc_typenode_for_spec (&sym->ts); type = gfc_get_nodesc_array_type (type, as, packed, !sym->attr.target); } @@ -1439,13 +1447,30 @@ gfc_get_symbol_decl (gfc_symbol * sym) sym->backend_decl = decl; } + /* Returning the descriptor for dummy class arrays is hazardous, because + some caller is expecting an expression to apply the component refs to. + Therefore the descriptor is only created and stored in + sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller then is + responsible to extract it from there, when the descriptor is + desired. */ + if (IS_CLASS_ARRAY (sym) + && (!DECL_LANG_SPECIFIC (sym->backend_decl) + || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) + { + decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); + /* Prevent the dummy from being detected as unused if it is copied. */ + if (sym->backend_decl != NULL && decl != sym->backend_decl) + DECL_ARTIFICIAL (sym->backend_decl) = 1; + sym->backend_decl = decl; + } + TREE_USED (sym->backend_decl) = 1; if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) { gfc_add_assign_aux_vars (sym); } - if (sym->attr.dimension + if ((sym->attr.dimension || IS_CLASS_ARRAY (sym)) && DECL_LANG_SPECIFIC (sym->backend_decl) && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl) && DECL_CONTEXT (sym->backend_decl) != current_function_decl) @@ -3982,14 +4007,16 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp); TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1; } - else if (sym->attr.dimension || sym->attr.codimension) + else if (sym->attr.dimension || sym->attr.codimension + || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)) { + bool is_classarray = IS_CLASS_ARRAY (sym); symbol_attribute *array_attr; gfc_array_spec *as; array_type tmp; - array_attr = &sym->attr; - as = sym->as; + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */ tmp = as->type; if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed) @@ -4119,6 +4146,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else { + se.descriptor_only = 1; gfc_conv_expr (&se, e); descriptor = se.expr; se.expr = gfc_conv_descriptor_data_addr (se.expr); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index db04b30..123011f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -149,6 +149,11 @@ tree gfc_class_vptr_get (tree decl) { tree vptr; + /* For class arrays decl may be a temporary array handle, the vptr then is + available through the saved descriptor. */ + if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) decl = build_fold_indirect_ref_loc (input_location, decl); vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), @@ -163,6 +168,11 @@ tree gfc_class_len_get (tree decl) { tree len; + /* For class arrays decl may be a temporary array handle, the vptr then is + available through the saved descriptor. */ + if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) decl = build_fold_indirect_ref_loc (input_location, decl); len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), @@ -798,7 +808,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = NULL_TREE; if (class_ref == NULL && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) - tmp = e->symtree->n.sym->backend_decl; + { + tmp = e->symtree->n.sym->backend_decl; + if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) + tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); + } else { /* Remove everything after the last class reference, convert the @@ -833,6 +847,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tree tmp2; cond = gfc_conv_expr_present (e->symtree->n.sym); + /* parmse->pre may contain some temporary array instructions. Those must + only be executed when the optional argument is set, therefore add them + to block. */ + gfc_add_block_to_block (&parmse->pre, &block); + block.head = parmse->pre.head; + parmse->pre.head = NULL_TREE; tmp = gfc_finish_block (&block); if (optional_alloc_ptr) @@ -1039,6 +1059,8 @@ gfc_trans_class_init_assign (gfc_code *code) been referenced. */ gfc_get_derived_type (rhs->ts.u.derived); gfc_add_def_init_component (rhs); + /* The _def_init is always scalar. */ + rhs->rank = 0; if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->attr.dimension) @@ -2037,8 +2059,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) bool return_value; bool alternate_entry; bool entry_master; + bool is_classarray; + bool first_time = true; sym = expr->symtree->n.sym; + is_classarray = IS_CLASS_ARRAY (sym); ss = se->ss; if (ss != NULL) { @@ -2142,9 +2167,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) } else if (!sym->attr.value) { + /* Dereference temporaries for class array dummy arguments. */ + if (sym->attr.dummy && is_classarray + && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))) + { + if (!se->descriptor_only) + se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr); + + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); + } + /* Dereference non-character scalar dummy arguments. */ if (sym->attr.dummy && !sym->attr.dimension - && !(sym->attr.codimension && sym->attr.allocatable)) + && !(sym->attr.codimension && sym->attr.allocatable) + && (sym->ts.type != BT_CLASS + || (!CLASS_DATA (sym)->attr.dimension + && !(CLASS_DATA (sym)->attr.codimension + && CLASS_DATA (sym)->attr.allocatable)))) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); @@ -2156,11 +2196,12 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Dereference non-character pointer variables. + /* Dereference non-character, non-class pointer variables. These must be dummies, results, or scalars. */ - if ((sym->attr.pointer || sym->attr.allocatable - || gfc_is_associate_pointer (sym) - || (sym->as && sym->as->type == AS_ASSUMED_RANK)) + if (!is_classarray + && (sym->attr.pointer || sym->attr.allocatable + || gfc_is_associate_pointer (sym) + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) && (sym->attr.dummy || sym->attr.function || sym->attr.result @@ -2168,6 +2209,32 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && (!sym->attr.codimension || !sym->attr.allocatable)))) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + /* Now treat the class array pointer variables accordingly. */ + else if (sym->ts.type == BT_CLASS + && sym->attr.dummy + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && ((CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer)) + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); + /* And the case where a non-dummy, non-result, non-function, + non-allotable and non-pointer classarray is present. This case was + previously covered by the first if, but with introducing the + check non-classarray falls out there and has to be covered here + explicilty. */ + else if (sym->ts.type == BT_CLASS + && !sym->attr.dummy + && !sym->attr.function + && !sym->attr.result + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && !CLASS_DATA (sym)->attr.allocatable + && !CLASS_DATA (sym)->attr.class_pointer) + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } ref = expr->ref; @@ -2205,6 +2272,18 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) break; case REF_COMPONENT: + 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 + && 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 + arrays that one is already done by introducing a temporary + array descriptor. */ + break; + if (ref->u.c.sym->attr.extension) conv_parent_component_references (se, ref); @@ -2224,6 +2303,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) gcc_unreachable (); break; } + first_time = false; ref = ref->next; } /* Pointer assignment, allocation or pass by reference. Arrays are handled @@ -4350,7 +4430,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_se (&parmse, se); parm_kind = ELEMENTAL; - if (fsym && fsym->attr.value) + /* For all value functions or polymorphic scalar non-pointer + non-allocatable variables use the expression in e directly. This + ensures, that initializers of polymorphic entities are correctly + copied. */ + if (fsym && (fsym->attr.value + || (e->expr_type == EXPR_VARIABLE + && fsym->ts.type == BT_DERIVED + && e->ts.type == BT_DERIVED + && !e->ts.u.derived->attr.dimension + && !e->rank + && (!e->symtree + || (!e->symtree->n.sym->attr.allocatable + && !e->symtree->n.sym->attr.pointer))))) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 9ca46ef..c899a73 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5863,8 +5863,15 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) } else if (arg->ts.type == BT_CLASS) { - if (arg->rank) + /* For deferred length arrays, conv_expr_descriptor returns an + indirect_ref to the component. */ + if (arg->rank < 0) byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0)); + else if (arg->rank > 0) + /* The scalarizer added an additional temp. To get the class' vptr + one has to look at the original backend_decl. */ + byte_size = gfc_vtable_size_get ( + GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); else byte_size = gfc_vtable_size_get (argse.expr); } @@ -5995,7 +6002,11 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) gfc_conv_expr_descriptor (&argse, arg); if (arg->ts.type == BT_CLASS) { - tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0)); + if (arg->rank > 0) + tmp = gfc_vtable_size_get ( + GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); + else + tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0)); tmp = fold_convert (result_type, tmp); goto done; } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 505f905..d393a14 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1276,12 +1276,29 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_init_se (&se, NULL); se.descriptor_only = 1; - gfc_conv_expr (&se, e); + /* In a select type the (temporary) associate variable shall point to + a standart fortran array (lower bound == 1), but conv_expr () + just maps to the input array in the class object, whose lbound may + be arbitrary. conv_expr_descriptor solves this by inserting a + temporary array. */ + gfc_conv_expr_descriptor (&se, e); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) + || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); - gfc_add_modify (&se.pre, sym->backend_decl, se.expr); + if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))) + { + if (INDIRECT_REF_P (se.expr)) + tmp = TREE_OPERAND (se.expr, 0); + else + tmp = se.expr; + + gfc_add_modify (&se.pre, sym->backend_decl, + gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp))); + } + else + gfc_add_modify (&se.pre, sym->backend_decl, se.expr); if (unlimited) { @@ -1292,7 +1309,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_get_dtype (TREE_TYPE (sym->backend_decl))); } - gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), gfc_finish_block (&se.post)); } @@ -1335,9 +1352,18 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) } if (need_len_assign) { - /* Get the _len comp from the target expr by stripping _data - from it and adding component-ref to _len. */ - tmp = gfc_class_len_get (TREE_OPERAND (target_expr, 0)); + if (e->symtree + && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl) + && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)) + /* Use the original class descriptor stored in the saved + descriptor to get the target_expr. */ + target_expr = + GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl); + else + /* Strip the _data component from the target_expr. */ + target_expr = TREE_OPERAND (target_expr, 0); + /* Add a reference to the _len comp to the target expr. */ + tmp = gfc_class_len_get (target_expr); /* Get the component-ref for the temp structure's _len comp. */ charlen = gfc_class_len_get (se.expr); /* Add the assign to the beginning of the the block... */ diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index bce4d24..1b613c2 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1290,9 +1290,10 @@ gfc_is_nodesc_array (gfc_symbol * sym) { symbol_attribute *array_attr; gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); - array_attr = &sym->attr; - as = sym->as; + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; gcc_assert (array_attr->dimension || array_attr->codimension); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index b749783..fe16059 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -362,16 +362,23 @@ gfc_build_array_ref (tree base, tree offset, tree decl) { if (GFC_DECL_CLASS (decl)) { - /* Allow for dummy arguments and other good things. */ - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Check if '_data' is an array descriptor. If it is not, - the array must be one of the components of the class object, - so return a normal array reference. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) - return build4_loc (input_location, ARRAY_REF, type, base, - offset, NULL_TREE, NULL_TREE); + /* When a temporary is in place for the class array, then the original + class' declaration is stored in the saved descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class object, + so return a normal array reference. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) + return build4_loc (input_location, ARRAY_REF, type, base, + offset, NULL_TREE, NULL_TREE); + } span = gfc_vtable_size_get (decl); } diff --git a/gcc/testsuite/gfortran.dg/class_array_20.f03 b/gcc/testsuite/gfortran.dg/class_array_20.f03 new file mode 100644 index 0000000..c49f7d2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_array_20.f03 @@ -0,0 +1,100 @@ +! {dg-do run} +! +! Test contributed by Thomas L. Clune via pr60322 +! and Antony Lewis via pr64692 + +program class_array_20 + implicit none + + type Foo + end type + + type(foo), dimension(2:3) :: arg + integer :: oneDarr(2) + integer :: twoDarr(2,3) + integer :: x, y + double precision :: P(2, 2) + + ! Checking for PR/60322 + call copyFromClassArray([Foo(), Foo()]) + call copyFromClassArray(arg) + call copyFromClassArray(arg(:)) + + x= 3 + y= 4 + oneDarr = [x, y] + call W([x, y]) + call W(oneDarr) + call W([3, 4]) + + twoDarr = reshape([3, 4, 5, 5, 6, 7], [2, 3]) + call WtwoD(twoDarr) + call WtwoD(reshape([3, 4, 5, 5, 6, 7], [2, 3])) + + ! Checking for PR/64692 + P(1:2, 1) = [1.d0, 2.d0] + P(1:2, 2) = [3.d0, 4.d0] + call AddArray(P(1:2, 2)) + +contains + + subroutine copyFromClassArray(classarray) + class (Foo), intent(in) :: classarray(:) + + if (lbound(classarray, 1) .ne. 1) call abort() + if (ubound(classarray, 1) .ne. 2) call abort() + if (size(classarray) .ne. 2) call abort() + end subroutine + + subroutine AddArray(P) + class(*), target, intent(in) :: P(:) + class(*), pointer :: Pt(:) + + allocate(Pt(1:size(P)), source= P) + + select type (P) + type is (double precision) + if (abs(P(1)-3.d0) .gt. 1.d-8) call abort() + if (abs(P(2)-4.d0) .gt. 1.d-8) call abort() + class default + call abort() + end select + + select type (Pt) + type is (double precision) + if (abs(Pt(1)-3.d0) .gt. 1.d-8) call abort() + if (abs(Pt(2)-4.d0) .gt. 1.d-8) call abort() + class default + call abort() + end select + end subroutine + + subroutine W(ar) + class(*), intent(in) :: ar(:) + + if (lbound(ar, 1) /= 1) call abort() + select type (ar) + type is (integer) + ! The indeces 1:2 are essential here, or else one would not + ! note, that the array internally starts at 0, although the + ! check for the lbound above went fine. + if (any (ar(1:2) .ne. [3, 4])) call abort() + class default + call abort() + end select + end subroutine + + subroutine WtwoD(ar) + class(*), intent(in) :: ar(:,:) + + if (any (lbound(ar) /= [1, 1])) call abort() + select type (ar) + type is (integer) + if (any (reshape(ar(1:2,1:3), [6]) .ne. [3, 4, 5, 5, 6, 7])) & + call abort() + class default + call abort() + end select + end subroutine +end program class_array_20 + diff --git a/gcc/testsuite/gfortran.dg/finalize_10.f90 b/gcc/testsuite/gfortran.dg/finalize_10.f90 index e042f11..32386ce 100644 --- a/gcc/testsuite/gfortran.dg/finalize_10.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_10.f90 @@ -27,8 +27,8 @@ end subroutine foo ! Finalize CLASS + set default init ! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\((unsigned long|unsigned int|character\\(kind=4\\))\\) y->_vptr->_size\\);" "original" } } -! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&parm.\[0-9\]+, x->_vptr->_size, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(" 1 "original" } } ! FINALIZE TYPE: ! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_15.f90 b/gcc/testsuite/gfortran.dg/finalize_15.f90 index 3c18b2a..d5ba28f 100644 --- a/gcc/testsuite/gfortran.dg/finalize_15.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_15.f90 @@ -9,37 +9,37 @@ module m implicit none type t1 - integer :: i + integer :: i = 1 contains final :: fini_elem end type t1 type, extends(t1) :: t1e - integer :: j + integer :: j = 11 contains final :: fini_elem2 end type t1e type t2 - integer :: i + integer :: i = 2 contains final :: fini_shape end type t2 type, extends(t2) :: t2e - integer :: j + integer :: j = 22 contains final :: fini_shape2 end type t2e type t3 - integer :: i + integer :: i = 3 contains final :: fini_explicit end type t3 type, extends(t3) :: t3e - integer :: j + integer :: j = 33 contains final :: fini_explicit2 end type t3e @@ -204,31 +204,31 @@ program test select type(x) type is (t1e) - call check_val(x%i, 1) - call check_val(x%j, 100) + call check_val(x%i, 1, 1) + call check_val(x%j, 100, 11) end select select type(y) type is (t2e) - call check_val(y%i, 1) - call check_val(y%j, 100) + call check_val(y%i, 1, 2) + call check_val(y%j, 100, 22) end select select type(z) type is (t3e) - call check_val(z%i, 1) - call check_val(z%j, 100) + call check_val(z%i, 1, 3) + call check_val(z%j, 100, 33) end select contains - subroutine check_val(x, factor) + subroutine check_val(x, factor, val) integer :: x(:,:) - integer, value :: factor + integer, value :: factor, val integer :: i, j do i = 1, 10 do j = 1, 10 if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then - if (x(j,i) /= (j + 100*i)*factor*(-13)) call abort () + if (x(j,i) /= val) call abort () else if (x(j,i) /= (j + 100*i)*factor) call abort () end if diff --git a/gcc/testsuite/gfortran.dg/finalize_29.f08 b/gcc/testsuite/gfortran.dg/finalize_29.f08 new file mode 100644 index 0000000..1f5f7424 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_29.f08 @@ -0,0 +1,289 @@ +! {dg-do run} +! +! Testcase contributed by Andre Vehreschild + +module module_finalize_29 + implicit none + + ! The type name is encoding the state of its finalizer being + ! elemental (second letter 'e'), or non-element (second letter 'n') + ! or array shaped (second letter 'a'), or shape-specific routine + ! (generic; second letter 'g'), + ! and whether the init-routine is elemental or not (third letter + ! either 'e' or 'n'). + type ten + integer :: i = 40 + contains + final :: ten_fin + end type ten + + type tee + integer :: i = 41 + contains + final :: tee_fin + end type tee + + type tne + integer :: i = 42 + contains + final :: tne_fin + end type tne + + type tnn + integer :: i = 43 + contains + final :: tnn_fin + end type tnn + + type tae + integer :: i = 44 + contains + final :: tae_fin + end type tae + + type tan + integer :: i = 45 + contains + final :: tan_fin + end type tan + + type tge + integer :: i = 46 + contains + final :: tge_scalar_fin, tge_array_fin + end type tge + + type tgn + integer :: i = 47 + contains + final :: tgn_scalar_fin, tgn_array_fin + end type tgn + + integer :: ten_fin_counts, tee_fin_counts, tne_fin_counts, tnn_fin_counts + integer :: tae_fin_counts, tan_fin_counts + integer :: tge_scalar_fin_counts, tge_array_fin_counts + integer :: tgn_scalar_fin_counts, tgn_array_fin_counts +contains + impure elemental subroutine ten_fin(x) + type(ten), intent(inout) :: x + x%i = -10 * x%i + ten_fin_counts = ten_fin_counts + 1 + end subroutine ten_fin + + impure elemental subroutine tee_fin(x) + type(tee), intent(inout) :: x + x%i = -11 * x%i + tee_fin_counts = tee_fin_counts + 1 + end subroutine tee_fin + + subroutine tne_fin(x) + type(tne), intent(inout) :: x + x%i = -12 * x%i + tne_fin_counts = tne_fin_counts + 1 + end subroutine tne_fin + + subroutine tnn_fin(x) + type(tnn), intent(inout) :: x + x%i = -13 * x%i + tnn_fin_counts = tnn_fin_counts + 1 + end subroutine tnn_fin + + subroutine tae_fin(x) + type(tae), intent(inout) :: x(:,:) + x%i = -14 * x%i + tae_fin_counts = tae_fin_counts + 1 + end subroutine tae_fin + + subroutine tan_fin(x) + type(tan), intent(inout) :: x(:,:) + x%i = -15 * x%i + tan_fin_counts = tan_fin_counts + 1 + end subroutine tan_fin + + subroutine tge_scalar_fin(x) + type(tge), intent(inout) :: x + x%i = -16 * x%i + tge_scalar_fin_counts = tge_scalar_fin_counts + 1 + end subroutine tge_scalar_fin + + subroutine tge_array_fin(x) + type(tge), intent(inout) :: x(:,:) + x%i = -17 * x%i + tge_array_fin_counts = tge_array_fin_counts + 1 + end subroutine tge_array_fin + + subroutine tgn_scalar_fin(x) + type(tgn), intent(inout) :: x + x%i = -18 * x%i + tgn_scalar_fin_counts = tgn_scalar_fin_counts + 1 + end subroutine tgn_scalar_fin + + subroutine tgn_array_fin(x) + type(tgn), intent(inout) :: x(:,:) + x%i = -19 * x%i + tgn_array_fin_counts = tgn_array_fin_counts + 1 + end subroutine tgn_array_fin + + ! The finalizer/initializer call producer + subroutine ten_init(x) + class(ten), intent(out) :: x(:,:) + end subroutine ten_init + + impure elemental subroutine tee_init(x) + class(tee), intent(out) :: x + end subroutine tee_init + + impure elemental subroutine tne_init(x) + class(tne), intent(out) :: x + end subroutine tne_init + + subroutine tnn_init(x) + class(tnn), intent(out) :: x(:,:) + end subroutine tnn_init + + impure elemental subroutine tae_init(x) + class(tae), intent(out) :: x + end subroutine tae_init + + subroutine tan_init(x) + class(tan), intent(out) :: x(:,:) + end subroutine tan_init + + impure elemental subroutine tge_init(x) + class(tge), intent(out) :: x + end subroutine tge_init + + subroutine tgn_init(x) + class(tgn), intent(out) :: x(:,:) + end subroutine tgn_init +end module module_finalize_29 + +program finalize_29 + use module_finalize_29 + implicit none + + type(ten), allocatable :: x_ten(:,:) + type(tee), allocatable :: x_tee(:,:) + type(tne), allocatable :: x_tne(:,:) + type(tnn), allocatable :: x_tnn(:,:) + type(tae), allocatable :: x_tae(:,:) + type(tan), allocatable :: x_tan(:,:) + type(tge), allocatable :: x_tge(:,:) + type(tgn), allocatable :: x_tgn(:,:) + + ! Set the global counts to zero. + ten_fin_counts = 0 + tee_fin_counts = 0 + tne_fin_counts = 0 + tnn_fin_counts = 0 + tae_fin_counts = 0 + tan_fin_counts = 0 + tge_scalar_fin_counts = 0 + tge_array_fin_counts = 0 + tgn_scalar_fin_counts = 0 + tgn_array_fin_counts = 0 + + allocate(ten :: x_ten(5,5)) + allocate(tee :: x_tee(5,5)) + allocate(tne :: x_tne(5,5)) + allocate(tnn :: x_tnn(5,5)) + allocate(tae :: x_tae(5,5)) + allocate(tan :: x_tan(5,5)) + allocate(tge :: x_tge(5,5)) + allocate(tgn :: x_tgn(5,5)) + + x_ten%i = 1 + x_tee%i = 2 + x_tne%i = 3 + x_tnn%i = 4 + x_tae%i = 5 + x_tan%i = 6 + x_tge%i = 7 + x_tgn%i = 8 + + call ten_init(x_ten(::2, ::3)) + + if (ten_fin_counts /= 6) call abort() + if (tee_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + ten_fin_counts = 0 + + call tee_init(x_tee(::2, ::3)) + + if (tee_fin_counts /= 6) call abort() + if (ten_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + tee_fin_counts = 0 + + call tne_init(x_tne(::2, ::3)) + + if (tne_fin_counts /= 6) call abort() + if (ten_fin_counts + tee_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + tne_fin_counts = 0 + + call tnn_init(x_tnn(::2, ::3)) + + if (tnn_fin_counts /= 0) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + + call tae_init(x_tae(::2, ::3)) + + if (tae_fin_counts /= 0) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + + call tan_init(x_tan(::2, ::3)) + + if (tan_fin_counts /= 1) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + tan_fin_counts = 0 + + call tge_init(x_tge(::2, ::3)) + + if (tge_scalar_fin_counts /= 6) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tan_fin_counts + tgn_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + tge_scalar_fin_counts = 0 + + call tgn_init(x_tgn(::2, ::3)) + + if (tgn_array_fin_counts /= 1) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tan_fin_counts + tge_scalar_fin_counts + & + tge_array_fin_counts + tgn_scalar_fin_counts /= 0) call abort() + tgn_array_fin_counts = 0 + + if (any (reshape (x_ten%i, [25]) /= [[40, 1, 40, 1, 40], [1, 1, 1, 1, 1],& + [1, 1, 1, 1, 1], [40, 1, 40, 1, 40], [1, 1, 1, 1, 1]])) call abort() + + if (any (reshape (x_tee%i, [25]) /= [[41, 2, 41, 2, 41], [2, 2, 2, 2, 2],& + [2, 2, 2, 2, 2], [41, 2, 41, 2, 41], [2, 2, 2, 2, 2]])) call abort() + + if (any (reshape (x_tne%i, [25]) /= [[42, 3, 42, 3, 42], [3, 3, 3, 3, 3],& + [3, 3, 3, 3, 3], [42, 3, 42, 3, 42], [3, 3, 3, 3, 3]])) call abort() + + if (any (reshape (x_tnn%i, [25]) /= [[43, 4, 43, 4, 43], [4, 4, 4, 4, 4],& + [4, 4, 4, 4, 4], [43, 4, 43, 4, 43], [4, 4, 4, 4, 4]])) call abort() + + if (any (reshape (x_tae%i, [25]) /= [[44, 5, 44, 5, 44], [5, 5, 5, 5, 5],& + [5, 5, 5, 5, 5], [44, 5, 44, 5, 44], [5, 5, 5, 5, 5]])) call abort() + + if (any (reshape (x_tan%i, [25]) /= [[45, 6, 45, 6, 45], [6, 6, 6, 6, 6],& + [6, 6, 6, 6, 6], [45, 6, 45, 6, 45], [6, 6, 6, 6, 6]])) call abort() + + if (any (reshape (x_tge%i, [25]) /= [[46, 7, 46, 7, 46], [7, 7, 7, 7, 7],& + [7, 7, 7, 7, 7], [46, 7, 46, 7, 46], [7, 7, 7, 7, 7]])) call abort() + + if (any (reshape (x_tgn%i, [25]) /= [[47, 8, 47, 8, 47], [8, 8, 8, 8, 8],& + [8, 8, 8, 8, 8], [47, 8, 47, 8, 47], [8, 8, 8, 8, 8]])) call abort() +end program finalize_29 --MP_/c8ythEJv_7UCpX_V=dpIksz--