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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
! RUN: %python %S/test_errors.py %s %flang_fc1
! Tests for the ASSOCIATED() and NULL() intrinsics
subroutine assoc()
abstract interface
subroutine subrInt(i)
integer :: i
end subroutine subrInt
integer function abstractIntFunc(x)
integer, intent(in) :: x
end function
end interface
type :: t1
integer :: n
end type t1
type :: t2
type(t1) :: t1arr(2)
type(t1), pointer :: t1ptr(:)
end type t2
contains
integer function intFunc(x)
integer, intent(in) :: x
intFunc = x
end function
real function realFunc(x)
real, intent(in) :: x
realFunc = x
end function
pure integer function pureFunc()
pureFunc = 343
end function pureFunc
elemental integer function elementalFunc(n)
integer, value :: n
elementalFunc = n
end function elementalFunc
subroutine subr(i)
integer :: i
end subroutine subr
subroutine subrCannotBeCalledfromImplicit(i)
integer :: i(:)
end subroutine subrCannotBeCalledfromImplicit
subroutine test(assumedRank)
real, pointer, intent(in out) :: assumedRank(..)
integer :: intVar
integer, target :: targetIntVar1
integer(kind=2), target :: targetIntVar2
real, target :: targetRealVar, targetRealMat(2,2)
real, pointer :: realScalarPtr, realVecPtr(:), realMatPtr(:,:)
integer, pointer :: intPointerVar1
integer, pointer :: intPointerVar2
integer, allocatable :: intAllocVar
procedure(intFunc) :: intProc
procedure(intFunc), pointer :: intprocPointer1
procedure(intFunc), pointer :: intprocPointer2
procedure(realFunc) :: realProc
procedure(realFunc), pointer :: realprocPointer1
procedure(pureFunc), pointer :: pureFuncPointer
procedure(elementalFunc) :: elementalProc
external :: externalProc
procedure(subrInt) :: subProc
procedure(subrInt), pointer :: subProcPointer
procedure(), pointer :: implicitProcPointer
procedure(subrCannotBeCalledfromImplicit), pointer :: cannotBeCalledfromImplicitPointer
logical :: lVar
type(t1) :: t1x
type(t1), target :: t1xtarget
type(t2) :: t2x
type(t2), target :: t2xtarget
integer, target :: targetIntArr(2)
integer, target :: targetIntCoarray[*]
integer, pointer :: intPointerArr(:)
!ERROR: Assumed-rank array cannot be forwarded to 'target=' argument
lvar = associated(assumedRank, assumedRank)
lvar = associated(assumedRank, targetRealVar) ! ok
lvar = associated(assumedRank, targetRealMat) ! ok
lvar = associated(realScalarPtr, targetRealVar) ! ok
!ERROR: 'target=' argument has unacceptable rank 0
lvar = associated(realVecPtr, targetRealVar)
!ERROR: 'target=' argument has unacceptable rank 0
lvar = associated(realMatPtr, targetRealVar)
!ERROR: 'target=' argument has unacceptable rank 2
lvar = associated(realScalarPtr, targetRealMat)
!ERROR: 'target=' argument has unacceptable rank 2
lvar = associated(realVecPtr, targetRealMat)
lvar = associated(realMatPtr, targetRealMat) ! ok
!ERROR: missing mandatory 'pointer=' argument
lVar = associated()
!ERROR: MOLD= argument to NULL() must be a pointer or allocatable
lVar = associated(null(intVar))
lVar = associated(null(intAllocVar)) !OK
lVar = associated(null()) !OK
lVar = associated(null(intPointerVar1)) !OK
!PORTABILITY: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement
!BECAUSE: 'NULL()' is a null pointer
lVar = associated(null(), null()) !OK
lVar = associated(intPointerVar1, null(intPointerVar2)) !OK
lVar = associated(intPointerVar1, null()) !OK
!PORTABILITY: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement
!BECAUSE: 'NULL()' is a null pointer
lVar = associated(null(), null(intPointerVar1)) !OK
!PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
lVar = associated(null(intPointerVar1), null()) !OK
!ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
lVar = associated(intVar)
!ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
lVar = associated(intVar, intVar)
!ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
lVar = associated(intAllocVar)
!ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target
lVar = associated(intPointerVar1, targetRealVar)
lVar = associated(intPointerVar1, targetIntVar1) !OK
!ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target
lVar = associated(intPointerVar1, targetIntVar2)
lVar = associated(intPointerVar1) !OK
lVar = associated(intPointerVar1, intPointerVar2) !OK
!ERROR: In assignment to object pointer 'intpointervar1', the target 'intvar' is not an object with POINTER or TARGET attributes
intPointerVar1 => intVar
!ERROR: TARGET= argument 'intvar' must have either the POINTER or the TARGET attribute
lVar = associated(intPointerVar1, intVar)
!ERROR: TARGET= argument 't1x%n' must have either the POINTER or the TARGET attribute
lVar = associated(intPointerVar1, t1x%n)
lVar = associated(intPointerVar1, t1xtarget%n) ! ok
!ERROR: TARGET= argument 't2x%t1arr(1_8)%n' must have either the POINTER or the TARGET attribute
lVar = associated(intPointerVar1, t2x%t1arr(1)%n)
lVar = associated(intPointerVar1, t2x%t1ptr(1)%n) ! ok
lVar = associated(intPointerVar1, t2xtarget%t1arr(1)%n) ! ok
lVar = associated(intPointerVar1, t2xtarget%t1ptr(1)%n) ! ok
! Procedure pointer tests
intprocPointer1 => intProc !OK
lVar = associated(intprocPointer1, intProc) !OK
intprocPointer1 => intProcPointer2 !OK
lVar = associated(intprocPointer1, intProcPointer2) !OK
intProcPointer1 => null(intProcPointer2) ! ok
lvar = associated(intProcPointer1, null(intProcPointer2)) ! ok
intProcPointer1 => null() ! ok
lvar = associated(intProcPointer1, null()) ! ok
intProcPointer1 => intProcPointer2 ! ok
lvar = associated(intProcPointer1, intProcPointer2) ! ok
intProcPointer1 => null(intProcPointer2) ! ok
lvar = associated(intProcPointer1, null(intProcPointer2)) ! ok
intProcPointer1 =>null() ! ok
lvar = associated(intProcPointer1, null()) ! ok
intPointerVar1 => null(intPointerVar1) ! ok
lvar = associated (intPointerVar1, null(intPointerVar1)) ! ok
!ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
intprocPointer1 => intVar
!ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'intvar' is not a procedure or procedure pointer
lVar = associated(intprocPointer1, intVar)
!ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible procedure attributes: Elemental
intProcPointer1 => elementalProc
!WARNING: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible procedure attributes: Elemental
!ERROR: Non-intrinsic ELEMENTAL procedure 'elementalproc' may not be passed as an actual argument
lvar = associated(intProcPointer1, elementalProc)
!ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is a procedure designator
lvar = associated (intPointerVar1, intFunc)
!ERROR: In assignment to object pointer 'intpointervar1', the target 'intfunc' is a procedure designator
intPointerVar1 => intFunc
!ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
intProcPointer1 => targetIntVar1
!ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'targetintvar1' is not a procedure or procedure pointer
lvar = associated (intProcPointer1, targetIntVar1)
!ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer: function results have distinct types: INTEGER(4) vs REAL(4)
intProcPointer1 => null(mold=realProcPointer1)
!WARNING: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer: function results have distinct types: INTEGER(4) vs REAL(4)
lvar = associated(intProcPointer1, null(mold=realProcPointer1))
!ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
pureFuncPointer => intProc
!WARNING: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
lvar = associated(pureFuncPointer, intProc)
!ERROR: Function pointer 'realprocpointer1' associated with incompatible function designator 'intproc': function results have distinct types: REAL(4) vs INTEGER(4)
realProcPointer1 => intProc
!WARNING: Function pointer 'realprocpointer1' associated with incompatible function designator 'intproc': function results have distinct types: REAL(4) vs INTEGER(4)
lvar = associated(realProcPointer1, intProc)
subProcPointer => externalProc ! OK to associate a procedure pointer with an explicit interface to a procedure with an implicit interface
lvar = associated(subProcPointer, externalProc) ! OK to associate a procedure pointer with an explicit interface to a procedure with an implicit interface
!ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
subProcPointer => intProc
!WARNING: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
lvar = associated(subProcPointer, intProc)
!ERROR: Function pointer 'intprocpointer1' may not be associated with subroutine designator 'subproc'
intProcPointer1 => subProc
!WARNING: Function pointer 'intprocpointer1' may not be associated with subroutine designator 'subproc'
lvar = associated(intProcPointer1, subProc)
implicitProcPointer => subr ! OK for an implicit point to point to an explicit proc
lvar = associated(implicitProcPointer, subr) ! OK
!WARNING: Procedure pointer 'implicitprocpointer' with implicit interface may not be associated with procedure designator 'subrcannotbecalledfromimplicit' with explicit interface that cannot be called via an implicit interface
lvar = associated(implicitProcPointer, subrCannotBeCalledFromImplicit)
!ERROR: Procedure pointer 'cannotbecalledfromimplicitpointer' with explicit interface that cannot be called via an implicit interface cannot be associated with procedure designator with an implicit interface
cannotBeCalledfromImplicitPointer => externalProc
!WARNING: Procedure pointer 'cannotbecalledfromimplicitpointer' with explicit interface that cannot be called via an implicit interface cannot be associated with procedure designator with an implicit interface
lvar = associated(cannotBeCalledfromImplicitPointer, externalProc)
!ERROR: TARGET= argument 'targetintarr([INTEGER(8)::2_8,1_8])' may not have a vector subscript or coindexing
lvar = associated(intPointerArr, targetIntArr([2,1]))
!ERROR: TARGET= argument 'targetintcoarray[1_8]' may not have a vector subscript or coindexing
lvar = associated(intPointerVar1, targetIntCoarray[1])
end subroutine test
end subroutine assoc
|
