From patchwork Mon Jul 15 16:10:36 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 1960721 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=SWgORGql; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; 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 [IPv6:2620:52:3:1:0:246e:9693:128c]) (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 4WN6dN4ttHz1xr4 for ; Tue, 16 Jul 2024 02:11:19 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8AFD8384AB65 for ; Mon, 15 Jul 2024 16:11:17 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pg1-x52d.google.com (mail-pg1-x52d.google.com [IPv6:2607:f8b0:4864:20::52d]) by sourceware.org (Postfix) with ESMTPS id 4A61D3858D20; Mon, 15 Jul 2024 16:10:49 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 4A61D3858D20 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 4A61D3858D20 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2607:f8b0:4864:20::52d ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1721059851; cv=none; b=r/id5s2Il8JnMNoh929dupWedn0ogpf7woiwnFs/Hyga+ghzKRxXxwsdU06JvVJ9+KHaiGLcTCld98iZXJCVfrsMinIOJ0/VrMaEtXC4lFkog+NqfTZqJpSLIU2taut3QtrR34d6yUH66wzP61wKGIjnpxBkzYpjzXOxRx0cZJA= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1721059851; c=relaxed/simple; bh=0D7BYUEyeo9Kw4hCZLemlxqG0+Chn9noRLyDL2w8VAc=; h=DKIM-Signature:MIME-Version:From:Date:Message-ID:Subject:To; b=l+P8aCzGACz3O/wBrBJjNt5HFFNsKOAwqISGLgI7sRKpJoHWPne1bK9UDJl8Iczqo7TzJZLzMCZ7nJ6+cZtdYUB2lfBDLMqV8pe2HMjSOLf3M673MOm8aJEMHfSJHRoytb4scNutgZiudUkwd770Qfbe7oRyAwZpGoU6G7GiMVE= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-pg1-x52d.google.com with SMTP id 41be03b00d2f7-78512d44a13so2998557a12.1; Mon, 15 Jul 2024 09:10:49 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1721059848; x=1721664648; darn=gcc.gnu.org; h=to:subject:message-id:date:from:mime-version:from:to:cc:subject :date:message-id:reply-to; bh=mfppOwapFOYM2OcL3kUbIa/+djeLDJg/fMLSQtL5gPw=; b=SWgORGqljSbGKgDc5MAhANj9Ta6K6CYt8ESscWTImWKTMECtdxj9MNnGZjdMFT0O3K YVmhmXFLlsPER5SfdWCewJAY0V7/oXmzvDZHG6F+uf0HrhcnhpYz8zNJtHKaJS8GHTgs 7t2kw2An8Ra/EwOArcSigX6sveu6cwK0/sNTmiAqbEgv5NMUkvEl1kcnOC8vPLqskSIa HGFSIStxPhmnXWY6ZCCW/GZwOnKK9nZwiiwkJcPvvHwe0S2D2OfncoMSIkEMOrWdqU4R spDzXdSCICKBYNbn9uqAjQf7C/BLH25+tEwgu5y2Nb8KF1qLOglfQ0d/jQ87qyePxHyD 7JRQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1721059848; x=1721664648; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=mfppOwapFOYM2OcL3kUbIa/+djeLDJg/fMLSQtL5gPw=; b=VGCuLwDwmIsZ2BbX6aKMz5K0NOwxZE7sRYdw1qU6z9KVtso5EBHAsgvTy/o8Ca/Ec2 2AmBO2pr/UMsuVdQtvWp8AQyaHPSzO9Tt8ihmSPO8tX8QwH1acOKds+5kDx7YPHrv2ok 4f5KblG2EPV/YQkJCeHJMgM46rIvu/nhksaK1rM7qjpSOg6a5DnkK+2yg/zDJ1nZrXA6 4wU7oYDJJl80AbeGPxUeipBWyvW2IgJrLQHweE+5NW1tNzpQc4AVMWjxCOO67eGA+fPH /RVwnIQq5NarwrSBbn2u7sWX+0i55n2IjquC0lu/eg9IaxMb4iqmO39BWpIcQImoPnSc vGkw== X-Forwarded-Encrypted: i=1; AJvYcCXU6N5Ply7A4Wz4ft7QQErvC4pxmBo7DoTWpEy58kBnDVj3XVTOB9acf9zuYpVXjzxji8LBzBu4BktU0HBw2DAJgpsOnaBmZA== X-Gm-Message-State: AOJu0YxX3/QXw+j3/8OuRjlZayuGin66IgHxgT3iibwwvO0osxveLna8 KewmH67CSVqgZWEvOL3CUoVohsY3Lif41F5Kjj0rhOi+amxu7V4Qpl9gaeRpq9Y3j1kHCG+3Nel Gl7hDpQoo4ajgDA3ea9+6OToS8enJdXPO X-Google-Smtp-Source: AGHT+IFtsyesvHskouJuxqXi5Q9TQnfWXiLmZp+WCAyjMU4MEDSoTUjsknt8TJOuhuQBZWgmjYXMuzvDkwOqRU0iYMo= X-Received: by 2002:a17:90a:e7cb:b0:2ca:8baf:abe9 with SMTP id 98e67ed59e1d1-2ca8bafb078mr12530227a91.40.1721059847792; Mon, 15 Jul 2024 09:10:47 -0700 (PDT) MIME-Version: 1.0 From: Paul Richard Thomas Date: Mon, 15 Jul 2024 17:10:36 +0100 Message-ID: Subject: [Patch, fortran] PR115070 (and PR115348) - [13/14/15 Regression] ICE using IEEE_ARITHMETIC in a derived type method with class, intent(out) To: "fortran@gcc.gnu.org" , gcc-patches X-Spam-Status: No, score=-7.7 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 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 Hi All, I am not sure that I understand why this bug occurs. The regression was introduced by my patch that had gfc_trans_class_init_assign return NULL_TREE, when all the components of the default initializer are NULL. Note that this only afflicts scalar dummy arguments. With pr115070: void my_sub (struct __class_my_mod_My_type_t & restrict obs) c_char fpstate.5[33]; // This disappears, when NULL is returned. try { _gfortran_ieee_procedure_entry ((void *) &fpstate.5); With pr115348: void myroutine (struct __class_mymodule_Mytype_t & restrict self) { static logical(kind=4) is_recursive.0 = 0; // This disappears when NULL is returned try { if (is_recursive.0) The fix is equally magical in that finishing build_empty_stmt seems to provide the backend with everything that it needs to retain these declarations. See the attached patch. If somebody can explain what causes the problem and why the patch fixes it, I would be very pleased. As far as I can tell, the tail end of trans_code should have been sufficient to handle the return of NULL_TREE. Anyway, work it does and regtests OK. OK for mainline and backporting? Regards Paul diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 477c2720187..d84ab46897f 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1789,10 +1789,12 @@ gfc_trans_class_init_assign (gfc_code *code) { stmtblock_t block; tree tmp; + bool cmp_flag = true; gfc_se dst,src,memsz; gfc_expr *lhs, *rhs, *sz; gfc_component *cmp; gfc_symbol *sym; + gfc_ref *ref; gfc_start_block (&block); @@ -1810,24 +1812,25 @@ gfc_trans_class_init_assign (gfc_code *code) rhs->rank = 0; /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all - default initializer components NULL, return NULL_TREE and use the passed - value as required by F2018(8.5.10). */ + default initializer components NULL, use the passed value even though + F2018(8.5.10) asserts that it should considered to be undefined. This is + needed for consistency with other brands. */ sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym : NULL; if (code->op != EXEC_ALLOCATE && sym && sym->attr.dummy && sym->attr.intent == INTENT_OUT) { - if (!lhs->ref && lhs->symtree->n.sym->attr.dummy) + ref = rhs->ref; + while (ref && ref->next) + ref = ref->next; + cmp = ref->u.c.component->ts.u.derived->components; + for (; cmp; cmp = cmp->next) { - cmp = rhs->ref->next->u.c.component->ts.u.derived->components; - for (; cmp; cmp = cmp->next) - { - if (cmp->initializer) - break; - else if (!cmp->next) - return NULL_TREE; - } + if (cmp->initializer) + break; + else if (!cmp->next) + cmp_flag = false; } } @@ -1841,7 +1844,7 @@ gfc_trans_class_init_assign (gfc_code *code) gfc_add_full_array_ref (lhs, tmparr); tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); } - else + else if (cmp_flag) { /* Scalar initialization needs the _data component. */ gfc_add_data_component (lhs); @@ -1871,6 +1874,8 @@ gfc_trans_class_init_assign (gfc_code *code) tmp, build_empty_stmt (input_location)); } } + else + tmp = build_empty_stmt (input_location); if (code->expr1->symtree->n.sym->attr.dummy && (code->expr1->symtree->n.sym->attr.optional diff --git a/gcc/testsuite/gfortran.dg/pr115070.f90 b/gcc/testsuite/gfortran.dg/pr115070.f90 new file mode 100644 index 00000000000..9378f770e2c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr115070.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! Test the fix for PR115070 +! +! Contributed by Sebastien Bardeau +! +module my_mod + type my_type + integer :: a + contains + final :: myfinal + end type my_type +contains + subroutine my_sub(obs) + use ieee_arithmetic + class(my_type), intent(out) :: obs + end subroutine my_sub + subroutine myfinal (arg) + type (my_type) :: arg + print *, arg%a + end +end module my_mod + + use my_mod + type (my_type) :: z + z%a = 42 + call my_sub (z) +end diff --git a/gcc/testsuite/gfortran.dg/pr115348.f90 b/gcc/testsuite/gfortran.dg/pr115348.f90 new file mode 100644 index 00000000000..bc644b2f1c0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr115348.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-fcheck=recursion" } +! +! Test the fix for pr115348. +! +! Contributed by Maxime van den Bossche +! +module mymodule + implicit none + + type mytype + integer :: mynumber + contains + procedure :: myroutine + end type mytype + + contains + + subroutine myroutine(self) + class(mytype), intent(out) :: self + + self%mynumber = 1 + end subroutine myroutine +end module mymodule + + +program myprogram + use mymodule, only: mytype + implicit none + + type(mytype) :: myobject + + call myobject%myroutine() + print *, myobject%mynumber +end program myprogram