From: Sandra Loosemore <sandra@codesourcery.com>
To: "fortran@gcc.gnu.org" <fortran@gcc.gnu.org>,
"gcc-patches@gcc.gnu.org" <gcc-patches@gcc.gnu.org>
Cc: Tobias Burnus <tobias@codesourcery.com>
Subject: [PATCH, Fortran] Add diagnostic for F2018:C839 (TS29113:C535c)
Date: Wed, 6 Oct 2021 15:37:47 -0600 [thread overview]
Message-ID: <93def131-42e3-e90f-3f9b-aebe6db3dcc3@codesourcery.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 1403 bytes --]
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
[-- Attachment #2: pr54753.patch --]
[-- Type: text/x-patch, Size: 15124 bytes --]
commit d11d942503c884c06155f2743f8ed6c981a65533
Author: Sandra Loosemore <sandra@codesourcery.com>
Date: Mon Sep 27 07:05:32 2021 -0700
Fortran: Add diagnostic for F2018:C839 (TS29113:C535c)
2021-10-06 Sandra Loosemore <sandra@codesourcery.com>
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
next reply other threads:[~2021-10-06 21:37 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-10-06 21:37 Sandra Loosemore [this message]
2021-10-07 15:25 ` Tobias Burnus
2021-10-08 16:58 ` [PATCH v2, " Sandra Loosemore
2021-10-08 19:54 ` Tobias Burnus
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=93def131-42e3-e90f-3f9b-aebe6db3dcc3@codesourcery.com \
--to=sandra@codesourcery.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=tobias@codesourcery.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).