|
173
|
1 //===-- lib/Semantics/check-call.cpp --------------------------------------===//
|
|
|
2 //
|
|
|
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
|
|
|
4 // See https://llvm.org/LICENSE.txt for license information.
|
|
|
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
|
|
|
6 //
|
|
|
7 //===----------------------------------------------------------------------===//
|
|
|
8
|
|
|
9 #include "check-call.h"
|
|
|
10 #include "pointer-assignment.h"
|
|
|
11 #include "flang/Evaluate/characteristics.h"
|
|
|
12 #include "flang/Evaluate/check-expression.h"
|
|
|
13 #include "flang/Evaluate/shape.h"
|
|
|
14 #include "flang/Evaluate/tools.h"
|
|
|
15 #include "flang/Parser/characters.h"
|
|
|
16 #include "flang/Parser/message.h"
|
|
|
17 #include "flang/Semantics/scope.h"
|
|
|
18 #include "flang/Semantics/tools.h"
|
|
|
19 #include <map>
|
|
|
20 #include <string>
|
|
|
21
|
|
|
22 using namespace Fortran::parser::literals;
|
|
|
23 namespace characteristics = Fortran::evaluate::characteristics;
|
|
|
24
|
|
|
25 namespace Fortran::semantics {
|
|
|
26
|
|
|
27 static void CheckImplicitInterfaceArg(
|
|
|
28 evaluate::ActualArgument &arg, parser::ContextualMessages &messages) {
|
|
|
29 if (auto kw{arg.keyword()}) {
|
|
|
30 messages.Say(*kw,
|
|
|
31 "Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US,
|
|
|
32 *kw);
|
|
|
33 }
|
|
|
34 if (auto type{arg.GetType()}) {
|
|
|
35 if (type->IsAssumedType()) {
|
|
|
36 messages.Say(
|
|
|
37 "Assumed type argument requires an explicit interface"_err_en_US);
|
|
|
38 } else if (type->IsPolymorphic()) {
|
|
|
39 messages.Say(
|
|
|
40 "Polymorphic argument requires an explicit interface"_err_en_US);
|
|
|
41 } else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
|
|
|
42 if (!derived->parameters().empty()) {
|
|
|
43 messages.Say(
|
|
|
44 "Parameterized derived type argument requires an explicit interface"_err_en_US);
|
|
|
45 }
|
|
|
46 }
|
|
|
47 }
|
|
|
48 if (const auto *expr{arg.UnwrapExpr()}) {
|
|
|
49 if (auto named{evaluate::ExtractNamedEntity(*expr)}) {
|
|
|
50 const Symbol &symbol{named->GetLastSymbol()};
|
|
|
51 if (symbol.Corank() > 0) {
|
|
|
52 messages.Say(
|
|
|
53 "Coarray argument requires an explicit interface"_err_en_US);
|
|
|
54 }
|
|
|
55 if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
|
|
|
56 if (details->IsAssumedRank()) {
|
|
|
57 messages.Say(
|
|
|
58 "Assumed rank argument requires an explicit interface"_err_en_US);
|
|
|
59 }
|
|
|
60 }
|
|
|
61 if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
|
|
|
62 messages.Say(
|
|
|
63 "ASYNCHRONOUS argument requires an explicit interface"_err_en_US);
|
|
|
64 }
|
|
|
65 if (symbol.attrs().test(Attr::VOLATILE)) {
|
|
|
66 messages.Say(
|
|
|
67 "VOLATILE argument requires an explicit interface"_err_en_US);
|
|
|
68 }
|
|
|
69 }
|
|
|
70 }
|
|
|
71 }
|
|
|
72
|
|
|
73 // When scalar CHARACTER actual arguments are known to be short,
|
|
|
74 // we extend them on the right with spaces and a warning.
|
|
|
75 static void PadShortCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
|
|
|
76 const characteristics::TypeAndShape &dummyType,
|
|
|
77 const characteristics::TypeAndShape &actualType,
|
|
|
78 parser::ContextualMessages &messages) {
|
|
|
79 if (dummyType.type().category() == TypeCategory::Character &&
|
|
|
80 actualType.type().category() == TypeCategory::Character &&
|
|
|
81 dummyType.type().kind() == actualType.type().kind() &&
|
|
|
82 GetRank(actualType.shape()) == 0) {
|
|
|
83 if (auto dummyLEN{ToInt64(dummyType.LEN())}) {
|
|
|
84 if (auto actualLEN{ToInt64(actualType.LEN())}) {
|
|
|
85 if (*actualLEN < *dummyLEN) {
|
|
|
86 messages.Say(
|
|
|
87 "Actual length '%jd' is less than expected length '%jd'"_en_US,
|
|
|
88 *actualLEN, *dummyLEN);
|
|
|
89 auto converted{ConvertToType(dummyType.type(), std::move(actual))};
|
|
|
90 CHECK(converted);
|
|
|
91 actual = std::move(*converted);
|
|
|
92 }
|
|
|
93 }
|
|
|
94 }
|
|
|
95 }
|
|
|
96 }
|
|
|
97
|
|
|
98 // Automatic conversion of different-kind INTEGER scalar actual
|
|
|
99 // argument expressions (not variables) to INTEGER scalar dummies.
|
|
|
100 // We return nonstandard INTEGER(8) results from intrinsic functions
|
|
|
101 // like SIZE() by default in order to facilitate the use of large
|
|
|
102 // arrays. Emit a warning when downconverting.
|
|
|
103 static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
|
|
|
104 const characteristics::TypeAndShape &dummyType,
|
|
|
105 characteristics::TypeAndShape &actualType,
|
|
|
106 parser::ContextualMessages &messages) {
|
|
|
107 if (dummyType.type().category() == TypeCategory::Integer &&
|
|
|
108 actualType.type().category() == TypeCategory::Integer &&
|
|
|
109 dummyType.type().kind() != actualType.type().kind() &&
|
|
|
110 GetRank(dummyType.shape()) == 0 && GetRank(actualType.shape()) == 0 &&
|
|
|
111 !evaluate::IsVariable(actual)) {
|
|
|
112 auto converted{
|
|
|
113 evaluate::ConvertToType(dummyType.type(), std::move(actual))};
|
|
|
114 CHECK(converted);
|
|
|
115 actual = std::move(*converted);
|
|
|
116 if (dummyType.type().kind() < actualType.type().kind()) {
|
|
|
117 messages.Say(
|
|
|
118 "Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_en_US,
|
|
|
119 actualType.type().kind(), dummyType.type().kind());
|
|
|
120 }
|
|
|
121 actualType = dummyType;
|
|
|
122 }
|
|
|
123 }
|
|
|
124
|
|
|
125 static bool DefersSameTypeParameters(
|
|
|
126 const DerivedTypeSpec &actual, const DerivedTypeSpec &dummy) {
|
|
|
127 for (const auto &pair : actual.parameters()) {
|
|
|
128 const ParamValue &actualValue{pair.second};
|
|
|
129 const ParamValue *dummyValue{dummy.FindParameter(pair.first)};
|
|
|
130 if (!dummyValue || (actualValue.isDeferred() != dummyValue->isDeferred())) {
|
|
|
131 return false;
|
|
|
132 }
|
|
|
133 }
|
|
|
134 return true;
|
|
|
135 }
|
|
|
136
|
|
|
137 static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
|
|
|
138 const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
|
|
|
139 characteristics::TypeAndShape &actualType, bool isElemental,
|
|
|
140 bool actualIsArrayElement, evaluate::FoldingContext &context,
|
|
|
141 const Scope *scope) {
|
|
|
142
|
|
|
143 // Basic type & rank checking
|
|
|
144 parser::ContextualMessages &messages{context.messages()};
|
|
|
145 PadShortCharacterActual(actual, dummy.type, actualType, messages);
|
|
|
146 ConvertIntegerActual(actual, dummy.type, actualType, messages);
|
|
|
147 bool typesCompatible{
|
|
|
148 dummy.type.type().IsTypeCompatibleWith(actualType.type())};
|
|
|
149 if (typesCompatible) {
|
|
|
150 if (isElemental) {
|
|
|
151 } else if (dummy.type.attrs().test(
|
|
|
152 characteristics::TypeAndShape::Attr::AssumedRank)) {
|
|
|
153 } else if (!dummy.type.attrs().test(
|
|
|
154 characteristics::TypeAndShape::Attr::AssumedShape) &&
|
|
|
155 (actualType.Rank() > 0 || actualIsArrayElement)) {
|
|
|
156 // Sequence association (15.5.2.11) applies -- rank need not match
|
|
|
157 // if the actual argument is an array or array element designator.
|
|
|
158 } else {
|
|
|
159 CheckConformance(messages, dummy.type.shape(), actualType.shape(),
|
|
|
160 "dummy argument", "actual argument");
|
|
|
161 }
|
|
|
162 } else {
|
|
|
163 const auto &len{actualType.LEN()};
|
|
|
164 messages.Say(
|
|
|
165 "Actual argument type '%s' is not compatible with dummy argument type '%s'"_err_en_US,
|
|
|
166 actualType.type().AsFortran(len ? len->AsFortran() : ""),
|
|
|
167 dummy.type.type().AsFortran());
|
|
|
168 }
|
|
|
169
|
|
|
170 bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
|
|
|
171 bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
|
|
|
172 bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()};
|
|
|
173 bool actualIsAssumedSize{actualType.attrs().test(
|
|
|
174 characteristics::TypeAndShape::Attr::AssumedSize)};
|
|
|
175 bool dummyIsAssumedSize{dummy.type.attrs().test(
|
|
|
176 characteristics::TypeAndShape::Attr::AssumedSize)};
|
|
|
177 bool dummyIsAsynchronous{
|
|
|
178 dummy.attrs.test(characteristics::DummyDataObject::Attr::Asynchronous)};
|
|
|
179 bool dummyIsVolatile{
|
|
|
180 dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)};
|
|
|
181 bool dummyIsValue{
|
|
|
182 dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};
|
|
|
183
|
|
|
184 if (actualIsPolymorphic && dummyIsPolymorphic &&
|
|
|
185 actualIsCoindexed) { // 15.5.2.4(2)
|
|
|
186 messages.Say(
|
|
|
187 "Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US,
|
|
|
188 dummyName);
|
|
|
189 }
|
|
|
190 if (actualIsPolymorphic && !dummyIsPolymorphic &&
|
|
|
191 actualIsAssumedSize) { // 15.5.2.4(2)
|
|
|
192 messages.Say(
|
|
|
193 "Assumed-size polymorphic array may not be associated with a monomorphic %s"_err_en_US,
|
|
|
194 dummyName);
|
|
|
195 }
|
|
|
196
|
|
|
197 // Derived type actual argument checks
|
|
|
198 const Symbol *actualFirstSymbol{evaluate::GetFirstSymbol(actual)};
|
|
|
199 bool actualIsAsynchronous{
|
|
|
200 actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)};
|
|
|
201 bool actualIsVolatile{
|
|
|
202 actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};
|
|
|
203 if (const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}) {
|
|
|
204 if (dummy.type.type().IsAssumedType()) {
|
|
|
205 if (!derived->parameters().empty()) { // 15.5.2.4(2)
|
|
|
206 messages.Say(
|
|
|
207 "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
|
|
|
208 dummyName);
|
|
|
209 }
|
|
|
210 if (const Symbol *
|
|
|
211 tbp{FindImmediateComponent(*derived, [](const Symbol &symbol) {
|
|
|
212 return symbol.has<ProcBindingDetails>();
|
|
|
213 })}) { // 15.5.2.4(2)
|
|
|
214 evaluate::SayWithDeclaration(messages, *tbp,
|
|
|
215 "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
|
|
|
216 dummyName, tbp->name());
|
|
|
217 }
|
|
|
218 if (const Symbol *
|
|
|
219 finalizer{FindImmediateComponent(*derived, [](const Symbol &symbol) {
|
|
|
220 return symbol.has<FinalProcDetails>();
|
|
|
221 })}) { // 15.5.2.4(2)
|
|
|
222 evaluate::SayWithDeclaration(messages, *finalizer,
|
|
|
223 "Actual argument associated with TYPE(*) %s may not have FINAL subroutine '%s'"_err_en_US,
|
|
|
224 dummyName, finalizer->name());
|
|
|
225 }
|
|
|
226 }
|
|
|
227 if (actualIsCoindexed) {
|
|
|
228 if (dummy.intent != common::Intent::In && !dummyIsValue) {
|
|
|
229 if (auto bad{
|
|
|
230 FindAllocatableUltimateComponent(*derived)}) { // 15.5.2.4(6)
|
|
|
231 evaluate::SayWithDeclaration(messages, *bad,
|
|
|
232 "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
|
|
|
233 bad.BuildResultDesignatorName(), dummyName);
|
|
|
234 }
|
|
|
235 }
|
|
|
236 if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537
|
|
|
237 const Symbol &coarray{coarrayRef->GetLastSymbol()};
|
|
|
238 if (const DeclTypeSpec * type{coarray.GetType()}) {
|
|
|
239 if (const DerivedTypeSpec * derived{type->AsDerived()}) {
|
|
|
240 if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
|
|
|
241 evaluate::SayWithDeclaration(messages, coarray,
|
|
|
242 "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
|
|
|
243 coarray.name(), bad.BuildResultDesignatorName(), dummyName);
|
|
|
244 }
|
|
|
245 }
|
|
|
246 }
|
|
|
247 }
|
|
|
248 }
|
|
|
249 if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
|
|
|
250 if (auto bad{semantics::FindCoarrayUltimateComponent(*derived)}) {
|
|
|
251 evaluate::SayWithDeclaration(messages, *bad,
|
|
|
252 "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
|
|
|
253 dummyName, bad.BuildResultDesignatorName());
|
|
|
254 }
|
|
|
255 }
|
|
|
256 }
|
|
|
257
|
|
|
258 // Rank and shape checks
|
|
|
259 const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)};
|
|
|
260 if (actualLastSymbol) {
|
|
|
261 actualLastSymbol = GetAssociationRoot(*actualLastSymbol);
|
|
|
262 }
|
|
|
263 const ObjectEntityDetails *actualLastObject{actualLastSymbol
|
|
|
264 ? actualLastSymbol->GetUltimate().detailsIf<ObjectEntityDetails>()
|
|
|
265 : nullptr};
|
|
|
266 int actualRank{evaluate::GetRank(actualType.shape())};
|
|
|
267 bool actualIsPointer{(actualLastSymbol && IsPointer(*actualLastSymbol)) ||
|
|
|
268 evaluate::IsNullPointer(actual)};
|
|
|
269 if (dummy.type.attrs().test(
|
|
|
270 characteristics::TypeAndShape::Attr::AssumedShape)) {
|
|
|
271 // 15.5.2.4(16)
|
|
|
272 if (actualRank == 0) {
|
|
|
273 messages.Say(
|
|
|
274 "Scalar actual argument may not be associated with assumed-shape %s"_err_en_US,
|
|
|
275 dummyName);
|
|
|
276 }
|
|
|
277 if (actualIsAssumedSize && actualLastSymbol) {
|
|
|
278 evaluate::SayWithDeclaration(messages, *actualLastSymbol,
|
|
|
279 "Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
|
|
|
280 dummyName);
|
|
|
281 }
|
|
|
282 } else if (actualRank == 0 && dummy.type.Rank() > 0) {
|
|
|
283 // Actual is scalar, dummy is an array. 15.5.2.4(14), 15.5.2.11
|
|
|
284 if (actualIsCoindexed) {
|
|
|
285 messages.Say(
|
|
|
286 "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
|
|
|
287 dummyName);
|
|
|
288 }
|
|
|
289 if (actualLastSymbol && actualLastSymbol->Rank() == 0 &&
|
|
|
290 !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize)) {
|
|
|
291 messages.Say(
|
|
|
292 "Whole scalar actual argument may not be associated with a %s array"_err_en_US,
|
|
|
293 dummyName);
|
|
|
294 }
|
|
|
295 if (actualIsPolymorphic) {
|
|
|
296 messages.Say(
|
|
|
297 "Polymorphic scalar may not be associated with a %s array"_err_en_US,
|
|
|
298 dummyName);
|
|
|
299 }
|
|
|
300 if (actualIsPointer) {
|
|
|
301 messages.Say(
|
|
|
302 "Scalar POINTER target may not be associated with a %s array"_err_en_US,
|
|
|
303 dummyName);
|
|
|
304 }
|
|
|
305 if (actualLastObject && actualLastObject->IsAssumedShape()) {
|
|
|
306 messages.Say(
|
|
|
307 "Element of assumed-shape array may not be associated with a %s array"_err_en_US,
|
|
|
308 dummyName);
|
|
|
309 }
|
|
|
310 }
|
|
|
311 if (actualLastObject && actualLastObject->IsCoarray() &&
|
|
|
312 IsAllocatable(*actualLastSymbol) &&
|
|
|
313 dummy.intent == common::Intent::Out) { // C846
|
|
|
314 messages.Say(
|
|
|
315 "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
|
|
|
316 actualLastSymbol->name(), dummyName);
|
|
|
317 }
|
|
|
318
|
|
|
319 // Definability
|
|
|
320 const char *reason{nullptr};
|
|
|
321 if (dummy.intent == common::Intent::Out) {
|
|
|
322 reason = "INTENT(OUT)";
|
|
|
323 } else if (dummy.intent == common::Intent::InOut) {
|
|
|
324 reason = "INTENT(IN OUT)";
|
|
|
325 } else if (dummyIsAsynchronous) {
|
|
|
326 reason = "ASYNCHRONOUS";
|
|
|
327 } else if (dummyIsVolatile) {
|
|
|
328 reason = "VOLATILE";
|
|
|
329 }
|
|
|
330 if (reason && scope) {
|
|
|
331 bool vectorSubscriptIsOk{isElemental || dummyIsValue}; // 15.5.2.4(21)
|
|
|
332 if (auto why{WhyNotModifiable(
|
|
|
333 messages.at(), actual, *scope, vectorSubscriptIsOk)}) {
|
|
|
334 if (auto *msg{messages.Say(
|
|
|
335 "Actual argument associated with %s %s must be definable"_err_en_US,
|
|
|
336 reason, dummyName)}) {
|
|
|
337 msg->Attach(*why);
|
|
|
338 }
|
|
|
339 }
|
|
|
340 }
|
|
|
341
|
|
|
342 // Cases when temporaries might be needed but must not be permitted.
|
|
|
343 bool dummyIsPointer{
|
|
|
344 dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
|
|
|
345 bool dummyIsContiguous{
|
|
|
346 dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
|
|
|
347 bool actualIsContiguous{IsSimplyContiguous(actual, context.intrinsics())};
|
|
|
348 bool dummyIsAssumedRank{dummy.type.attrs().test(
|
|
|
349 characteristics::TypeAndShape::Attr::AssumedRank)};
|
|
|
350 bool dummyIsAssumedShape{dummy.type.attrs().test(
|
|
|
351 characteristics::TypeAndShape::Attr::AssumedShape)};
|
|
|
352 if ((actualIsAsynchronous || actualIsVolatile) &&
|
|
|
353 (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
|
|
|
354 if (actualIsCoindexed) { // C1538
|
|
|
355 messages.Say(
|
|
|
356 "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
|
|
|
357 dummyName);
|
|
|
358 }
|
|
|
359 if (actualRank > 0 && !actualIsContiguous) {
|
|
|
360 if (dummyIsContiguous ||
|
|
|
361 !(dummyIsAssumedShape || dummyIsAssumedRank ||
|
|
|
362 (actualIsPointer && dummyIsPointer))) { // C1539 & C1540
|
|
|
363 messages.Say(
|
|
|
364 "ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous %s"_err_en_US,
|
|
|
365 dummyName);
|
|
|
366 }
|
|
|
367 }
|
|
|
368 }
|
|
|
369
|
|
|
370 // 15.5.2.6 -- dummy is ALLOCATABLE
|
|
|
371 bool dummyIsAllocatable{
|
|
|
372 dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
|
|
|
373 bool actualIsAllocatable{
|
|
|
374 actualLastSymbol && IsAllocatable(*actualLastSymbol)};
|
|
|
375 if (dummyIsAllocatable) {
|
|
|
376 if (!actualIsAllocatable) {
|
|
|
377 messages.Say(
|
|
|
378 "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US,
|
|
|
379 dummyName);
|
|
|
380 }
|
|
|
381 if (actualIsAllocatable && actualIsCoindexed &&
|
|
|
382 dummy.intent != common::Intent::In) {
|
|
|
383 messages.Say(
|
|
|
384 "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,
|
|
|
385 dummyName);
|
|
|
386 }
|
|
|
387 if (!actualIsCoindexed && actualLastSymbol &&
|
|
|
388 actualLastSymbol->Corank() != dummy.type.corank()) {
|
|
|
389 messages.Say(
|
|
|
390 "ALLOCATABLE %s has corank %d but actual argument has corank %d"_err_en_US,
|
|
|
391 dummyName, dummy.type.corank(), actualLastSymbol->Corank());
|
|
|
392 }
|
|
|
393 }
|
|
|
394
|
|
|
395 // 15.5.2.7 -- dummy is POINTER
|
|
|
396 if (dummyIsPointer) {
|
|
|
397 if (dummyIsContiguous && !actualIsContiguous) {
|
|
|
398 messages.Say(
|
|
|
399 "Actual argument associated with CONTIGUOUS POINTER %s must be simply contiguous"_err_en_US,
|
|
|
400 dummyName);
|
|
|
401 }
|
|
|
402 if (!actualIsPointer) {
|
|
|
403 if (dummy.intent == common::Intent::In) {
|
|
|
404 semantics::CheckPointerAssignment(
|
|
|
405 context, parser::CharBlock{}, dummyName, dummy, actual);
|
|
|
406 } else {
|
|
|
407 messages.Say(
|
|
|
408 "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
|
|
|
409 dummyName);
|
|
|
410 }
|
|
|
411 }
|
|
|
412 }
|
|
|
413
|
|
|
414 // 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE
|
|
|
415 if ((actualIsPointer && dummyIsPointer) ||
|
|
|
416 (actualIsAllocatable && dummyIsAllocatable)) {
|
|
|
417 bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()};
|
|
|
418 bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()};
|
|
|
419 if (actualIsUnlimited != dummyIsUnlimited) {
|
|
|
420 if (typesCompatible) {
|
|
|
421 messages.Say(
|
|
|
422 "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so"_err_en_US);
|
|
|
423 }
|
|
|
424 } else if (dummyIsPolymorphic != actualIsPolymorphic) {
|
|
|
425 if (dummy.intent == common::Intent::In && typesCompatible) {
|
|
|
426 // extension: allow with warning, rule is only relevant for definables
|
|
|
427 messages.Say(
|
|
|
428 "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_en_US);
|
|
|
429 } else {
|
|
|
430 messages.Say(
|
|
|
431 "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);
|
|
|
432 }
|
|
|
433 } else if (!actualIsUnlimited && typesCompatible) {
|
|
|
434 if (!actualType.type().IsTypeCompatibleWith(dummy.type.type())) {
|
|
|
435 if (dummy.intent == common::Intent::In) {
|
|
|
436 // extension: allow with warning, rule is only relevant for definables
|
|
|
437 messages.Say(
|
|
|
438 "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type"_en_US);
|
|
|
439 } else {
|
|
|
440 messages.Say(
|
|
|
441 "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type"_err_en_US);
|
|
|
442 }
|
|
|
443 }
|
|
|
444 if (const auto *derived{
|
|
|
445 evaluate::GetDerivedTypeSpec(actualType.type())}) {
|
|
|
446 if (!DefersSameTypeParameters(
|
|
|
447 *derived, *evaluate::GetDerivedTypeSpec(dummy.type.type()))) {
|
|
|
448 messages.Say(
|
|
|
449 "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
|
|
|
450 }
|
|
|
451 }
|
|
|
452 }
|
|
|
453 }
|
|
|
454
|
|
|
455 // 15.5.2.8 -- coarray dummy arguments
|
|
|
456 if (dummy.type.corank() > 0) {
|
|
|
457 if (actualType.corank() == 0) {
|
|
|
458 messages.Say(
|
|
|
459 "Actual argument associated with coarray %s must be a coarray"_err_en_US,
|
|
|
460 dummyName);
|
|
|
461 }
|
|
|
462 if (dummyIsVolatile) {
|
|
|
463 if (!actualIsVolatile) {
|
|
|
464 messages.Say(
|
|
|
465 "non-VOLATILE coarray may not be associated with VOLATILE coarray %s"_err_en_US,
|
|
|
466 dummyName);
|
|
|
467 }
|
|
|
468 } else {
|
|
|
469 if (actualIsVolatile) {
|
|
|
470 messages.Say(
|
|
|
471 "VOLATILE coarray may not be associated with non-VOLATILE coarray %s"_err_en_US,
|
|
|
472 dummyName);
|
|
|
473 }
|
|
|
474 }
|
|
|
475 if (actualRank == dummy.type.Rank() && !actualIsContiguous) {
|
|
|
476 if (dummyIsContiguous) {
|
|
|
477 messages.Say(
|
|
|
478 "Actual argument associated with a CONTIGUOUS coarray %s must be simply contiguous"_err_en_US,
|
|
|
479 dummyName);
|
|
|
480 } else if (!dummyIsAssumedShape && !dummyIsAssumedRank) {
|
|
|
481 messages.Say(
|
|
|
482 "Actual argument associated with coarray %s (not assumed shape or rank) must be simply contiguous"_err_en_US,
|
|
|
483 dummyName);
|
|
|
484 }
|
|
|
485 }
|
|
|
486 }
|
|
|
487 }
|
|
|
488
|
|
|
489 static void CheckProcedureArg(evaluate::ActualArgument &arg,
|
|
|
490 const characteristics::DummyProcedure &proc, const std::string &dummyName,
|
|
|
491 evaluate::FoldingContext &context) {
|
|
|
492 parser::ContextualMessages &messages{context.messages()};
|
|
|
493 const characteristics::Procedure &interface{proc.procedure.value()};
|
|
|
494 if (const auto *expr{arg.UnwrapExpr()}) {
|
|
|
495 bool dummyIsPointer{
|
|
|
496 proc.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
|
|
|
497 const auto *argProcDesignator{
|
|
|
498 std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
|
|
|
499 const auto *argProcSymbol{
|
|
|
500 argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
|
|
|
501 if (auto argChars{characteristics::DummyArgument::FromActual(
|
|
|
502 "actual argument", *expr, context)}) {
|
|
|
503 if (auto *argProc{
|
|
|
504 std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
|
|
|
505 characteristics::Procedure &argInterface{argProc->procedure.value()};
|
|
|
506 argInterface.attrs.reset(characteristics::Procedure::Attr::NullPointer);
|
|
|
507 if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
|
|
|
508 // It's ok to pass ELEMENTAL unrestricted intrinsic functions.
|
|
|
509 argInterface.attrs.reset(characteristics::Procedure::Attr::Elemental);
|
|
|
510 } else if (argInterface.attrs.test(
|
|
|
511 characteristics::Procedure::Attr::Elemental)) {
|
|
|
512 if (argProcSymbol) { // C1533
|
|
|
513 evaluate::SayWithDeclaration(messages, *argProcSymbol,
|
|
|
514 "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
|
|
|
515 argProcSymbol->name());
|
|
|
516 return; // avoid piling on with checks below
|
|
|
517 } else {
|
|
|
518 argInterface.attrs.reset(
|
|
|
519 characteristics::Procedure::Attr::NullPointer);
|
|
|
520 }
|
|
|
521 }
|
|
|
522 if (!interface.IsPure()) {
|
|
|
523 // 15.5.2.9(1): if dummy is not pure, actual need not be.
|
|
|
524 argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
|
|
|
525 }
|
|
|
526 if (interface.HasExplicitInterface()) {
|
|
|
527 if (interface != argInterface) {
|
|
|
528 messages.Say(
|
|
|
529 "Actual argument procedure has interface incompatible with %s"_err_en_US,
|
|
|
530 dummyName);
|
|
|
531 }
|
|
|
532 } else { // 15.5.2.9(2,3)
|
|
|
533 if (interface.IsSubroutine() && argInterface.IsFunction()) {
|
|
|
534 messages.Say(
|
|
|
535 "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
|
|
|
536 dummyName);
|
|
|
537 } else if (interface.IsFunction()) {
|
|
|
538 if (argInterface.IsFunction()) {
|
|
|
539 if (interface.functionResult != argInterface.functionResult) {
|
|
|
540 messages.Say(
|
|
|
541 "Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
|
|
|
542 dummyName);
|
|
|
543 }
|
|
|
544 } else if (argInterface.IsSubroutine()) {
|
|
|
545 messages.Say(
|
|
|
546 "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
|
|
|
547 dummyName);
|
|
|
548 }
|
|
|
549 }
|
|
|
550 }
|
|
|
551 } else {
|
|
|
552 messages.Say(
|
|
|
553 "Actual argument associated with procedure %s is not a procedure"_err_en_US,
|
|
|
554 dummyName);
|
|
|
555 }
|
|
|
556 } else if (!(dummyIsPointer && IsNullPointer(*expr))) {
|
|
|
557 messages.Say(
|
|
|
558 "Actual argument associated with procedure %s is not a procedure"_err_en_US,
|
|
|
559 dummyName);
|
|
|
560 }
|
|
|
561 if (interface.HasExplicitInterface()) {
|
|
|
562 if (dummyIsPointer) {
|
|
|
563 // 15.5.2.9(5) -- dummy procedure POINTER
|
|
|
564 // Interface compatibility has already been checked above by comparison.
|
|
|
565 if (proc.intent != common::Intent::In && !IsVariable(*expr)) {
|
|
|
566 messages.Say(
|
|
|
567 "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
|
|
|
568 dummyName);
|
|
|
569 }
|
|
|
570 } else { // 15.5.2.9(4) -- dummy procedure is not POINTER
|
|
|
571 if (!argProcDesignator) {
|
|
|
572 messages.Say(
|
|
|
573 "Actual argument associated with non-POINTER procedure %s must be a procedure (and not a procedure pointer)"_err_en_US,
|
|
|
574 dummyName);
|
|
|
575 }
|
|
|
576 }
|
|
|
577 }
|
|
|
578 } else {
|
|
|
579 messages.Say(
|
|
|
580 "Assumed-type argument may not be forwarded as procedure %s"_err_en_US,
|
|
|
581 dummyName);
|
|
|
582 }
|
|
|
583 }
|
|
|
584
|
|
|
585 static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
|
|
|
586 const characteristics::DummyArgument &dummy,
|
|
|
587 const characteristics::Procedure &proc, evaluate::FoldingContext &context,
|
|
|
588 const Scope *scope) {
|
|
|
589 auto &messages{context.messages()};
|
|
|
590 std::string dummyName{"dummy argument"};
|
|
|
591 if (!dummy.name.empty()) {
|
|
|
592 dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
|
|
|
593 }
|
|
|
594 std::visit(
|
|
|
595 common::visitors{
|
|
|
596 [&](const characteristics::DummyDataObject &object) {
|
|
|
597 if (auto *expr{arg.UnwrapExpr()}) {
|
|
|
598 if (auto type{characteristics::TypeAndShape::Characterize(
|
|
|
599 *expr, context)}) {
|
|
|
600 arg.set_dummyIntent(object.intent);
|
|
|
601 bool isElemental{object.type.Rank() == 0 && proc.IsElemental()};
|
|
|
602 CheckExplicitDataArg(object, dummyName, *expr, *type,
|
|
|
603 isElemental, IsArrayElement(*expr), context, scope);
|
|
|
604 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
|
|
|
605 std::holds_alternative<evaluate::BOZLiteralConstant>(
|
|
|
606 expr->u)) {
|
|
|
607 // ok
|
|
|
608 } else {
|
|
|
609 messages.Say(
|
|
|
610 "Actual argument is not a variable or typed expression"_err_en_US);
|
|
|
611 }
|
|
|
612 } else {
|
|
|
613 const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};
|
|
|
614 if (!object.type.type().IsAssumedType()) {
|
|
|
615 messages.Say(
|
|
|
616 "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,
|
|
|
617 assumed.name(), dummyName);
|
|
|
618 } else if (const auto *details{
|
|
|
619 assumed.detailsIf<ObjectEntityDetails>()}) {
|
|
|
620 if (!(details->IsAssumedShape() || details->IsAssumedRank())) {
|
|
|
621 messages.Say( // C711
|
|
|
622 "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed-type %s"_err_en_US,
|
|
|
623 assumed.name(), dummyName);
|
|
|
624 }
|
|
|
625 }
|
|
|
626 }
|
|
|
627 },
|
|
|
628 [&](const characteristics::DummyProcedure &proc) {
|
|
|
629 CheckProcedureArg(arg, proc, dummyName, context);
|
|
|
630 },
|
|
|
631 [&](const characteristics::AlternateReturn &) {
|
|
|
632 // TODO check alternate return
|
|
|
633 },
|
|
|
634 },
|
|
|
635 dummy.u);
|
|
|
636 }
|
|
|
637
|
|
|
638 static void RearrangeArguments(const characteristics::Procedure &proc,
|
|
|
639 evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) {
|
|
|
640 CHECK(proc.HasExplicitInterface());
|
|
|
641 if (actuals.size() < proc.dummyArguments.size()) {
|
|
|
642 actuals.resize(proc.dummyArguments.size());
|
|
|
643 } else if (actuals.size() > proc.dummyArguments.size()) {
|
|
|
644 messages.Say(
|
|
|
645 "Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US,
|
|
|
646 actuals.size(), proc.dummyArguments.size());
|
|
|
647 }
|
|
|
648 std::map<std::string, evaluate::ActualArgument> kwArgs;
|
|
|
649 for (auto &x : actuals) {
|
|
|
650 if (x && x->keyword()) {
|
|
|
651 auto emplaced{
|
|
|
652 kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};
|
|
|
653 if (!emplaced.second) {
|
|
|
654 messages.Say(*x->keyword(),
|
|
|
655 "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
|
|
|
656 *x->keyword());
|
|
|
657 }
|
|
|
658 x.reset();
|
|
|
659 }
|
|
|
660 }
|
|
|
661 if (!kwArgs.empty()) {
|
|
|
662 int index{0};
|
|
|
663 for (const auto &dummy : proc.dummyArguments) {
|
|
|
664 if (!dummy.name.empty()) {
|
|
|
665 auto iter{kwArgs.find(dummy.name)};
|
|
|
666 if (iter != kwArgs.end()) {
|
|
|
667 evaluate::ActualArgument &x{iter->second};
|
|
|
668 if (actuals[index]) {
|
|
|
669 messages.Say(*x.keyword(),
|
|
|
670 "Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,
|
|
|
671 *x.keyword(), index + 1);
|
|
|
672 } else {
|
|
|
673 actuals[index] = std::move(x);
|
|
|
674 }
|
|
|
675 kwArgs.erase(iter);
|
|
|
676 }
|
|
|
677 }
|
|
|
678 ++index;
|
|
|
679 }
|
|
|
680 for (auto &bad : kwArgs) {
|
|
|
681 evaluate::ActualArgument &x{bad.second};
|
|
|
682 messages.Say(*x.keyword(),
|
|
|
683 "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
|
|
|
684 *x.keyword());
|
|
|
685 }
|
|
|
686 }
|
|
|
687 }
|
|
|
688
|
|
|
689 static parser::Messages CheckExplicitInterface(
|
|
|
690 const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
|
|
|
691 const evaluate::FoldingContext &context, const Scope *scope) {
|
|
|
692 parser::Messages buffer;
|
|
|
693 parser::ContextualMessages messages{context.messages().at(), &buffer};
|
|
|
694 RearrangeArguments(proc, actuals, messages);
|
|
|
695 if (buffer.empty()) {
|
|
|
696 int index{0};
|
|
|
697 evaluate::FoldingContext localContext{context, messages};
|
|
|
698 for (auto &actual : actuals) {
|
|
|
699 const auto &dummy{proc.dummyArguments.at(index++)};
|
|
|
700 if (actual) {
|
|
|
701 CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope);
|
|
|
702 } else if (!dummy.IsOptional()) {
|
|
|
703 if (dummy.name.empty()) {
|
|
|
704 messages.Say(
|
|
|
705 "Dummy argument #%d is not OPTIONAL and is not associated with "
|
|
|
706 "an actual argument in this procedure reference"_err_en_US,
|
|
|
707 index);
|
|
|
708 } else {
|
|
|
709 messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "
|
|
|
710 "associated with an actual argument in this procedure "
|
|
|
711 "reference"_err_en_US,
|
|
|
712 dummy.name, index);
|
|
|
713 }
|
|
|
714 }
|
|
|
715 }
|
|
|
716 }
|
|
|
717 return buffer;
|
|
|
718 }
|
|
|
719
|
|
|
720 parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
|
|
|
721 evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
|
|
|
722 const Scope &scope) {
|
|
|
723 return CheckExplicitInterface(proc, actuals, context, &scope);
|
|
|
724 }
|
|
|
725
|
|
|
726 bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
|
|
|
727 evaluate::ActualArguments &actuals,
|
|
|
728 const evaluate::FoldingContext &context) {
|
|
|
729 return CheckExplicitInterface(proc, actuals, context, nullptr).empty();
|
|
|
730 }
|
|
|
731
|
|
|
732 void CheckArguments(const characteristics::Procedure &proc,
|
|
|
733 evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
|
|
|
734 const Scope &scope, bool treatingExternalAsImplicit) {
|
|
|
735 bool explicitInterface{proc.HasExplicitInterface()};
|
|
|
736 if (explicitInterface) {
|
|
|
737 auto buffer{CheckExplicitInterface(proc, actuals, context, scope)};
|
|
|
738 if (treatingExternalAsImplicit && !buffer.empty()) {
|
|
|
739 if (auto *msg{context.messages().Say(
|
|
|
740 "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
|
|
|
741 buffer.AttachTo(*msg);
|
|
|
742 }
|
|
|
743 }
|
|
|
744 if (auto *msgs{context.messages().messages()}) {
|
|
|
745 msgs->Merge(std::move(buffer));
|
|
|
746 }
|
|
|
747 }
|
|
|
748 if (!explicitInterface || treatingExternalAsImplicit) {
|
|
|
749 for (auto &actual : actuals) {
|
|
|
750 if (actual) {
|
|
|
751 CheckImplicitInterfaceArg(*actual, context.messages());
|
|
|
752 }
|
|
|
753 }
|
|
|
754 }
|
|
|
755 }
|
|
|
756 } // namespace Fortran::semantics
|
