{"id":2224249,"url":"http://patchwork.ozlabs.org/api/1.2/patches/2224249/?format=json","web_url":"http://patchwork.ozlabs.org/project/gcc/patch/CAGkQGiK6nmyc7LVmN7-8SafPpDY8gfXy0S_-TR_hRZRnCUi+xw@mail.gmail.com/","project":{"id":17,"url":"http://patchwork.ozlabs.org/api/1.2/projects/17/?format=json","name":"GNU Compiler Collection","link_name":"gcc","list_id":"gcc-patches.gcc.gnu.org","list_email":"gcc-patches@gcc.gnu.org","web_url":null,"scm_url":null,"webscm_url":null,"list_archive_url":"","list_archive_url_format":"","commit_url_format":""},"msgid":"","list_archive_url":null,"date":"2026-04-17T07:36:48","name":"[fortran] PR121384 - Wrongly initialized associate array descriptor when the target is wrapped in parenthesis","commit_ref":null,"pull_url":null,"state":"new","archived":false,"hash":"7fc7b6060d793492a74a1c28a98bc7bde49af58a","submitter":{"id":4392,"url":"http://patchwork.ozlabs.org/api/1.2/people/4392/?format=json","name":"Paul Richard Thomas","email":"paul.richard.thomas@gmail.com"},"delegate":null,"mbox":"http://patchwork.ozlabs.org/project/gcc/patch/CAGkQGiK6nmyc7LVmN7-8SafPpDY8gfXy0S_-TR_hRZRnCUi+xw@mail.gmail.com/mbox/","series":[{"id":500252,"url":"http://patchwork.ozlabs.org/api/1.2/series/500252/?format=json","web_url":"http://patchwork.ozlabs.org/project/gcc/list/?series=500252","date":"2026-04-17T07:36:48","name":"[fortran] PR121384 - Wrongly initialized associate array descriptor when the target is wrapped in parenthesis","version":1,"mbox":"http://patchwork.ozlabs.org/series/500252/mbox/"}],"comments":"http://patchwork.ozlabs.org/api/patches/2224249/comments/","check":"pending","checks":"http://patchwork.ozlabs.org/api/patches/2224249/checks/","tags":{},"related":[],"headers":{"Return-Path":"","X-Original-To":["incoming@patchwork.ozlabs.org","gcc-patches@gcc.gnu.org"],"Delivered-To":["patchwork-incoming@legolas.ozlabs.org","gcc-patches@gcc.gnu.org"],"Authentication-Results":["legolas.ozlabs.org;\n\tdkim=pass (2048-bit key;\n unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256\n header.s=20251104 header.b=Qtz/+ViM;\n\tdkim-atps=neutral","legolas.ozlabs.org;\n spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org\n (client-ip=2620:52:6:3111::32; helo=vm01.sourceware.org;\n envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org;\n receiver=patchwork.ozlabs.org)","sourceware.org;\n\tdkim=pass (2048-bit key,\n unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256\n header.s=20251104 header.b=Qtz/+ViM","sourceware.org;\n dmarc=pass (p=none dis=none) header.from=gmail.com","sourceware.org; spf=pass smtp.mailfrom=gmail.com","server2.sourceware.org;\n arc=pass smtp.remote-ip=74.125.82.42"],"Received":["from vm01.sourceware.org (vm01.sourceware.org\n [IPv6:2620:52:6:3111::32])\n\t(using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)\n\t key-exchange x25519 server-signature ECDSA (secp384r1) server-digest SHA384)\n\t(No client certificate requested)\n\tby legolas.ozlabs.org (Postfix) with ESMTPS id 4fxmv12mJCz1yDF\n\tfor ; Fri, 17 Apr 2026 17:37:47 +1000 (AEST)","from vm01.sourceware.org (localhost [127.0.0.1])\n\tby sourceware.org (Postfix) with ESMTP id 9316C4BAD142\n\tfor ; Fri, 17 Apr 2026 07:37:44 +0000 (GMT)","from mail-dl1-f42.google.com (mail-dl1-f42.google.com\n [74.125.82.42])\n by sourceware.org (Postfix) with ESMTPS id E64374BA2E0A\n for ; Fri, 17 Apr 2026 07:37:03 +0000 (GMT)","by mail-dl1-f42.google.com with SMTP id\n a92af1059eb24-1274204434bso1092008c88.1\n for ; Fri, 17 Apr 2026 00:37:03 -0700 (PDT)"],"DKIM-Filter":["OpenDKIM Filter v2.11.0 sourceware.org 9316C4BAD142","OpenDKIM Filter v2.11.0 sourceware.org E64374BA2E0A"],"DMARC-Filter":"OpenDMARC Filter v1.4.2 sourceware.org E64374BA2E0A","ARC-Filter":"OpenARC Filter v1.0.0 sourceware.org E64374BA2E0A","ARC-Seal":["i=2; a=rsa-sha256; d=sourceware.org; s=key; t=1776411424; cv=pass;\n b=FtfcmrTTT/uRBeXkQ7Vnwge7zOrmrZI4p+qYijblwBU6I/ocoWmkkRrdRj9rN5MnQcgvxBjyeYQT3Q11GBzhn2r7xDEHEh4+Py36opXjupGD40+rvPrzBEYV1n4K1vI5cOZQiAQ3ysC1hrfahDWzUwLlHgYSXPuAdAvs6TgevL0=","i=1; a=rsa-sha256; t=1776411423; cv=none;\n d=google.com; s=arc-20240605;\n b=QZjovt463JFXGlwQCykF3RVgeaoe/et3w3L6z4pkzmgzayKOhia1mFJwShDJYcD0aQ\n IkoWTbV4L4LUfexvEFWhn6TmNKrO9kgNXrEkdwT+aRtrn1/7DNo0XTskDFaAmiYSpu+B\n +i/0nqMnvPBXESadjMqWM8RcCIJwy/00pqgt59obJ2MuNU/rAnHh+TAQDlc9/SMPoeRA\n Ek13/Cp9sX8H02ejQgKRQbpezCucQ6fDyyJPgDsCVvWW/3horSv4orkPdG0WtpXWJ0/P\n STTflBYWXNJ6Au7lfsnQ19D+9x3gWDO10sN27yHMLzugJdInJ8hqYGZ4iowgx03BA3lM\n U5zA=="],"ARC-Message-Signature":["i=2; a=rsa-sha256; d=sourceware.org; s=key;\n t=1776411424; c=relaxed/simple;\n bh=I0jHxzN6eeeQOlk4LI/qMDe3L1XNMUv0fCTPQzosmMY=;\n h=DKIM-Signature:MIME-Version:From:Date:Message-ID:Subject:To;\n b=Ewdp5rc8ExIE6okdiYlC4xEgTamLSk6Ivfzrvwx4Tq1kifyaA3k4kasCSRrJoylFQJ3NVA3Alj592jcYD02/GhMeRUxbEQP2HbSFp/zKrVUIE3wSOM2pfeaf8ELYC5Gl61Zv5jY30j/Oxf64wCgpDIJnr1/ifkecAd1LcRh2jzU=","i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com;\n s=arc-20240605;\n h=to:subject:message-id:date:from:mime-version:dkim-signature;\n bh=I0jHxzN6eeeQOlk4LI/qMDe3L1XNMUv0fCTPQzosmMY=;\n fh=uwBox9RMZtdUOt0m8EF5Ek3gnPUtI+jsRyNuj+/VoS8=;\n b=Qjia8IDz8fLhjACG/kQEquhXqKYUC9vtmrreS7symPdUwqtV4qzD2cWyh0acT8zlWz\n X1C78eTgHcmALruHvo0RRTVj/1Y42Mq5xOy3pTftQ+6xgtaIQwEN+ONgF9UhdG2PN5Xt\n gwKgSwZkN5LwJfuwRe+1jMFGcNoFOj5v+K8YIUHqQchoMcx35813bPaSynXlj513/lxG\n 64NC/GIP9yQz+m8xiJwFNbNCD4iuxoD21n0dusgaz/llGlFnR3GT8EphZma2r9uZe/Os\n edCB7KDbSZlhyAQdm2wHdA3XSxymqG2WgMb9sdqpPEkVpFJSJ8fs+7IbneTMgrl8nFk9\n +NIg==; darn=gcc.gnu.org"],"ARC-Authentication-Results":["i=2; server2.sourceware.org","i=1; mx.google.com; arc=none"],"DKIM-Signature":"v=1; a=rsa-sha256; c=relaxed/relaxed;\n d=gmail.com; s=20251104; t=1776411423; x=1777016223; darn=gcc.gnu.org;\n h=to:subject:message-id:date:from:mime-version:from:to:cc:subject\n :date:message-id:reply-to;\n bh=I0jHxzN6eeeQOlk4LI/qMDe3L1XNMUv0fCTPQzosmMY=;\n b=Qtz/+ViM/sHEHtDknUjHduBBY2Gzv0h3dN/D3L5h8ku31mbWwMMsS3jEluvhB1T1PC\n TVpfRs8u4wHv1nPdkLREOhVRCh/VNMVcey5fDIX/zm3wdE/BAE2jDVAA+r/h2n9ccNvH\n nnWndU3f75beIYWbW2LVpmSzvuG4cINwvJVLYHKtP5+WQcnG2LZ/cD2Bs7AFRT5O0+zp\n FgDnlGWYViiraeEKFWa8rV3uCSsWBZN7FYUtTg4QAOUwuBWp+DWY2BJSjR7XQNJypOhc\n K6t56PPXovZVLd0tJ3ZGTPyrQB3tNJbZ6FJQsW9K25bCteY+HDtofqRA/YZ8xzVOZQGx\n X9EQ==","X-Google-DKIM-Signature":"v=1; a=rsa-sha256; c=relaxed/relaxed;\n d=1e100.net; s=20251104; t=1776411423; x=1777016223;\n h=to:subject:message-id:date:from:mime-version:x-gm-gg\n :x-gm-message-state:from:to:cc:subject:date:message-id:reply-to;\n bh=I0jHxzN6eeeQOlk4LI/qMDe3L1XNMUv0fCTPQzosmMY=;\n b=fDi1D4b6dd7Us+xhYrggfuloAqnxwWQwPHIHfoDyCMrqdfxULlBGFERfGRCGTOHAYl\n 938RIgDnfDRn5Oy8GahitPMQveP0tIw4CLzRfmxoPTt36h4w0Zk7i8ow4cxXQvncAHdt\n pwzGZN3lkcuHwzzvf+0k2ftKvGKZoYtfCYNn+TWkQpTwkddpBJCUetmLpc1Vn48+PaTM\n 4kkJLCrEV6AORwEIEXYK5wnjISAB3Dlse8qTWukptAcM4e72nlbYvSYK17o2Rq5hINmD\n Q4FsN4lBQoSlHv4d555XZsgNDj/wUMJNFxwSVl51lQjOrKrptv+tydHpE+HmFSMFLQD6\n OcZw==","X-Forwarded-Encrypted":"i=1;\n AFNElJ9romyqie48niULUuzfD8uEMxYHECwM1tcyQvR2ZynKDqZGT69OdWtrFjh+nvhndOeKaWScml3MhXnkwA==@gcc.gnu.org","X-Gm-Message-State":"AOJu0YwuOteVC8IGLhar0J76Dn4m99LnwguIQI8xvMYPqqgmZ3o02Yre\n gB9Nx1FvrtvMdqdzIvCbZAj5LrbES5eqchPFgFzGlgJFF97XfHI6t11cX1R1racmGH9jum3QFSe\n lQbqLSdoq+iOVotnME/9lqes+gdhQPf+VMA==","X-Gm-Gg":"AeBDietNFEKuni32FOGaGh0xG7ASAIErxlhmyqGbm94/1/WRzaqzpalV2pUgUiSB9Ss\n /nPNVXsEme8B3q6GhDlFaOmLu+SVQTSSIPikfc8jOhyN6KEPHx80r7muOx0boNRGBo5QOi4XYgk\n mBRifjAReA97SS7VINm0XWlAuSD5pW46Oqzz9p9v0zvpiNBEmbIKbiO7+jADAjD2MjmO6jUvzrd\n xN0KrvNMk/o8vlcggCavhn7c0IwHtHJyVnvSaqyvi2SX3YtTuEM3DQQiPW6QpcqoGITy7R0PWgE\n CLztANuDeKKnDKvyaxJnZ6Py5QHr67eDuOz37Gkijkoo94J/8YAm","X-Received":"by 2002:a05:7022:6181:b0:12b:fd86:b443 with SMTP id\n a92af1059eb24-12c73afa6a5mr625347c88.7.1776411422480; Fri, 17 Apr 2026\n 00:37:02 -0700 (PDT)","MIME-Version":"1.0","From":"Paul Richard Thomas ","Date":"Fri, 17 Apr 2026 08:36:48 +0100","X-Gm-Features":"AQROBzD-8kTOBfLiqUu5s-FKFNhvxj2r4_FjrkXlM9Ggc14l1c2rZfIxmVbGLKI","Message-ID":"\n ","Subject":"[Patch, fortran] PR121384 - Wrongly initialized associate array\n descriptor when the target is wrapped in parenthesis","To":"\"fortran@gcc.gnu.org\" ,\n gcc-patches ","Content-Type":"multipart/mixed; boundary=\"000000000000d059e9064fa30370\"","X-BeenThere":"gcc-patches@gcc.gnu.org","X-Mailman-Version":"2.1.30","Precedence":"list","List-Id":"Gcc-patches mailing list ","List-Unsubscribe":",\n ","List-Archive":"","List-Post":"","List-Help":"","List-Subscribe":",\n ","Errors-To":"gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org"},"content":"This one is actually very straightforward. Most of the patch consists\nof moves of helper functions to allow a temporary to be constructed\nfor the selector.\n\nRegtests on FC43/x86_64 - OK for mainline?\n\nOnce 17-branch is open, I will see if an extension to this patch can\nbe used to eliminate a lot of code in trans-stmt.cc.\n\nPaul","diff":"From 691c7503f509423c3ffedbfa0bda5207281951bd Mon Sep 17 00:00:00 2001\nFrom: Paul Thomas \nDate: Fri, 17 Apr 2026 06:00:03 +0100\nSubject: [PATCH] Fortran: Fix wrongly initialized associate-name descriptor\n [PR121384]\n\n2026-04-17 Paul Thomas \n\ngcc/fortran\n\tPR fortran/121384\n\t* resolve.cc (add_comp_ref, build_assignment,\n\tadd_code_to_chain, get_temp_from_expr,\n\tadd_temp_assign_before_call) : Move to top of file and delete\n\tprototypes.\n\t(resolve_block_construct): Generate a temporary for subref\n\tarray selectors enclosed in parantheses.\n\ngcc/testsuite\n\tPR fortran/121384\n\t* gfortran.dg/associate_79.f90: New test.\n---\n gcc/fortran/resolve.cc | 556 +++++++++++----------\n gcc/testsuite/gfortran.dg/associate_79.f90 | 43 ++\n 2 files changed, 338 insertions(+), 261 deletions(-)\n create mode 100644 gcc/testsuite/gfortran.dg/associate_79.f90\n\ndiff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc\nindex a5d9add9d2f..bf078a40206 100644\n--- a/gcc/fortran/resolve.cc\n+++ b/gcc/fortran/resolve.cc\n@@ -204,6 +204,264 @@ check_proc_interface (gfc_symbol *ifc, locus *where)\n static void resolve_symbol (gfc_symbol *sym);\n \n \n+/*************Helper functions for modifying code*********************/\n+\n+/* Add a component reference onto an expression. */\n+\n+static void\n+add_comp_ref (gfc_expr *e, gfc_component *c)\n+{\n+ gfc_ref **ref;\n+ ref = &(e->ref);\n+ while (*ref)\n+ ref = &((*ref)->next);\n+ *ref = gfc_get_ref ();\n+ (*ref)->type = REF_COMPONENT;\n+ (*ref)->u.c.sym = e->ts.u.derived;\n+ (*ref)->u.c.component = c;\n+ e->ts = c->ts;\n+\n+ /* Add a full array ref, as necessary. */\n+ if (c->as)\n+ {\n+ gfc_add_full_array_ref (e, c->as);\n+ e->rank = c->as->rank;\n+ e->corank = c->as->corank;\n+ }\n+}\n+\n+\n+/* Build an assignment. Keep the argument 'op' for future use, so that\n+ pointer assignments can be made. */\n+\n+static gfc_code *\n+build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,\n+\t\t gfc_component *comp1, gfc_component *comp2, locus loc)\n+{\n+ gfc_code *this_code;\n+\n+ this_code = gfc_get_code (op);\n+ this_code->next = NULL;\n+ this_code->expr1 = gfc_copy_expr (expr1);\n+ this_code->expr2 = gfc_copy_expr (expr2);\n+ this_code->loc = loc;\n+ if (comp1 && comp2)\n+ {\n+ add_comp_ref (this_code->expr1, comp1);\n+ add_comp_ref (this_code->expr2, comp2);\n+ }\n+\n+ return this_code;\n+}\n+\n+\n+/* Makes a temporary variable expression based on the characteristics of\n+ a given variable expression. If allocatable is set, the temporary is\n+ unconditionally allocatable*/\n+\n+static gfc_expr*\n+get_temp_from_expr (gfc_expr *e, gfc_namespace *ns,\n+\t\t bool allocatable = false)\n+{\n+ static int serial = 0;\n+ char name[GFC_MAX_SYMBOL_LEN];\n+ gfc_symtree *tmp;\n+ gfc_array_spec *as;\n+ gfc_array_ref *aref;\n+ gfc_ref *ref;\n+\n+ sprintf (name, GFC_PREFIX(\"DA%d\"), serial++);\n+ gfc_get_sym_tree (name, ns, &tmp, false);\n+ gfc_add_type (tmp->n.sym, &e->ts, NULL);\n+\n+ if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)\n+ tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,\n+\t\t\t\t\t\t NULL,\n+\t\t\t\t\t\t e->value.character.length);\n+\n+ as = NULL;\n+ ref = NULL;\n+ aref = NULL;\n+\n+ /* Obtain the arrayspec for the temporary. */\n+ if (e->rank && e->expr_type != EXPR_ARRAY\n+ && e->expr_type != EXPR_FUNCTION\n+ && e->expr_type != EXPR_OP)\n+ {\n+ aref = gfc_find_array_ref (e);\n+ if (e->expr_type == EXPR_VARIABLE\n+\t && e->symtree->n.sym->as == aref->as)\n+\tas = aref->as;\n+ else\n+\t{\n+\t for (ref = e->ref; ref; ref = ref->next)\n+\t if (ref->type == REF_COMPONENT\n+\t\t&& ref->u.c.component->as == aref->as)\n+\t {\n+\t\tas = aref->as;\n+\t\tbreak;\n+\t }\n+\t}\n+ }\n+\n+ /* Add the attributes and the arrayspec to the temporary. */\n+ tmp->n.sym->attr = gfc_expr_attr (e);\n+ tmp->n.sym->attr.function = 0;\n+ tmp->n.sym->attr.proc_pointer = 0;\n+ tmp->n.sym->attr.result = 0;\n+ tmp->n.sym->attr.flavor = FL_VARIABLE;\n+ tmp->n.sym->attr.dummy = 0;\n+ tmp->n.sym->attr.use_assoc = 0;\n+ tmp->n.sym->attr.intent = INTENT_UNKNOWN;\n+\n+\n+ if (as && !allocatable)\n+ {\n+ tmp->n.sym->as = gfc_copy_array_spec (as);\n+ if (!ref)\n+\tref = e->ref;\n+ if (as->type == AS_DEFERRED)\n+\ttmp->n.sym->attr.allocatable = 1;\n+ }\n+ else if ((e->rank || e->corank)\n+\t && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION\n+\t || e->expr_type == EXPR_OP || allocatable))\n+ {\n+ tmp->n.sym->as = gfc_get_array_spec ();\n+ tmp->n.sym->as->type = AS_DEFERRED;\n+ tmp->n.sym->as->rank = e->rank;\n+ tmp->n.sym->as->corank = e->corank;\n+ tmp->n.sym->attr.allocatable = 1;\n+ tmp->n.sym->attr.dimension = e->rank ? 1 : 0;\n+ tmp->n.sym->attr.codimension = e->corank ? 1 : 0;\n+ }\n+ else\n+ tmp->n.sym->attr.dimension = 0;\n+\n+ gfc_set_sym_referenced (tmp->n.sym);\n+ gfc_commit_symbol (tmp->n.sym);\n+ e = gfc_lval_expr_from_sym (tmp->n.sym);\n+\n+ /* Should the lhs be a section, use its array ref for the\n+ temporary expression. */\n+ if (aref && aref->type != AR_FULL && !allocatable)\n+ {\n+ gfc_free_ref_list (e->ref);\n+ e->ref = gfc_copy_ref (ref);\n+ }\n+ return e;\n+}\n+\n+\n+/* Helper function to take an argument in a subroutine call with a dependency\n+ on another argument, copy it to an allocatable temporary and use the\n+ temporary in the call expression. The new code is embedded in a block to\n+ ensure local, automatic deallocation. */\n+\n+static void\n+add_temp_assign_before_call (gfc_code *code, gfc_namespace *ns,\n+\t\t\t gfc_expr **rhsptr)\n+{\n+ gfc_namespace *block_ns;\n+ gfc_expr *tmp_var;\n+\n+ /* Wrap the new code in a block so that the temporary is deallocated. */\n+ block_ns = gfc_build_block_ns (ns);\n+\n+ /* As it stands, the block_ns does not not stand up to resolution because the\n+ the assignment would be converted to a call and, in any case, the modified\n+ call fails in gfc_check_conformance. */\n+ block_ns->resolved = 1;\n+\n+ /* Assign the original expression to the temporary. */\n+ tmp_var = get_temp_from_expr (*rhsptr, block_ns, true);\n+ block_ns->code = build_assignment (EXEC_ASSIGN, tmp_var, *rhsptr,\n+\t\t\t\t NULL, NULL, (*rhsptr)->where);\n+\n+ /* Transfer the call to the block and terminate block code. */\n+ *rhsptr = gfc_copy_expr (tmp_var);\n+ block_ns->code->next = gfc_get_code (EXEC_NOP);\n+ *(block_ns->code->next) = *code;\n+ block_ns->code->next->next = NULL;\n+\n+ /* Convert the original code to execute the block. */\n+ code->op = EXEC_BLOCK;\n+ code->ext.block.ns = block_ns;\n+ code->ext.block.assoc = NULL;\n+ code->expr1 = code->expr2 = NULL;\n+}\n+\n+\n+/* Add one line of code to the code chain, making sure that 'head' and\n+ 'tail' are appropriately updated. */\n+\n+static void\n+add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)\n+{\n+ gcc_assert (this_code);\n+ if (*head == NULL)\n+ *head = *tail = *this_code;\n+ else\n+ *tail = gfc_append_code (*tail, *this_code);\n+ *this_code = NULL;\n+}\n+\n+\n+/* Generate a final call from a variable expression */\n+\n+static void\n+generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)\n+{\n+ gfc_code *this_code;\n+ gfc_expr *final_expr = NULL;\n+ gfc_expr *size_expr;\n+ gfc_expr *fini_coarray;\n+\n+ gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);\n+ if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)\n+ return;\n+\n+ /* Now generate the finalizer call. */\n+ this_code = gfc_get_code (EXEC_CALL);\n+ this_code->symtree = final_expr->symtree;\n+ this_code->resolved_sym = final_expr->symtree->n.sym;\n+\n+ //* Expression to be finalized */\n+ this_code->ext.actual = gfc_get_actual_arglist ();\n+ this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);\n+\n+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */\n+ this_code->ext.actual->next = gfc_get_actual_arglist ();\n+ size_expr = gfc_get_expr ();\n+ size_expr->where = gfc_current_locus;\n+ size_expr->expr_type = EXPR_OP;\n+ size_expr->value.op.op = INTRINSIC_DIVIDE;\n+ size_expr->value.op.op1\n+\t= gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,\n+\t\t\t\t \"storage_size\", gfc_current_locus, 2,\n+\t\t\t\t gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),\n+\t\t\t\t gfc_get_int_expr (gfc_index_integer_kind,\n+\t\t\t\t\t\t NULL, 0));\n+ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,\n+\t\t\t\t\t gfc_character_storage_size);\n+ size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;\n+ size_expr->ts = size_expr->value.op.op1->ts;\n+ this_code->ext.actual->next->expr = size_expr;\n+\n+ /* fini_coarray */\n+ this_code->ext.actual->next->next = gfc_get_actual_arglist ();\n+ fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,\n+\t\t\t\t\t&tmp_expr->where);\n+ fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;\n+ this_code->ext.actual->next->next->expr = fini_coarray;\n+\n+ add_code_to_chain (&this_code, head, tail);\n+\n+}\n+\n+/**********End of helper functions for modifying code*****************/\n+\n+\n /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */\n \n static bool\n@@ -4133,9 +4391,6 @@ check_import_status (gfc_expr *e)\n argument which is not INTENT_IN and requires a temporary, build a temporary\n for the INTENT_IN actual argument as well. */\n \n-static void\n-add_temp_assign_before_call (gfc_code *, gfc_namespace *, gfc_expr **);\n-\n static void\n resolve_elemental_dependencies (gfc_code *c)\n {\n@@ -12876,14 +13131,47 @@ static void\n resolve_block_construct (gfc_code* code)\n {\n gfc_namespace *ns = code->ext.block.ns;\n+ gfc_association_list *assoc;\n+ gfc_expr *tmp_var, *tgt;\n+ gfc_code *tmp_code, *old_code;\n+ gfc_exec_op op;\n+\n+ /* For an ASSOCIATE block, the associations (and their targets) will, for the\n+ main part, be resolved by gfc_resolve_symbol, during resolution of the\n+ BLOCK's namespace. */\n+\n+ assoc = code->ext.block.assoc;\n+\n+ /* Subref arrays that are encloded in parentheses need a temporary. */\n+ for (; assoc; assoc = assoc->next)\n+ {\n+ if (assoc && assoc->st && assoc->st->n.sym->assoc\n+\t && !assoc->st->n.sym->attr.select_type_temporary\n+\t && (tgt = assoc->st->n.sym->assoc->target)\n+\t && gfc_resolve_expr (tgt)\n+\t && tgt->expr_type == EXPR_OP\n+\t && tgt->value.op.op == INTRINSIC_PARENTHESES\n+\t && is_subref_array (tgt->value.op.op1))\n+\t{\n+\t if (gfc_expr_attr (tgt->value.op.op1).pointer)\n+\t op = EXEC_POINTER_ASSIGN;\n+\t else\n+\t op = EXEC_ASSIGN;\n+\t tmp_var = get_temp_from_expr (tgt->value.op.op1, ns->parent, true);\n+\t tmp_code = build_assignment (op, tmp_var, tgt->value.op.op1,\n+\t\t\t\t NULL, NULL, assoc->where);\n+\t assoc->st->n.sym->assoc->target = gfc_copy_expr (tmp_var);\n+\t old_code = gfc_get_code (EXEC_NOP);\n+\t *old_code = *code;\n+\t *code = *tmp_code;\n+\t code->next = old_code;\n+\t free (tmp_code);\n+\t}\n+ }\n \n- /* For an ASSOCIATE block, the associations (and their targets) will be\n- resolved by gfc_resolve_symbol, during resolution of the BLOCK's\n- namespace. */\n gfc_resolve (ns);\n }\n \n-\n /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and\n DO code nodes. */\n \n@@ -13312,263 +13600,9 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)\n }\n \n \n-/* Add a component reference onto an expression. */\n-\n-static void\n-add_comp_ref (gfc_expr *e, gfc_component *c)\n-{\n- gfc_ref **ref;\n- ref = &(e->ref);\n- while (*ref)\n- ref = &((*ref)->next);\n- *ref = gfc_get_ref ();\n- (*ref)->type = REF_COMPONENT;\n- (*ref)->u.c.sym = e->ts.u.derived;\n- (*ref)->u.c.component = c;\n- e->ts = c->ts;\n-\n- /* Add a full array ref, as necessary. */\n- if (c->as)\n- {\n- gfc_add_full_array_ref (e, c->as);\n- e->rank = c->as->rank;\n- e->corank = c->as->corank;\n- }\n-}\n-\n-\n-/* Build an assignment. Keep the argument 'op' for future use, so that\n- pointer assignments can be made. */\n-\n-static gfc_code *\n-build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,\n-\t\t gfc_component *comp1, gfc_component *comp2, locus loc)\n-{\n- gfc_code *this_code;\n-\n- this_code = gfc_get_code (op);\n- this_code->next = NULL;\n- this_code->expr1 = gfc_copy_expr (expr1);\n- this_code->expr2 = gfc_copy_expr (expr2);\n- this_code->loc = loc;\n- if (comp1 && comp2)\n- {\n- add_comp_ref (this_code->expr1, comp1);\n- add_comp_ref (this_code->expr2, comp2);\n- }\n-\n- return this_code;\n-}\n-\n-\n-/* Makes a temporary variable expression based on the characteristics of\n- a given variable expression. If allocatable is set, the temporary is\n- unconditionally allocatable*/\n-\n-static gfc_expr*\n-get_temp_from_expr (gfc_expr *e, gfc_namespace *ns,\n-\t\t bool allocatable = false)\n-{\n- static int serial = 0;\n- char name[GFC_MAX_SYMBOL_LEN];\n- gfc_symtree *tmp;\n- gfc_array_spec *as;\n- gfc_array_ref *aref;\n- gfc_ref *ref;\n-\n- sprintf (name, GFC_PREFIX(\"DA%d\"), serial++);\n- gfc_get_sym_tree (name, ns, &tmp, false);\n- gfc_add_type (tmp->n.sym, &e->ts, NULL);\n-\n- if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)\n- tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,\n-\t\t\t\t\t\t NULL,\n-\t\t\t\t\t\t e->value.character.length);\n-\n- as = NULL;\n- ref = NULL;\n- aref = NULL;\n-\n- /* Obtain the arrayspec for the temporary. */\n- if (e->rank && e->expr_type != EXPR_ARRAY\n- && e->expr_type != EXPR_FUNCTION\n- && e->expr_type != EXPR_OP)\n- {\n- aref = gfc_find_array_ref (e);\n- if (e->expr_type == EXPR_VARIABLE\n-\t && e->symtree->n.sym->as == aref->as)\n-\tas = aref->as;\n- else\n-\t{\n-\t for (ref = e->ref; ref; ref = ref->next)\n-\t if (ref->type == REF_COMPONENT\n-\t\t&& ref->u.c.component->as == aref->as)\n-\t {\n-\t\tas = aref->as;\n-\t\tbreak;\n-\t }\n-\t}\n- }\n-\n- /* Add the attributes and the arrayspec to the temporary. */\n- tmp->n.sym->attr = gfc_expr_attr (e);\n- tmp->n.sym->attr.function = 0;\n- tmp->n.sym->attr.proc_pointer = 0;\n- tmp->n.sym->attr.result = 0;\n- tmp->n.sym->attr.flavor = FL_VARIABLE;\n- tmp->n.sym->attr.dummy = 0;\n- tmp->n.sym->attr.use_assoc = 0;\n- tmp->n.sym->attr.intent = INTENT_UNKNOWN;\n-\n-\n- if (as && !allocatable)\n- {\n- tmp->n.sym->as = gfc_copy_array_spec (as);\n- if (!ref)\n-\tref = e->ref;\n- if (as->type == AS_DEFERRED)\n-\ttmp->n.sym->attr.allocatable = 1;\n- }\n- else if ((e->rank || e->corank)\n-\t && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION\n-\t || e->expr_type == EXPR_OP || allocatable))\n- {\n- tmp->n.sym->as = gfc_get_array_spec ();\n- tmp->n.sym->as->type = AS_DEFERRED;\n- tmp->n.sym->as->rank = e->rank;\n- tmp->n.sym->as->corank = e->corank;\n- tmp->n.sym->attr.allocatable = 1;\n- tmp->n.sym->attr.dimension = e->rank ? 1 : 0;\n- tmp->n.sym->attr.codimension = e->corank ? 1 : 0;\n- }\n- else\n- tmp->n.sym->attr.dimension = 0;\n-\n- gfc_set_sym_referenced (tmp->n.sym);\n- gfc_commit_symbol (tmp->n.sym);\n- e = gfc_lval_expr_from_sym (tmp->n.sym);\n-\n- /* Should the lhs be a section, use its array ref for the\n- temporary expression. */\n- if (aref && aref->type != AR_FULL && !allocatable)\n- {\n- gfc_free_ref_list (e->ref);\n- e->ref = gfc_copy_ref (ref);\n- }\n- return e;\n-}\n-\n-\n-/* Helper function to take an argument in a subroutine call with a dependency\n- on another argument, copy it to an allocatable temporary and use the\n- temporary in the call expression. The new code is embedded in a block to\n- ensure local, automatic deallocation. */\n-\n-static void\n-add_temp_assign_before_call (gfc_code *code, gfc_namespace *ns,\n-\t\t\t gfc_expr **rhsptr)\n-{\n- gfc_namespace *block_ns;\n- gfc_expr *tmp_var;\n-\n- /* Wrap the new code in a block so that the temporary is deallocated. */\n- block_ns = gfc_build_block_ns (ns);\n-\n- /* As it stands, the block_ns does not not stand up to resolution because the\n- the assignment would be converted to a call and, in any case, the modified\n- call fails in gfc_check_conformance. */\n- block_ns->resolved = 1;\n-\n- /* Assign the original expression to the temporary. */\n- tmp_var = get_temp_from_expr (*rhsptr, block_ns, true);\n- block_ns->code = build_assignment (EXEC_ASSIGN, tmp_var, *rhsptr,\n-\t\t\t\t NULL, NULL, (*rhsptr)->where);\n-\n- /* Transfer the call to the block and terminate block code. */\n- *rhsptr = gfc_copy_expr (tmp_var);\n- block_ns->code->next = gfc_get_code (EXEC_NOP);\n- *(block_ns->code->next) = *code;\n- block_ns->code->next->next = NULL;\n-\n- /* Convert the original code to execute the block. */\n- code->op = EXEC_BLOCK;\n- code->ext.block.ns = block_ns;\n- code->ext.block.assoc = NULL;\n- code->expr1 = code->expr2 = NULL;\n-}\n-\n-\n-/* Add one line of code to the code chain, making sure that 'head' and\n- 'tail' are appropriately updated. */\n-\n-static void\n-add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)\n-{\n- gcc_assert (this_code);\n- if (*head == NULL)\n- *head = *tail = *this_code;\n- else\n- *tail = gfc_append_code (*tail, *this_code);\n- *this_code = NULL;\n-}\n-\n-\n-/* Generate a final call from a variable expression */\n-\n-static void\n-generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)\n-{\n- gfc_code *this_code;\n- gfc_expr *final_expr = NULL;\n- gfc_expr *size_expr;\n- gfc_expr *fini_coarray;\n-\n- gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);\n- if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)\n- return;\n-\n- /* Now generate the finalizer call. */\n- this_code = gfc_get_code (EXEC_CALL);\n- this_code->symtree = final_expr->symtree;\n- this_code->resolved_sym = final_expr->symtree->n.sym;\n-\n- //* Expression to be finalized */\n- this_code->ext.actual = gfc_get_actual_arglist ();\n- this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);\n-\n- /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */\n- this_code->ext.actual->next = gfc_get_actual_arglist ();\n- size_expr = gfc_get_expr ();\n- size_expr->where = gfc_current_locus;\n- size_expr->expr_type = EXPR_OP;\n- size_expr->value.op.op = INTRINSIC_DIVIDE;\n- size_expr->value.op.op1\n-\t= gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,\n-\t\t\t\t \"storage_size\", gfc_current_locus, 2,\n-\t\t\t\t gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),\n-\t\t\t\t gfc_get_int_expr (gfc_index_integer_kind,\n-\t\t\t\t\t\t NULL, 0));\n- size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,\n-\t\t\t\t\t gfc_character_storage_size);\n- size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;\n- size_expr->ts = size_expr->value.op.op1->ts;\n- this_code->ext.actual->next->expr = size_expr;\n-\n- /* fini_coarray */\n- this_code->ext.actual->next->next = gfc_get_actual_arglist ();\n- fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,\n-\t\t\t\t\t&tmp_expr->where);\n- fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;\n- this_code->ext.actual->next->next->expr = fini_coarray;\n-\n- add_code_to_chain (&this_code, head, tail);\n-\n-}\n-\n /* Counts the potential number of part array references that would\n result from resolution of typebound defined assignments. */\n \n-\n static int\n nonscalar_typebound_assign (gfc_symbol *derived, int depth)\n {\ndiff --git a/gcc/testsuite/gfortran.dg/associate_79.f90 b/gcc/testsuite/gfortran.dg/associate_79.f90\nnew file mode 100644\nindex 00000000000..ff657e6499e\n--- /dev/null\n+++ b/gcc/testsuite/gfortran.dg/associate_79.f90\n@@ -0,0 +1,43 @@\n+! { dg-do run }\n+! Test the fix for PR121384\n+! Contributed by Mikael Morin \n+program test\n+ implicit none\n+ type :: t\n+ integer :: i,j\n+ end type\n+ type(t) :: a(5)\n+ class(t), allocatable :: c(:)\n+ a = [ t(2,3), t(5,7), t(11,13), t(17,19), t(23,29) ]\n+ associate (x => (a%i))\n+ if (rank(x) /= 1) error stop 11\n+ if (any(shape(x) /= [5])) error stop 12\n+ if (any(x /= [2,5,11,17,23])) error stop 13\n+ x(1) = 3\n+ end associate\n+ if (a(1)%i /= 2) stop 14\n+ associate (x => (a%j))\n+ if (rank(x) /= 1) error stop 21\n+ if (any(shape(x) /= [5])) error stop 22\n+ if (any(x /= [3,7,13,19,29])) error stop 23\n+ x(1) = 4\n+ end associate\n+ if (a(1)%j /= 3) stop 24\n+\n+! Check the class variants\n+ c = a\n+ associate (x => (c%i))\n+ if (rank(x) /= 1) error stop 31\n+ if (any(shape(x) /= [5])) error stop 32\n+ if (any(x /= [2,5,11,17,23])) error stop 33\n+ x(1) = 3\n+ end associate\n+ if (c(1)%i /= 2) stop 34\n+ associate (x => (c%j))\n+ if (rank(x) /= 1) error stop 41\n+ if (any(shape(x) /= [5])) error stop 42\n+ if (any(x /= [3,7,13,19,29])) error stop 43\n+ x(1) = 4\n+ end associate\n+ if (c(1)%j /= 3) stop 44\n+end program\n-- \n2.53.0\n\n","prefixes":["fortran"]}