Hi Sandra,
On 06.10.21 23:37, Sandra Loosemore wrote:
> 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.
>
> (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.
I concur that that should be in a separate PR.
> diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
> ...
> + gfc_array_spec *fas, *aas;
> + bool pointer_arg, allocatable_arg;;
Remove either ";" or ";".
> @@ -3329,13 +3331,48 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
> + if (a->expr->expr_type != EXPR_VARIABLE)
> + {
> + aas = NULL;
> + pointer_arg = false;
> + allocatable_arg = false;
This code is not generic but rather specific.
But it is fine as used in the code.
The question is how to prevent "?" or wrong code for future
code readers and writers.
The issue is that:
* "alloc_array(:)" is not allocatable but allocatable_arg
would be true.
* For var(5)%comp%comp2 - the aas and
allocatable_arg/pointer_arg is based on 'var' and not on
'comp2'.
As those vars are only used with expr->ref == NULL
(or expr->ref == whole-array ref) – and only with
assumed-rank or assumed-size dummys as actual argument,
it works fine as the not-handled code cannot occur.
* * *
Solution: I think the simplest would be to add a comment.
Alternatively:
* For 'aas', one way might be to move to 'enum array_type'
as that makes it clearer that 'aas' is for a special purpose,
only. I mean something like:
enum array_type a_array_type = AS_UNKNOWN;
if (a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym
&& a->expr->symtree->n.sym->as && )
a_array_type = a->expr->symtree->n.sym->as->type;
else if (... BT_CLASS ...)
...
For the attribute, either of the following would work:
* symbol_attribute arg_attr = gfc_expr_attr (e);
This uses the big hammer when a small one would be sufficient,
but it works in general.
or
* bool nonpointer_nonalloc_arg = ...
This uses a more specific name. The attributes might not be
correct, but the chance that it gets misused are reduced.
I think all variants work – and I am not sure what's the best.
There might be also other solutions, which are better/equally
good.
> + 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)))
That's old code – but can you adapt it to handle BT_CLASS? I think
only 'f->sym->attr.pointer' causes the issue as it does not check for
CLASS_DATA()->attr.class_pointer – and the rest is fine, also because
of now using 'aas->type' which already encapsulates the classness.
Testcase:
----------------------
type t
end type t
interface
subroutine fc2 (x)
import :: t
class(t), pointer, intent(in) :: x(..)
end
end interface
contains
subroutine sub1(y)
type(t), target :: y(*)
call fc2 (y) ! silently accepted
end
end
--------------------------
> + 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
Can you also add a call like involving something like:
a1(5), a2(4:7), a1(:10) or a2(:-5) ? (Here, '(:-5)' is a
rank-1, size-zero array.)
Calls with those are valid as those pass the array size alongside.
From the patch it looks as if they should just work, but it is
still good to test this.
> + subroutine test_assumed_size_unlimited_polymorphic (a1, a2)
> + class(*) :: a1(*), a2(*)
> + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" }
> + end subroutine
Likewise.
Otherwise, it looks good to me.
Thanks,
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
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.
@@ -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)
@@ -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
@@ -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
@@ -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
@@ -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