1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
! PR 101337
! { dg-do compile }
!
! TS 29113
! C407b An assumed-type variable name shall not appear in a designator
! or expression except as an actual argument corresponding to a dummy
! argument that is assumed-type, or as the first argument to any of
! the intrinsic and intrinsic module functions IS_CONTIGUOUS, LBOUND,
! PRESENT, RANK, SHAPE, SIZE, UBOUND, and C_LOC.
!
! This file contains tests that are expected to give diagnostics.
! Check that passing an assumed-type variable as an actual argument
! corresponding to a non-assumed-type dummy gives a diagnostic.
module m
interface
subroutine f (a, b)
implicit none
integer :: a
integer :: b
end subroutine
subroutine g (a, b)
implicit none
type(*) :: a
integer :: b
end subroutine
subroutine h (a, b)
implicit none
type(*) :: a(*)
integer :: b
end subroutine
end interface
end module
subroutine s0 (x)
use m
implicit none
type(*) :: x
call g (x, 1)
call f (x, 1) ! { dg-error "Type mismatch" }
call h (x, 1) ! Scalar to type(*),dimension(*): Invalid in TS29113 but valid since F2018
end subroutine
! Check that you can't use an assumed-type array variable in an array
! element or section designator.
subroutine s1 (x, y)
use m
implicit none
integer :: x(*)
type(*) :: y(*)
call f (x(1), 1)
call g (y(1), 1) ! { dg-error "Assumed.type" }
call h (y, 1) ! ok
call h (y(1:3:1), 1) ! { dg-error "Assumed.type" }
end subroutine
! Check that you can't use an assumed-type array variable in other
! expressions. This is clearly not exhaustive since few operations
! are even plausible from a type perspective.
subroutine s2 (x, y)
implicit none
type(*) :: x, y
integer :: i
! select type
select type (x) ! { dg-error "Assumed.type|Selector shall be polymorphic" }
type is (integer)
i = 0
type is (real)
i = 1
class default
i = -1
end select
! relational operations
if (x & ! { dg-error "Assumed.type" "pr101337" }
.eq. y) then ! { dg-error "Assumed.type" }
return
end if
if (.not. (x & ! { dg-error "Assumed.type" "pr101337" }
.ne. y)) then ! { dg-error "Assumed.type" }
return
end if
if (.not. x) then ! { dg-error "Assumed.type" }
return
end if
! assignment
x & ! { dg-error "Assumed.type" }
= y ! { dg-error "Assumed.type" }
i = x ! { dg-error "Assumed.type" }
y = i ! { dg-error "Assumed.type" }
! arithmetic
i = x + 1 ! { dg-error "Assumed.type" }
i = -y ! { dg-error "Assumed.type" }
i = (x & ! { dg-error "Assumed.type" "pr101337" }
+ y) ! { dg-error "Assumed.type" }
! computed go to
goto (10, 20, 30), x ! { dg-error "Assumed.type|must be a scalar integer" }
10 continue
20 continue
30 continue
! do loops
do i = 1, x ! { dg-error "Assumed.type" }
continue
end do
do x = 1, i ! { dg-error "Assumed.type" }
continue
end do
end subroutine
! Check that calls to disallowed intrinsic functions produce a diagnostic.
! Again, this isn't exhaustive, there are just too many intrinsics and
! hardly any of them are plausible.
subroutine s3 (x, y)
implicit none
type(*) :: x, y
integer :: i
i = bit_size (x) ! { dg-error "Assumed.type" }
i = exponent (x) ! { dg-error "Assumed.type" }
if (extends_type_of (x, & ! { dg-error "Assumed.type" }
y)) then ! { dg-error "Assumed.type" "pr101337" }
return
end if
if (same_type_as (x, & ! { dg-error "Assumed.type" }
y)) then ! { dg-error "Assumed.type" "pr101337" }
return
end if
i = storage_size (x) ! { dg-error "Assumed.type" }
i = iand (x, & ! { dg-error "Assumed.type" }
y) ! { dg-error "Assumed.type" "pr101337" }
i = kind (x) ! { dg-error "Assumed.type" }
end subroutine
|
