From patchwork Sat Apr 22 08:32:30 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 1772240 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: legolas.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=PIqQt53/; dkim-atps=neutral Received: from sourceware.org (ip-8-43-85-97.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 (P-384) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4Q3PmZ59GBz23s0 for ; Sat, 22 Apr 2023 18:33:17 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 28A24385840C for ; Sat, 22 Apr 2023 08:33:13 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 28A24385840C DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1682152393; bh=PvxQF+KC1j3iDlhnTZ42TlL502lnw2RI4UmxTiUh0o8=; h=Date:Subject:To:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=PIqQt53/aPTpYiOjyQOXdTJZp+96E9SzYtFp2tXo3b0+AIWikqCD3+72J+PdauNP0 eJGJsB64yeOJ1oLk1YJKb9HgBotCsu/ZrKk9s20nzs7WEHpcXGjlHsSa5nEvCjXBZY oLiNzw7FlM4sSTNX+CUgNaCVepJ8Nu9Pt0DSQddI= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pl1-x632.google.com (mail-pl1-x632.google.com [IPv6:2607:f8b0:4864:20::632]) by sourceware.org (Postfix) with ESMTPS id 7653A3858C83; Sat, 22 Apr 2023 08:32:44 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 7653A3858C83 Received: by mail-pl1-x632.google.com with SMTP id d9443c01a7336-1a66e7a52d3so23848545ad.0; Sat, 22 Apr 2023 01:32:44 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1682152363; x=1684744363; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=YR1s48OxhpVJPq6rpECl/EbO0c7upi7RpGc1HFATJk4=; b=AP+FhU5JZSGLLS1aLuZOxKJUsrKRV21bR2aHgHjJm80QaIiVb94B0iDJBdjaZIRn7G U3BVzc6aE9J+2sKvLCkJV0rHYCI6UqdG/rDDkH5MaQgUKdZgsv9LxXWvM2PH7HLd37sf wDvVHsxE3Vo2vzs6kexs7q+XBoTp2ywANaHo8OzGDW5vk612ThkRyMaIk5O5WC02IEwT UeNR8j1gj/7f0jMG/0uoy6KTnRlS2RNwqUVMS8hh3v1u+G5v7nmczn7ueJryt6Fctepr 9wFCoD+O5Mkhygp61fkFFZ3cyocLA5dJ0tBxS2MY9+VKQkdLJHtJi3C39AJzKRR2WQdq kk3g== X-Gm-Message-State: AAQBX9dbNTgRraMw1sZuz1eL/uNIXtHJ81TiMXiBgJYGpe3yv2gwmmXx A+AjX6d8m6URJri5B8B1uGZ9kJFRhPlkUrw1TDxNjRQX X-Google-Smtp-Source: AKy350ZHbDmvjXNQTCK9TAtxJlqnAlmsLCotVgPdXOqEI80jgEsEP9nHa4euMHdaknBAYHvxAd4ZfkVBd/3MJ5Y1pj0= X-Received: by 2002:a17:902:e381:b0:1a8:1c9a:f68 with SMTP id g1-20020a170902e38100b001a81c9a0f68mr6955147ple.36.1682152362530; Sat, 22 Apr 2023 01:32:42 -0700 (PDT) MIME-Version: 1.0 Date: Sat, 22 Apr 2023 09:32:30 +0100 Message-ID: Subject: [Patch, fortran] PRs 105152, 100193, 87946, 103389, 104429 and 82774 To: "fortran@gcc.gnu.org" , gcc-patches X-Spam-Status: No, score=-6.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, KAM_NUMSUBJECT, RCVD_IN_DNSWL_NONE, 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-Content-Filtered-By: Mailman/MimeDel 2.1.29 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Paul Richard Thomas via Gcc-patches From: Paul Richard Thomas Reply-To: Paul Richard Thomas Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" Hi All, As usual, I received a string of emails on retargeting for PRs for which I was either responsible or was on the cc list. This time I decided to take a look at them all, in order to reward the tireless efforts of Richi, Jakub and Martin with some attention at least. I have fixed the PRs in the title line: See the attached changelog, patch and testcases. OK for 14-branch? Of the others: PR100815 - fixed already for 12-branch on. Martin located the fix from Tobias, for which thanks. It's quite large but has stood the test of time. Should I backport to 11-branch? PR103366 - fixed on 12-branch on. I closed it. PR103715 - might be fixed but the report is for gcc with checking enabled. I will give that a go. PR103716 - a gimple problem with assumed shape characters. A TODO. PR103931 - I couldn't reproduce the bug, which involves 'ambiguous c_ptr'. To judge by the comments, it seems that this bug is a bit elusive. PR65381 - Seems to be fixed for 12-branch on PR82064 - Seems to be fixed. PR83209 - Coarray allocation - seems to be fixed. PR84244 - Coarray segfault. I have no acquaintance with the inner works of coarrays and so don't think that I can fix this one. PR87674 - Segfault in runtime with non-overridable proc-pointer. A TODO. PR96087 - A module procedure problem. A TODO. I have dejagnu-ified testcases for the already fixed PRs ready to go. Should these be committed or do we assume that the fixes already provided adequate tests? Regards Paul diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index e9843e9549c..fa505ab7ed9 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -3312,6 +3312,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, } } + if (UNLIMITED_POLY (a->expr) + && !(f->sym->ts.type == BT_ASSUMED || UNLIMITED_POLY (f->sym))) + { + gfc_error ("Unlimited polymorphic actual argument at %L is not " + "matched with either an unlimited polymorphic or " + "assumed type dummy argument", &a->expr->where); + ok = false; + goto match; + } + /* Special case for character arguments. For allocatable, pointer and assumed-shape dummies, the string length needs to match exactly. */ diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 55d8e326a87..aaca772320a 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -11129,6 +11129,17 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) lhs = code->expr1; rhs = code->expr2; + if ((lhs->symtree->n.sym->ts.type == BT_DERIVED + || lhs->symtree->n.sym->ts.type == BT_CLASS) + && !lhs->symtree->n.sym->attr.proc_pointer + && gfc_expr_attr (lhs).proc_pointer) + { + gfc_error ("Variable in the ordinary assignment at %L is a procedure " + "pointer component", + &lhs->where); + return false; + } + if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) && rhs->ts.type == BT_CHARACTER && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions)) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e1725808033..6c47b537dfc 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11471,6 +11471,12 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) break; case AR_FULL: + /* Assumed shape arrays from interface mapping need this fix. */ + if (!ar->as && expr->symtree->n.sym->as) + { + ar->as = gfc_get_array_spec(); + *ar->as = *expr->symtree->n.sym->as; + } newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); newss->info->data.array.ref = ref; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 09cdd9263c4..74d6948b0ae 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -996,6 +996,12 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, tree var; tree tmp; int dim; + bool unlimited_poly; + + unlimited_poly = class_ts.type == BT_CLASS + && class_ts.u.derived->components->ts.type == BT_DERIVED + && class_ts.u.derived->components->ts.u.derived + ->attr.unlimited_polymorphic; /* The intrinsic type needs to be converted to a temporary CLASS object. */ @@ -1067,9 +1073,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, } gcc_assert (class_ts.type == BT_CLASS); - if (class_ts.u.derived->components->ts.type == BT_DERIVED - && class_ts.u.derived->components->ts.u.derived - ->attr.unlimited_polymorphic) + if (unlimited_poly) { ctree = gfc_class_len_get (var); /* When the actual arg is a char array, then set the _len component of the @@ -1116,10 +1120,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); } - else if (class_ts.type == BT_CLASS - && class_ts.u.derived->components - && class_ts.u.derived->components->ts.u - .derived->attr.unlimited_polymorphic) + else if (unlimited_poly) { ctree = gfc_class_len_get (var); gfc_add_modify (&parmse->pre, ctree, @@ -5650,7 +5651,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) itype = CFI_type_other; // FIXME: Or CFI_type_cptr ? break; case BT_CLASS: - if (UNLIMITED_POLY (e) && fsym->ts.type == BT_ASSUMED) + if (fsym->ts.type == BT_ASSUMED) { // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*) // type specifier is assumed-type and is an unlimited polymorphic @@ -6682,20 +6683,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree zero; - gfc_expr *var; - - /* Borrow the function symbol to make a call to - gfc_add_finalizer_call and then restore it. */ - tmp = e->symtree->n.sym->backend_decl; - e->symtree->n.sym->backend_decl - = TREE_OPERAND (parmse.expr, 0); - e->symtree->n.sym->attr.flavor = FL_VARIABLE; - var = gfc_lval_expr_from_sym (e->symtree->n.sym); - finalized = gfc_add_finalizer_call (&parmse.post, - var); - gfc_free_expr (var); - e->symtree->n.sym->backend_decl = tmp; - e->symtree->n.sym->attr.flavor = FL_PROCEDURE; + /* Finalize the expression. */ + gfc_finalize_tree_expr (&parmse, NULL, + gfc_expr_attr (e), e->rank); + gfc_add_block_to_block (&parmse.post, + &parmse.finalblock); /* Then free the class _data. */ zero = build_int_cst (TREE_TYPE (parmse.expr), 0); @@ -7131,7 +7123,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, types passed to class formals need the _data component. */ tmp = gfc_class_data_get (tmp); if (!CLASS_DATA (fsym)->attr.dimension) - tmp = build_fold_indirect_ref_loc (input_location, tmp); + { + if (UNLIMITED_POLY (fsym)) + { + tree type = gfc_typenode_for_spec (&e->ts); + type = build_pointer_type (type); + tmp = fold_convert (type, tmp); + } + tmp = build_fold_indirect_ref_loc (input_location, tmp); + } } if (e->expr_type == EXPR_OP @@ -8767,11 +8767,9 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, /* Allocate or reallocate scalar component, as necessary. */ static void -alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, - tree comp, - gfc_component *cm, - gfc_expr *expr2, - gfc_symbol *sym) +alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp, + gfc_component *cm, gfc_expr *expr2, + tree slen) { tree tmp; tree ptr; @@ -8789,26 +8787,20 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) { - char name[GFC_MAX_SYMBOL_LEN+9]; - gfc_component *strlen; - /* Use the rhs string length and the lhs element size. */ gcc_assert (expr2->ts.type == BT_CHARACTER); - if (!expr2->ts.u.cl->backend_decl) - { - gfc_conv_string_length (expr2->ts.u.cl, expr2, block); - gcc_assert (expr2->ts.u.cl->backend_decl); - } + if (!expr2->ts.u.cl->backend_decl + || !VAR_P (expr2->ts.u.cl->backend_decl)) + expr2->ts.u.cl->backend_decl = gfc_create_var (TREE_TYPE (slen), + "slen"); + gfc_add_modify (block, expr2->ts.u.cl->backend_decl, slen); size = expr2->ts.u.cl->backend_decl; - /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length - component. */ - sprintf (name, "_%s_length", cm->name); - strlen = gfc_find_component (sym, name, true, true, NULL); + gfc_deferred_strlen (cm, &tmp); lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF, gfc_charlen_type_node, TREE_OPERAND (comp, 0), - strlen->backend_decl, NULL_TREE); + tmp, NULL_TREE); tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts)); tmp = TYPE_SIZE_UNIT (tmp); @@ -8881,8 +8873,8 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, /* Assign a single component of a derived type constructor. */ static tree -gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, - gfc_symbol *sym, bool init) +gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, + gfc_expr * expr, bool init) { gfc_se se; gfc_se lse; @@ -8976,19 +8968,17 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable && expr->ts.type != BT_CLASS))) { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr); + /* Take care about non-array allocatable components here. The alloc_* routine below is motivated by the alloc_scalar_allocatable_for_ assignment() routine, but with the realloc portions removed and different input. */ - alloc_scalar_allocatable_for_subcomponent_assignment (&block, - dest, - cm, - expr, - sym); + alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr, + se.string_length); /* The remainder of these instructions follow the if (cm->attr.pointer) if (!cm->attr.dimension) part above. */ - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr); gfc_add_block_to_block (&block, &se.pre); if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer @@ -9252,13 +9242,11 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray) if (!c->expr) { gfc_expr *e = gfc_get_null_expr (NULL); - tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived, - init); + tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init); gfc_free_expr (e); } else - tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, - expr->ts.u.derived, init); + tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block);