From patchwork Wed Dec 6 16:09:36 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: 1872831 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256 header.s=20230601 header.b=f3VvqF9L; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4Slj6W3Tdhz1ySd for ; Thu, 7 Dec 2023 03:10:11 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 476E53858C5F for ; Wed, 6 Dec 2023 16:10:09 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pg1-x52c.google.com (mail-pg1-x52c.google.com [IPv6:2607:f8b0:4864:20::52c]) by sourceware.org (Postfix) with ESMTPS id B224A3858D20; Wed, 6 Dec 2023 16:09:49 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B224A3858D20 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmail.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmail.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org B224A3858D20 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2607:f8b0:4864:20::52c ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1701878995; cv=none; b=IdEr2SrJHWQi1If31+gSJO/Y9i16eduE7mH/aJ0OVS6arJKhiFNPdX1dhoR2c8kAYTol7odmlKgDsPjgE3Btn8bxCtu3GRkOZuasDG9CWwKUYIqe5kfmjqqRaggMo4s+Afq5HgKhmX/X7zmXh03glff3j33WcsIrg15faNY9Bt4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1701878995; c=relaxed/simple; bh=3v13Gr1TLDudABWMcxqt6Xx1S8Sbt/JDchMKAB9GJA0=; h=DKIM-Signature:MIME-Version:From:Date:Message-ID:Subject:To; b=RJYDG173zvnv2WAZEVW6KhhOVShTofP6jphdlwvxqzE8jL9Vm0+Kff8YTa/iRpO8gE9iXi2cMMknYYCZm4gDFivcbPuYghOu5Za1DuCeq9lh8mj1PCShoi/ZzJP7F/ypjwx4ytkjR+ViXtZ0hBcFHH0F/OrzaXJYqlqfaW5I5fM= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-pg1-x52c.google.com with SMTP id 41be03b00d2f7-5c68da9d639so2397763a12.3; Wed, 06 Dec 2023 08:09:49 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1701878988; x=1702483788; darn=gcc.gnu.org; h=to:subject:message-id:date:from:mime-version:from:to:cc:subject :date:message-id:reply-to; bh=3v13Gr1TLDudABWMcxqt6Xx1S8Sbt/JDchMKAB9GJA0=; b=f3VvqF9LSnQ7sT3H0wdlc7QOuAblIejlqDh3wcgKdRu4BIUy1DsmFncm4ojD4ZIzfv nHJZFYnuJKpUer8R1WyBm24N6a6ngNfWc2QcMrVP5TUnVoQW7V6e+KCuhPeP7qIHrN8B ICL/puMEnbAOqEVKYjqY/j34MD1JY3cFJPzElHa5iZkmxIBGD4HL+2dn0oyYwjtEleiY ZD/uIoR+9/ysoqrpy0P1+TA0nEX2BRKaRmuDCzsY1PHVNl8etqWTg4tPOzXg1KYd6j+G SJnr9Ql3tKjtPPF/SwMiYpAaaCIiDvBBAQvmtl7HUcpsHyQr93M5zqPQIeVyyllJ2s2C qL9A== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1701878988; x=1702483788; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=3v13Gr1TLDudABWMcxqt6Xx1S8Sbt/JDchMKAB9GJA0=; b=YIMr7/o9jrX7SgqaG705ykMdLc4LuTgbgCbPFRGFmtH06NsQL8d1DxlKUIsZgcMlTs 8h+juttit7R0vRNGRknqVVB1tCfEe+FDyGpk8QKaSEdDhsMYH0ikjh4IRNbX3n+84uiG u0YL9699C9C8M5U7CaDGdlfH7U+ujPM2h1yCMhHjfbjQSl+pPfesUlaUXycqbSjLCHaC FQc3IbYZJ2WVizdT2chA+Z0QScN3PGMBsi4UOVpO8zqSKn1ylDnSUlbMkjASl6bI+zbZ PEqD14CV8s7g59BZI0f0RzDR9wAuJ6bqTjGiyCxC3mQEsx8MaHMyKAt0eg/jl5hJFP7f 8rTQ== X-Gm-Message-State: AOJu0YxRnJhCS5Lc5AHZMmrnjs1J5cJoSFQHJq3yA/4FaXZnIBxEa7zW txDrMpVCpUmiUjh92vwzSSN1AQBMy3/xDgZJinA7raMBIHQ= X-Google-Smtp-Source: AGHT+IFPJjBJE7jyaeyNOB13x/v5SSt+byfd10m/VG19GdBUifmDdZ9sTl6pGwKI3BR0U17kFTQLhUYaiWDbz5mytKE= X-Received: by 2002:a17:90b:30c5:b0:286:6cc1:2cc0 with SMTP id hi5-20020a17090b30c500b002866cc12cc0mr849150pjb.74.1701878988093; Wed, 06 Dec 2023 08:09:48 -0800 (PST) MIME-Version: 1.0 From: Paul Richard Thomas Date: Wed, 6 Dec 2023 16:09:36 +0000 Message-ID: Subject: {Patch, fortran] PR112834 - Class array function selector causes chain of syntax and other spurious errors To: "fortran@gcc.gnu.org" , gcc-patches X-Spam-Status: No, score=-6.5 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE, URIBL_BLACK 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 Dear All, This patch was rescued from my ill-fated and long winded attempt to provide a fix-up for function selector references, where the function is parsed after the procedure containing the associate/select type construct (PRs 89645 and 99065). The fix-ups broke down completely once these constructs were enclosed by another associate construct, where the selector is a derived type or class function. My inclination now is to introduce two pass parsing for contained procedures. Returning to PR112834, the patch is simple enough and is well described by the change logs. PR111853 was fixed as a side effect of the bigger patch. Steve Kargl had also posted the same fix on the PR. Regression tests - OK for trunk and 13-branch? Paul diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 9e3571d3dbe..cecd2940dcf 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -6436,9 +6436,9 @@ build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2) sym = expr1->symtree->n.sym; if (expr2->ts.type == BT_UNKNOWN) - sym->attr.untyped = 1; + sym->attr.untyped = 1; else - copy_ts_from_selector_to_associate (expr1, expr2); + copy_ts_from_selector_to_associate (expr1, expr2); sym->attr.flavor = FL_VARIABLE; sym->attr.referenced = 1; @@ -6527,6 +6527,7 @@ select_type_set_tmp (gfc_typespec *ts) gfc_symtree *tmp = NULL; gfc_symbol *selector = select_type_stack->selector; gfc_symbol *sym; + gfc_expr *expr2; if (!ts) { @@ -6550,7 +6551,19 @@ select_type_set_tmp (gfc_typespec *ts) sym = tmp->n.sym; gfc_add_type (sym, ts, NULL); - if (selector->ts.type == BT_CLASS && selector->attr.class_ok + /* If the SELECT TYPE selector is a function we might be able to obtain + a typespec from the result. Since the function might not have been + parsed yet we have to check that there is indeed a result symbol. */ + if (selector->ts.type == BT_UNKNOWN + && gfc_state_stack->construct + && (expr2 = gfc_state_stack->construct->expr2) + && expr2->expr_type == EXPR_FUNCTION + && expr2->symtree + && expr2->symtree->n.sym && expr2->symtree->n.sym->result) + selector->ts = expr2->symtree->n.sym->result->ts; + + if (selector->ts.type == BT_CLASS + && selector->attr.class_ok && selector->ts.u.derived && CLASS_DATA (selector)) { sym->attr.pointer diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index abd3a424f38..c1fa751d0e8 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -5131,7 +5131,7 @@ parse_associate (void) gfc_current_ns = my_ns; for (a = new_st.ext.block.assoc; a; a = a->next) { - gfc_symbol* sym; + gfc_symbol *sym, *tsym; gfc_expr *target; int rank; @@ -5195,6 +5195,16 @@ parse_associate (void) sym->ts.type = BT_DERIVED; sym->ts.u.derived = derived; } + else if (target->symtree && (tsym = target->symtree->n.sym)) + { + sym->ts = tsym->result ? tsym->result->ts : tsym->ts; + if (sym->ts.type == BT_CLASS) + { + if (CLASS_DATA (sym)->as) + target->rank = CLASS_DATA (sym)->as->rank; + sym->attr.class_ok = 1; + } + } } rank = target->rank; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 166b702cd9a..92678b816a1 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5669,7 +5669,7 @@ gfc_expression_rank (gfc_expr *e) if (ref->type != REF_ARRAY) continue; - if (ref->u.ar.type == AR_FULL) + if (ref->u.ar.type == AR_FULL && ref->u.ar.as) { rank = ref->u.ar.as->rank; break; diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 50b71e67234..b70c079fc55 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -1746,6 +1746,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) e = sym->assoc->target; class_target = (e->expr_type == EXPR_VARIABLE) + && e->ts.type == BT_CLASS && (gfc_is_class_scalar_expr (e) || gfc_is_class_array_ref (e, NULL)); @@ -2037,7 +2038,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* Class associate-names come this way because they are unconditionally associate pointers and the symbol is scalar. */ - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) + if (sym->ts.type == BT_CLASS && e->expr_type ==EXPR_FUNCTION) + { + gfc_conv_expr (&se, e); + se.expr = gfc_evaluate_now (se.expr, &se.pre); + } + else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) { tree target_expr; /* For a class array we need a descriptor for the selector. */