1! PR 54753 2! { dg-do compile} 3! 4! TS 29113 5! C535c If an assumed-size or nonallocatable nonpointer assumed-rank 6! array is an actual argument corresponding to a dummy argument that 7! is an INTENT(OUT) assumed-rank array, it shall not be polymorphic, [...]. 8! 9! This constraint is numbered C839 in the Fortran 2018 standard. 10! 11! This test file contains tests that are expected to issue diagnostics 12! for invalid code. 13 14module t 15 type :: t1 16 integer :: id 17 real :: xyz(3) 18 end type 19end module 20 21module m 22 use t 23 24 ! Assumed-type dummies are (unlimited) polymorphic too, but F2018:C709 25 ! already prohibits them from being declared intent(out). So we only 26 ! test dummies of class type that are polymorphic or unlimited 27 ! polymorphic. 28 interface 29 subroutine poly (x, y) 30 use t 31 class(t1) :: x(..) 32 class(t1), intent (out) :: y(..) 33 end subroutine 34 subroutine upoly (x, y) 35 class(*) :: x(..) 36 class(*), intent (out) :: y(..) 37 end subroutine 38 end interface 39 40contains 41 42 ! The known-size calls should all be OK as they do not involve 43 ! assumed-size or assumed-rank actual arguments. 44 subroutine test_known_size_nonpolymorphic (a1, a2, n) 45 integer :: n 46 type(t1) :: a1(n,n), a2(n) 47 call poly (a1, a2) 48 call upoly (a1, a2) 49 end subroutine 50 subroutine test_known_size_polymorphic (a1, a2, n) 51 integer :: n 52 class(t1) :: a1(n,n), a2(n) 53 call poly (a1, a2) 54 call upoly (a1, a2) 55 end subroutine 56 subroutine test_known_size_unlimited_polymorphic (a1, a2, n) 57 integer :: n 58 class(*) :: a1(n,n), a2(n) 59 call upoly (a1, a2) 60 end subroutine 61 62 ! Likewise passing a scalar as the assumed-rank argument. 63 subroutine test_scalar_nonpolymorphic (a1, a2) 64 type(t1) :: a1, a2 65 call poly (a1, a2) 66 call upoly (a1, a2) 67 end subroutine 68 subroutine test_scalar_polymorphic (a1, a2) 69 class(t1) :: a1, a2 70 call poly (a1, a2) 71 call upoly (a1, a2) 72 end subroutine 73 subroutine test_scalar_unlimited_polymorphic (a1, a2) 74 class(*) :: a1, a2 75 call upoly (a1, a2) 76 end subroutine 77 78 ! The polymorphic cases for assumed-size are bad. 79 subroutine test_assumed_size_nonpolymorphic (a1, a2) 80 type(t1) :: a1(*), a2(*) 81 call poly (a1, a2) ! OK 82 call upoly (a1, a2) ! OK 83 end subroutine 84 subroutine test_assumed_size_polymorphic (a1, a2) 85 class(t1) :: a1(*), a2(*) 86 call poly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } 87 call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } 88 call poly (a1(5), a2(4:7)) 89 end subroutine 90 subroutine test_assumed_size_unlimited_polymorphic (a1, a2) 91 class(*) :: a1(*), a2(*) 92 call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } 93 end subroutine 94 95 ! The arguments being passed to poly/upoly in this set are *not* 96 ! assumed size and should not error. 97 subroutine test_not_assumed_size_nonpolymorphic (a1, a2) 98 type(t1) :: a1(*), a2(*) 99 call poly (a1(5), a2(4:7)) 100 call upoly (a1(5), a2(4:7)) 101 call poly (a1(:10), a2(:-5)) 102 call upoly (a1(:10), a2(:-5)) 103 end subroutine 104 subroutine test_not_assumed_size_polymorphic (a1, a2) 105 class(t1) :: a1(*), a2(*) 106 call poly (a1(5), a2(4:7)) 107 call upoly (a1(5), a2(4:7)) 108 call poly (a1(:10), a2(:-5)) 109 call upoly (a1(:10), a2(:-5)) 110 end subroutine 111 subroutine test_not_assumed_size_unlimited_polymorphic (a1, a2) 112 class(*) :: a1(*), a2(*) 113 call upoly (a1(5), a2(4:7)) 114 call upoly (a1(:10), a2(:-5)) 115 end subroutine 116 117 ! Polymorphic assumed-rank without pointer/allocatable is also bad. 118 subroutine test_assumed_rank_nonpolymorphic (a1, a2) 119 type(t1) :: a1(..), a2(..) 120 call poly (a1, a2) ! OK 121 call upoly (a1, a2) ! OK 122 end subroutine 123 subroutine test_assumed_rank_polymorphic (a1, a2) 124 class(t1) :: a1(..), a2(..) 125 call poly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } 126 call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } 127 end subroutine 128 subroutine test_assumed_rank_unlimited_polymorphic (a1, a2) 129 class(*) :: a1(..), a2(..) 130 call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } 131 end subroutine 132 133 ! Pointer/allocatable assumed-rank should be OK. 134 subroutine test_pointer_nonpolymorphic (a1, a2) 135 type(t1), pointer :: a1(..), a2(..) 136 call poly (a1, a2) 137 call upoly (a1, a2) 138 end subroutine 139 subroutine test_pointer_polymorphic (a1, a2) 140 class(t1), pointer :: a1(..), a2(..) 141 call poly (a1, a2) 142 call upoly (a1, a2) 143 end subroutine 144 subroutine test_pointer_unlimited_polymorphic (a1, a2) 145 class(*), pointer :: a1(..), a2(..) 146 call upoly (a1, a2) 147 end subroutine 148 149 subroutine test_allocatable_nonpolymorphic (a1, a2) 150 type(t1), allocatable :: a1(..), a2(..) 151 call poly (a1, a2) 152 call upoly (a1, a2) 153 end subroutine 154 subroutine test_allocatable_polymorphic (a1, a2) 155 class(t1), allocatable :: a1(..), a2(..) 156 call poly (a1, a2) 157 call upoly (a1, a2) 158 end subroutine 159 subroutine test_allocatable_unlimited_polymorphic (a1, a2) 160 class(*), allocatable :: a1(..), a2(..) 161 call upoly (a1, a2) 162 end subroutine 163 164end module 165