unsigned long actual_size, formal_size;
bool full_array = false;
gfc_array_ref *actual_arr_ref;
+ gfc_array_spec *fas, *aas;
+ bool pointer_dummy, pointer_arg, allocatable_arg;
actual = *ap;
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. Note that
+ pointer_arg and allocatable_arg are not fully general and are
+ only used in a specific situation below with an assumed-rank
+ argument. */
+ if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym))
+ {
+ gfc_component *classdata = CLASS_DATA (f->sym);
+ fas = classdata->as;
+ pointer_dummy = classdata->attr.class_pointer;
+ }
+ else
+ {
+ fas = f->sym->as;
+ pointer_dummy = f->sym->attr.pointer;
+ }
+
+ 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 && pointer_dummy))
+ && aas
+ && aas->type == AS_ASSUMED_SIZE
&& (a->expr->ref == NULL
|| (a->expr->ref->type == REF_ARRAY
&& a->expr->ref->u.ar.type == AR_FULL)))
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)
{
&& 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 "
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 "
&& 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)
! 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)
+ class(*) :: a1(n,n), a2(n)
+ call upoly (a1, a2)
+ end subroutine
- call s1_nonpolymorphic (a1, a2)
- call s1_polymorphic (a1, a2)
- call s1_unlimited_polymorphic (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" }
+ call poly (a1(5), a2(4:7))
+ 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
- ! The calls to the polymorphic functions should be rejected
- ! with an assumed-size array argument.
- subroutine test_assumed_size (a1, a2)
+ ! The arguments being passed to poly/upoly in this set are *not*
+ ! assumed size and should not error.
+ subroutine test_not_assumed_size_nonpolymorphic (a1, a2)
type(t1) :: a1(*), a2(*)
+ call poly (a1(5), a2(4:7))
+ call upoly (a1(5), a2(4:7))
+ call poly (a1(:10), a2(:-5))
+ call upoly (a1(:10), a2(:-5))
+ end subroutine
+ subroutine test_not_assumed_size_polymorphic (a1, a2)
+ class(t1) :: a1(*), a2(*)
+ call poly (a1(5), a2(4:7))
+ call upoly (a1(5), a2(4:7))
+ call poly (a1(:10), a2(:-5))
+ call upoly (a1(:10), a2(:-5))
+ end subroutine
+ subroutine test_not_assumed_size_unlimited_polymorphic (a1, a2)
+ class(*) :: a1(*), a2(*)
+ call upoly (a1(5), a2(4:7))
+ call upoly (a1(:10), a2(:-5))
+ 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 *-*-* } }
+ ! Polymorphic assumed-rank without pointer/allocatable is also bad.
+ 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
projects / platform / upstream / gcc.git / commitdiff