From patchwork Wed Oct 6 21:37:47 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Sandra Loosemore X-Patchwork-Id: 45947 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 5FF1F3858020 for ; Wed, 6 Oct 2021 21:38:23 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa3.mentor.iphmx.com (esa3.mentor.iphmx.com [68.232.137.180]) by sourceware.org (Postfix) with ESMTPS id 1D3E83858C39; Wed, 6 Oct 2021 21:37:56 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 1D3E83858C39 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: l0UmKBZ3nj53zJb7piw4yNF7QluDkDhWJii+PIYcFj59GVYmSlaVjS7yrnu3C3PVy0TeF5SNzv RVo3tc85XxoEEJWy6fVYYenZuyaAtkzE2bXRxtlzezKppYezv4D07E3tEq6d5CNtJD+SUItOve b0m/QplFckoNbxLGHMH0xkTV71Q5nfLWGRTLw/tjBp2eZfLyE0ki+v4ArHn07ivXz38kDhVdL0 ZIlb8CncTO6XLephcl8UyFQEiC+Z/121pQLKDMcbzBMSb6vPSZucc9fkW0UfxeGxpqDo1rI5Wd 44TW0oi40Wsjsuj6XvYQThzf X-IronPort-AV: E=Sophos;i="5.85,352,1624348800"; d="scan'208";a="66746033" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa3.mentor.iphmx.com with ESMTP; 06 Oct 2021 13:37:54 -0800 IronPort-SDR: pAwuoephQz95mzMOlzmZpFPJGh6+7YT+uNFUXWGO4oTC7ro3LYXulSpnsRGBvNYKVovLJ2f2U4 1+qYMQDbKNeUe3Uc65rpCJSODibmwfLxZcnltfq/4L7WBPJ9ROTNwUrOlys2VCtK8E3wRyWkJC QemY1BQo1uLFdhJ6IVtEy/h/RGXdoK22+9cz23eWnJAu6GL9uNBXRd4zoI1s564zJpys+66Qj3 avpbnd4zGXt0aPuekwihgw5lccwZOV8EykciW82yujhSwHIZJDg5WqAoN0gzbP+xOjOtQKRGF0 bIo= To: "fortran@gcc.gnu.org" , "gcc-patches@gcc.gnu.org" From: Sandra Loosemore Subject: [PATCH, Fortran] Add diagnostic for F2018:C839 (TS29113:C535c) Message-ID: <93def131-42e3-e90f-3f9b-aebe6db3dcc3@codesourcery.com> Date: Wed, 6 Oct 2021 15:37:47 -0600 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.13.0 MIME-Version: 1.0 Content-Language: en-US X-ClientProxiedBy: SVR-ORW-MBX-07.mgc.mentorg.com (147.34.90.207) To svr-orw-mbx-04.mgc.mentorg.com (147.34.90.204) X-Spam-Status: No, score=-9.8 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org 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: , Cc: Tobias Burnus Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch is for PR fortran/54753, to add a diagnostic for violations of this constraint in the 2018 standard: C839 If an assumed-size or nonallocatable nonpointer assumed-rank array is an actual argument that corresponds to a dummy argument that is an INTENT (OUT) assumed-rank array, it shall not be polymorphic, finalizable, of a type with an allocatable ultimate component, or of a type for which default initialization is specified. The last 3 clauses were fairly straightforward, but the "polymorphic" case gave me fits because I didn't initially understand that the front end stores flags for class types in different places than for non-class types. I must give Tobias credit for straightening me out on that and some other obscure points that were confusing me, but he deserves none of the blame for this patch. :-P This patch fixes all the missing diagnostics and ICEs I previously reported in the PR, but I ended up completely rewriting the c535c-1 test case that formerly produced a bogus diagnostic. (It now uses an interface instead of an actual subroutine definition, since Tobias recently committed a patch to fix interfaces in order to unblock my work on this one.) That bug is independent of enforcing this constraint so I'm planning to open a new issue for it with its own test case, if there isn't already one in Bugzilla. OK to commit? -Sandra commit d11d942503c884c06155f2743f8ed6c981a65533 Author: Sandra Loosemore Date: Mon Sep 27 07:05:32 2021 -0700 Fortran: Add diagnostic for F2018:C839 (TS29113:C535c) 2021-10-06 Sandra Loosemore PR fortran/54753 gcc/fortran/ * interface.c (gfc_compare_actual_formal): Add diagnostic for F2018:C839. Refactor shared code and fix bugs with class array info lookup, and add comments to diagnostic from PR94110 that is structured similarly to the new diagnostic. gcc/testsuite/ * gfortran.dg/c-interop/c535c-1.f90: Rewrite and expand. * gfortran.dg/c-interop/c535c-2.f90: Remove xfails. * gfortran.dg/c-interop/c535c-3.f90: Likewise. * gfortran.dg/c-interop/c535c-4.f90: Likewise. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index a2fea0e97b8..9d13575cbf0 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -3061,6 +3061,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, unsigned long actual_size, formal_size; bool full_array = false; gfc_array_ref *actual_arr_ref; + gfc_array_spec *fas, *aas; + bool pointer_arg, allocatable_arg;; actual = *ap; @@ -3329,13 +3331,48 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return false; } - if (f->sym->as - && (f->sym->as->type == AS_ASSUMED_SHAPE - || f->sym->as->type == AS_DEFERRED - || (f->sym->as->type == AS_ASSUMED_RANK && f->sym->attr.pointer)) - && a->expr->expr_type == EXPR_VARIABLE - && a->expr->symtree->n.sym->as - && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE + /* Class array variables and expressions store array info in a + different place from non-class objects; consolidate the logic + to access it here instead of repeating it below. */ + fas = (f->sym->ts.type == BT_CLASS + ? CLASS_DATA (f->sym)->as + : f->sym->as); + if (a->expr->expr_type != EXPR_VARIABLE) + { + aas = NULL; + pointer_arg = false; + allocatable_arg = false; + } + else if (a->expr->ts.type == BT_CLASS + && a->expr->symtree->n.sym + && CLASS_DATA (a->expr->symtree->n.sym)) + { + gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym); + aas = classdata->as; + pointer_arg = classdata->attr.class_pointer; + allocatable_arg = classdata->attr.allocatable; + } + else + { + aas = a->expr->symtree->n.sym->as; + pointer_arg = a->expr->symtree->n.sym->attr.pointer; + allocatable_arg = a->expr->symtree->n.sym->attr.allocatable; + } + + /* F2018:9.5.2(2) permits assumed-size whole array expressions as + actual arguments only if the shape is not required; thus it + cannot be passed to an assumed-shape array dummy. + F2018:15.5.2.(2) permits passing a nonpointer actual to an + intent(in) pointer dummy argument and this is accepted by + the compare_pointer check below, but this also requires shape + information. + There's more discussion of this in PR94110. */ + if (fas + && (fas->type == AS_ASSUMED_SHAPE + || fas->type == AS_DEFERRED + || (fas->type == AS_ASSUMED_RANK && f->sym->attr.pointer)) + && aas + && aas->type == AS_ASSUMED_SIZE && (a->expr->ref == NULL || (a->expr->ref->type == REF_ARRAY && a->expr->ref->u.ar.type == AR_FULL))) @@ -3346,6 +3383,35 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return false; } + /* Diagnose F2018 C839 (TS29113 C535c). Here the problem is + passing an assumed-size array to an INTENT(OUT) assumed-rank + dummy when it doesn't have the size information needed to run + initializers and finalizers. */ + if (f->sym->attr.intent == INTENT_OUT + && fas + && fas->type == AS_ASSUMED_RANK + && aas + && ((aas->type == AS_ASSUMED_SIZE + && (a->expr->ref == NULL + || (a->expr->ref->type == REF_ARRAY + && a->expr->ref->u.ar.type == AR_FULL))) + || (aas->type == AS_ASSUMED_RANK + && !pointer_arg + && !allocatable_arg)) + && (a->expr->ts.type == BT_CLASS + || (a->expr->ts.type == BT_DERIVED + && (gfc_is_finalizable (a->expr->ts.u.derived, NULL) + || gfc_has_ultimate_allocatable (a->expr) + || gfc_has_default_initializer + (a->expr->ts.u.derived))))) + { + if (where) + gfc_error ("Actual argument to assumed-rank INTENT(OUT) " + "dummy %qs at %L cannot be of unknown size", + f->sym->name, where); + return false; + } + if (a->expr->expr_type != EXPR_NULL && compare_pointer (f->sym, a->expr) == 0) { @@ -3479,7 +3545,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym->as && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE - && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) + && !(fas && fas->type == AS_ASSUMED_SHAPE)) { if (where) gfc_error ("Assumed-shape actual argument at %L is " @@ -3496,7 +3562,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (f->sym->attr.volatile_ && actual_arr_ref && actual_arr_ref->type == AR_SECTION - && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) + && !(fas && fas->type == AS_ASSUMED_SHAPE)) { if (where) gfc_error ("Array-section actual argument at %L is " @@ -3514,8 +3580,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym->attr.pointer && a->expr->symtree->n.sym->as - && !(f->sym->as - && (f->sym->as->type == AS_ASSUMED_SHAPE + && !(fas + && (fas->type == AS_ASSUMED_SHAPE || f->sym->attr.pointer))) { if (where) diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 index b4047139eaf..b7999a70d5f 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 @@ -11,77 +11,131 @@ ! This test file contains tests that are expected to issue diagnostics ! for invalid code. -module m - +module t type :: t1 integer :: id real :: xyz(3) end type +end module -contains +module m + use t + + ! Assumed-type dummies are (unlimited) polymorphic too, but F2018:C709 + ! already prohibits them from being declared intent(out). So we only + ! test dummies of class type that are polymorphic or unlimited + ! polymorphic. + interface + subroutine poly (x, y) + use t + class(t1) :: x(..) + class(t1), intent (out) :: y(..) + end subroutine + subroutine upoly (x, y) + class(*) :: x(..) + class(*), intent (out) :: y(..) + end subroutine + end interface - subroutine s1_nonpolymorphic (x, y) - type(t1) :: x(..) - type(t1), intent(out) :: y(..) - end subroutine +contains - subroutine s1_polymorphic (x, y) ! { dg-bogus "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } - class(t1) :: x(..) - class(t1), intent(out) :: y(..) + ! The known-size calls should all be OK as they do not involve + ! assumed-size or assumed-rank actual arguments. + subroutine test_known_size_nonpolymorphic (a1, a2, n) + integer :: n + type(t1) :: a1(n,n), a2(n) + call poly (a1, a2) + call upoly (a1, a2) end subroutine - - subroutine s1_unlimited_polymorphic (x, y) ! { dg-bogus "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } - class(*) :: x(..) - class(*), intent(out) :: y(..) + subroutine test_known_size_polymorphic (a1, a2, n) + integer :: n + class(t1) :: a1(n,n), a2(n) + call poly (a1, a2) + call upoly (a1, a2) end subroutine - - ! These calls should all be OK as they do not involve assumed-size or - ! assumed-rank actual arguments. - subroutine test_known_size (a1, a2, n) + subroutine test_known_size_unlimited_polymorphic (a1, a2, n) integer :: n - type(t1) :: a1(n,n), a2(n) - - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) - call s1_unlimited_polymorphic (a1, a2) + class(*) :: a1(n,n), a2(n) + call upoly (a1, a2) end subroutine - ! The calls to the polymorphic functions should be rejected - ! with an assumed-size array argument. - subroutine test_assumed_size (a1, a2) + ! Likewise passing a scalar as the assumed-rank argument. + subroutine test_scalar_nonpolymorphic (a1, a2) + type(t1) :: a1, a2 + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_scalar_polymorphic (a1, a2) + class(t1) :: a1, a2 + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_scalar_unlimited_polymorphic (a1, a2) + class(*) :: a1, a2 + call upoly (a1, a2) + end subroutine + + ! The polymorphic cases for assumed-size are bad. + subroutine test_assumed_size_nonpolymorphic (a1, a2) type(t1) :: a1(*), a2(*) + call poly (a1, a2) ! OK + call upoly (a1, a2) ! OK + end subroutine + subroutine test_assumed_size_polymorphic (a1, a2) + class(t1) :: a1(*), a2(*) + call poly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + subroutine test_assumed_size_unlimited_polymorphic (a1, a2) + class(*) :: a1(*), a2(*) + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } - call s1_unlimited_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + ! Likewise for polymorphic assumed-rank without pointer/allocatable. + subroutine test_assumed_rank_nonpolymorphic (a1, a2) + type(t1) :: a1(..), a2(..) + call poly (a1, a2) ! OK + call upoly (a1, a2) ! OK + end subroutine + subroutine test_assumed_rank_polymorphic (a1, a2) + class(t1) :: a1(..), a2(..) + call poly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + subroutine test_assumed_rank_unlimited_polymorphic (a1, a2) + class(*) :: a1(..), a2(..) + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine - ! These calls should be OK. - subroutine test_assumed_rank_pointer (a1, a2) + ! Pointer/allocatable assumed-rank should be OK. + subroutine test_pointer_nonpolymorphic (a1, a2) type(t1), pointer :: a1(..), a2(..) - - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) - call s1_unlimited_polymorphic (a1, a2) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_pointer_polymorphic (a1, a2) + class(t1), pointer :: a1(..), a2(..) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_pointer_unlimited_polymorphic (a1, a2) + class(*), pointer :: a1(..), a2(..) + call upoly (a1, a2) end subroutine - ! These calls should be OK. - subroutine test_assumed_rank_allocatable (a1, a2) + subroutine test_allocatable_nonpolymorphic (a1, a2) type(t1), allocatable :: a1(..), a2(..) - - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) - call s1_unlimited_polymorphic (a1, a2) + call poly (a1, a2) + call upoly (a1, a2) end subroutine - - ! The calls to the polymorphic functions should be rejected - ! with a nonallocatable nonpointer assumed-rank actual argument. - subroutine test_assumed_rank_plain (a1, a2) - type(t1) :: a1(..), a2(..) - - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } - call s1_unlimited_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + subroutine test_allocatable_polymorphic (a1, a2) + class(t1), allocatable :: a1(..), a2(..) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_allocatable_unlimited_polymorphic (a1, a2) + class(*), allocatable :: a1(..), a2(..) + call upoly (a1, a2) end subroutine end module diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 index db15ece9809..f232efae9fc 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 @@ -45,7 +45,7 @@ contains subroutine test_assumed_size (a1, a2) type(t1) :: a1(*), a2(*) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine ! This call should be OK. @@ -67,7 +67,7 @@ contains subroutine test_assumed_rank_plain (a1, a2) type(t1) :: a1(..), a2(..) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine end module diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 index 5c224b1f8bd..50840a1ba5f 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 @@ -1,6 +1,5 @@ ! PR 54753 ! { dg-do compile } -! { dg-ice "pr54753" } ! ! TS 29113 ! C535c If an assumed-size or nonallocatable nonpointer assumed-rank @@ -45,7 +44,7 @@ contains subroutine test_assumed_size (a1, a2) type(t1) :: a1(*), a2(*) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine ! This call should be OK. @@ -67,7 +66,7 @@ contains subroutine test_assumed_rank_plain (a1, a2) type(t1) :: a1(..), a2(..) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine end module diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 index ecbb18187dd..dc380baf465 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 @@ -1,6 +1,5 @@ ! PR 54753 ! { dg-do compile } -! { dg-ice "pr54753" } ! ! TS 29113 ! C535c If an assumed-size or nonallocatable nonpointer assumed-rank @@ -45,7 +44,7 @@ contains subroutine test_assumed_size (a1, a2) type(t1) :: a1(*), a2(*) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine ! This call should be OK. @@ -67,7 +66,7 @@ contains subroutine test_assumed_rank_plain (a1, a2) type(t1) :: a1(..), a2(..) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine end module