From patchwork Mon Oct 24 16:48:09 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 79006 Delivered-To: patch@linaro.org Received: by 10.140.97.247 with SMTP id m110csp2679480qge; Mon, 24 Oct 2016 09:48:43 -0700 (PDT) X-Received: by 10.99.0.196 with SMTP id 187mr6320451pga.78.1477327723358; Mon, 24 Oct 2016 09:48:43 -0700 (PDT) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id f188si16228530pfc.266.2016.10.24.09.48.43 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Mon, 24 Oct 2016 09:48:43 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-return-439440-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) client-ip=209.132.180.131; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org; spf=pass (google.com: domain of gcc-patches-return-439440-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-439440-patch=linaro.org@gcc.gnu.org DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; q=dns; s= default; b=tL0j2ej4GalnKC5VXw8r4ECvWtpkZH58i1sx4vB7TsNzwoUr9Nf8h xUOE0lJtZgEAipqPLARlqThCJH627uCeXrlXw1LRHgRNwcIriT9ThZrt/oOd2aZW 56riWRTdCT21+ZS/S+AosgHm1R9wzjMMqKYs4P+ClxK2+SxseFsHuQ= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; s= default; bh=p292vgQ6dPvY4/A3T29oTLj/9tQ=; b=cafSrFzmQyNBjO+h/WcF dANDnQQBmn0XPDBf+EQdBTgP6gJ1+4J6SrqxV7iKJMS1BWFHtxGTZhQJ/nsSvnJF bsCWa+8olkPZilIW+EKbrRZ8Qby4csnAjlCcRddl5kBnQQTej7zeDubIJ34nN4Jb iOVZqcI6RBGPF5NMo6bLR04= Received: (qmail 98171 invoked by alias); 24 Oct 2016 16:48:28 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 98151 invoked by uid 89); 24 Oct 2016 16:48:28 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.7 required=5.0 tests=AWL, BAYES_20, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 spammy=_size, sk:gfc_def, ith, gfc_current_ns 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 ESMTP; Mon, 24 Oct 2016 16:48:17 +0000 Received: from vepi2 ([84.63.206.51]) by mail.gmx.com (mrgmx003) with ESMTPSA (Nemesis) id 0M7pku-1cu6Kg1xj6-00vMvQ; Mon, 24 Oct 2016 18:48:10 +0200 Date: Mon, 24 Oct 2016 18:48:09 +0200 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Subject: [Fortran, patch, pr78053, v1] [OOP] SELECT TYPE on CLASS(*) component for deferred length char arrays ICEs for -O > 0 Message-ID: <20161024184809.470a1dc7@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:KyavpVTnQ6M=:wf1hfKiSBSYzD3sWh2Q0IL 4O6GcFyoHZ5t/q6xmBF/JthOedStofAXBoKNv5eCxy+gQodCxiooz3lqLwKkqYNXsiIITzC4e 3mbzSz0fNfaPhKFa7kNbxnppQbCpDh66lmAwg8/1aeG4Zg3WcMAFmLpEQegkAdSM1oRrofMAF hv5qRdSf3i2ofbISHLHvtpoZssLds4GtdUZhFlUv2L0q8l4NdaSs+zxR6gqnzLMGki1OvjXMx XDVJqeYgd5oHB/o8ofEHz1IymazBVJkElQDWDMy1Qz3ntrqc5nwUHrbsFxWlfK0jA1cgsUeFo K+TOqRFRbKH77DLJ9ggo4DK6uyfuvGNGLCniez8j1mnnbJh3k9X6LmVnigBOxReAm9A2xpMp/ bSegJBR87SZP3yuJYDxxzNsPCqyO9UdQvIIXSoIIvgMWet5Gp0fLcvuo92oAnrECIarUEH/fn yD8xSOcDNHaMjBf0v17jDFe6iXDiz8Tg9PIipxzHtmf2xFhBm3DyBoo8+ea+YwGWiJaPn4hnZ NyLV4K8n1fDTA+US1BM0E+gJEX6VQc8W5mffgTlI5NX6ZZcbv8Zi3lzgPbnFmhSGU5GeT+o8n GsgGdN2uCTP1KL5gGN86hcfn8oOwyRB2Zt0LZMJMq4dNVo2iPu1kZriMk2PXFhVHxA1kcEcXy f/YUNOVyMg/qIpL58bIgHabpC/oZyz+Tiovt+UZ0uJZlqPOjw30ydbLaPdo9AtSK8OfOLgwTe eLtm1QFQVGFvHWhyd2xDJlgiCejdmWeHUkWH6IOYywAr77qPc0eEArYGXhY= Hi all, attached patch fixes an ICE in gfortran when an unlimited polymorphic entity was used to store a char array of deferred/assumed length. The patch typedefs the necessary type now copying the behavior from trans-array.c::gfc_trans_create_temp_array(). Furthermore does the patch now consequently set the _vptr->_size to the character kind of the char array and the _len component to the length of the string independent of whether the char array was declared deferred or with a len given. Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de gcc/testsuite/ChangeLog: 2016-10-24 Andre Vehreschild PR fortran/78053 * gfortran.dg/alloc_comp_class_5.f03: Added test again that caused this pr. gcc/fortran/ChangeLog: 2016-10-24 Andre Vehreschild PR fortran/78053 * class.c (find_intrinsic_vtab): No longer encode the string length into vtype's name and use the char's kind for the size instead of the string_length time the size. * trans-array.c (gfc_conv_ss_descriptor): For deferred length char arrays the dynamically sized type needs to be declared. (build_class_array_ref): Address the i-th array element by multiplying it with the _vptr->_size and the _len to make sure char arrays are addressed correctly. * trans-expr.c (gfc_conv_intrinsic_to_class): Made comment more precise. diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 6ac543c..549cc91 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -2515,11 +2515,6 @@ find_intrinsic_vtab (gfc_typespec *ts) gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL; gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; - int charlen = 0; - - if (ts->type == BT_CHARACTER && !ts->deferred && ts->u.cl && ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT) - charlen = mpz_get_si (ts->u.cl->length->value.integer); /* Find the top-level namespace. */ for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -2530,12 +2525,10 @@ find_intrinsic_vtab (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; - if (ts->type == BT_CHARACTER) - sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), - charlen, ts->kind); - else - sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); - + /* Encode all type as TYPENAME_KIND_ including especially character + arrays, whose length is no consistently stored in the _len component + of the class-variable. */ + sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); sprintf (name, "__vtab_%s", tname); /* Look for the vtab symbol in the top-level namespace only. */ @@ -2600,9 +2593,8 @@ find_intrinsic_vtab (gfc_typespec *ts) c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, ts->type == BT_CHARACTER - && charlen == 0 ? - ts->kind : - (int)gfc_element_size (e)); + ? ts->kind + : (int)gfc_element_size (e)); gfc_free_expr (e); /* Add component _extends. */ diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c59e872..0d0bc38 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2681,6 +2681,20 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) if (base) { + if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred + && ss_info->expr->ts.u.cl->length == NULL) + { + /* Emit a DECL_EXPR for the variable sized array type in + GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type + sizes works correctly. */ + tree arraytype = TREE_TYPE ( + GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor))); + if (! TYPE_NAME (arraytype)) + TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, + NULL_TREE, arraytype); + gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype, + TYPE_NAME (arraytype))); + } /* Also the data pointer. */ tmp = gfc_conv_array_data (se.expr); /* If this is a variable or address of a variable we use it directly. @@ -3143,9 +3157,22 @@ build_class_array_ref (gfc_se *se, tree base, tree index) size = gfc_class_vtab_size_get (decl); + /* For unlimited polymorphic entities then _len component needs to be + multiplied with the size. If no _len component is present, then + gfc_class_len_or_zero_get () return a zero_node. */ + tmp = gfc_class_len_or_zero_get (decl); + if (!integer_zerop (tmp)) + size = fold_build2 (MULT_EXPR, TREE_TYPE (index), + fold_convert (TREE_TYPE (index), size), + fold_build2 (MAX_EXPR, TREE_TYPE (index), + fold_convert (TREE_TYPE (index), tmp), + fold_convert (TREE_TYPE (index), + integer_one_node))); + else + size = fold_convert (TREE_TYPE (index), size); + /* Build the address of the element. */ type = TREE_TYPE (TREE_TYPE (base)); - size = fold_convert (TREE_TYPE (index), size); offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, index, size); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index f1849f5..aababab 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -861,7 +861,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, { ctree = gfc_class_len_get (var); /* When the actual arg is a char array, then set the _len component of the - unlimited polymorphic entity, too. */ + unlimited polymorphic entity to the length of the string. */ if (e->ts.type == BT_CHARACTER) { /* Start with parmse->string_length because this seems to be set to a diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 index a2d7cce..f07ffa1 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 @@ -1,7 +1,7 @@ ! { dg-do run } ! ! Contributed by Vladimir Fuka -! Check that pr61337 is fixed. +! Check that pr61337 and pr78053, which was caused by this testcase, is fixed. module array_list @@ -39,8 +39,9 @@ program test_pr61337 call add_item(a_list, [1, 2]) call add_item(a_list, [3.0_8, 4.0_8]) call add_item(a_list, [.true., .false.]) + call add_item(a_list, ["foo", "bar", "baz"]) - if (size(a_list) /= 3) call abort() + if (size(a_list) /= 4) call abort() do i = 1, size(a_list) call checkarr(a_list(i)) end do @@ -60,6 +61,9 @@ contains if (any(x /= [3.0_8, 4.0_8])) call abort() type is (logical) if (any(x .neqv. [.true., .false.])) call abort() + type is (character(len=*)) + if (len(x) /= 3) call abort() + if (any(x /= ["foo", "bar", "baz"])) call abort() class default call abort() end select