?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
[flang][cuda] Adapt ExternalNameConversion to work in gpu module (#117039)
[llvm-project.git] / flang / lib / Semantics / check-call.cpp
blob597c280a6df8bc2c130ab48d62d2ac2e079cb064
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 "definable.h"
11 #include "pointer-assignment.h"
12 #include "flang/Evaluate/characteristics.h"
13 #include "flang/Evaluate/check-expression.h"
14 #include "flang/Evaluate/fold-designator.h"
15 #include "flang/Evaluate/shape.h"
16 #include "flang/Evaluate/tools.h"
17 #include "flang/Parser/characters.h"
18 #include "flang/Parser/message.h"
19 #include "flang/Semantics/scope.h"
20 #include "flang/Semantics/tools.h"
21 #include <map>
22 #include <string>
23
24 using namespace Fortran::parser::literals;
25 namespace characteristics = Fortran::evaluate::characteristics;
26
27 namespace Fortran::semantics {
28
29 static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
30 parser::ContextualMessages &messages, SemanticsContext &context) {
31 auto restorer{
32 messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
33 if (auto kw{arg.keyword()}) {
34 messages.Say(*kw,
35 "Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US,
36 *kw);
37 }
38 auto type{arg.GetType()};
39 if (type) {
40 if (type->IsAssumedType()) {
41 messages.Say(
42 "Assumed type actual argument requires an explicit interface"_err_en_US);
43 } else if (type->IsUnlimitedPolymorphic()) {
44 messages.Say(
45 "Unlimited polymorphic actual argument requires an explicit interface"_err_en_US);
46 } else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
47 if (!derived->parameters().empty()) {
48 messages.Say(
49 "Parameterized derived type actual argument requires an explicit interface"_err_en_US);
50 }
51 }
52 }
53 if (arg.isPercentVal() &&
54 (!type || !type->IsLengthlessIntrinsicType() || arg.Rank() != 0)) {
55 messages.Say(
56 "%VAL argument must be a scalar numeric or logical expression"_err_en_US);
57 }
58 if (const auto *expr{arg.UnwrapExpr()}) {
59 if (const Symbol * base{GetFirstSymbol(*expr)};
60 base && IsFunctionResult(*base)) {
61 context.NoteDefinedSymbol(*base);
62 }
63 if (IsBOZLiteral(*expr)) {
64 messages.Say("BOZ argument requires an explicit interface"_err_en_US);
65 } else if (evaluate::IsNullPointer(*expr)) {
66 messages.Say(
67 "Null pointer argument requires an explicit interface"_err_en_US);
68 } else if (auto named{evaluate::ExtractNamedEntity(*expr)}) {
69 const Symbol &symbol{named->GetLastSymbol()};
70 if (symbol.Corank() > 0) {
71 messages.Say(
72 "Coarray argument requires an explicit interface"_err_en_US);
73 }
74 if (evaluate::IsAssumedRank(symbol)) {
75 messages.Say(
76 "Assumed rank argument requires an explicit interface"_err_en_US);
77 }
78 if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
79 messages.Say(
80 "ASYNCHRONOUS argument requires an explicit interface"_err_en_US);
81 }
82 if (symbol.attrs().test(Attr::VOLATILE)) {
83 messages.Say(
84 "VOLATILE argument requires an explicit interface"_err_en_US);
85 }
86 } else if (auto argChars{characteristics::DummyArgument::FromActual(
87 "actual argument", *expr, context.foldingContext(),
88 /*forImplicitInterface=*/true)}) {
89 const auto *argProcDesignator{
90 std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
91 if (const auto *argProcSymbol{
92 argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}) {
93 if (!argChars->IsTypelessIntrinsicDummy() && argProcDesignator &&
94 argProcDesignator->IsElemental()) { // C1533
95 evaluate::SayWithDeclaration(messages, *argProcSymbol,
96 "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
97 argProcSymbol->name());
98 } else if (const auto *subp{argProcSymbol->GetUltimate()
99 .detailsIf<SubprogramDetails>()}) {
100 if (subp->stmtFunction()) {
101 evaluate::SayWithDeclaration(messages, *argProcSymbol,
102 "Statement function '%s' may not be passed as an actual argument"_err_en_US,
103 argProcSymbol->name());
104 }
105 }
106 }
107 }
108 }
109 }
110
111 // F'2023 15.5.2.12p1: "Sequence association only applies when the dummy
112 // argument is an explicit-shape or assumed-size array."
113 static bool CanAssociateWithStorageSequence(
114 const characteristics::DummyDataObject &dummy) {
115 return !dummy.type.attrs().test(
116 characteristics::TypeAndShape::Attr::AssumedRank) &&
117 !dummy.type.attrs().test(
118 characteristics::TypeAndShape::Attr::AssumedShape) &&
119 !dummy.type.attrs().test(characteristics::TypeAndShape::Attr::Coarray) &&
120 !dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&
121 !dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer);
122 }
123
124 // When a CHARACTER actual argument is known to be short,
125 // we extend it on the right with spaces and a warning if
126 // possible. When it is long, and not required to be equal,
127 // the usage conforms to the standard and no warning is needed.
128 static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
129 const characteristics::DummyDataObject &dummy,
130 characteristics::TypeAndShape &actualType, SemanticsContext &context,
131 parser::ContextualMessages &messages, bool extentErrors,
132 const std::string &dummyName) {
133 if (dummy.type.type().category() == TypeCategory::Character &&
134 actualType.type().category() == TypeCategory::Character &&
135 dummy.type.type().kind() == actualType.type().kind() &&
136 !dummy.attrs.test(
137 characteristics::DummyDataObject::Attr::DeducedFromActual)) {
138 bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
139 if (actualIsAssumedRank &&
140 !dummy.type.attrs().test(
141 characteristics::TypeAndShape::Attr::AssumedRank)) {
142 if (!context.languageFeatures().IsEnabled(
143 common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {
144 messages.Say(
145 "Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
146 } else {
147 context.Warn(common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
148 messages.at(),
149 "Assumed-rank character array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
150 }
151 }
152 if (dummy.type.LEN() && actualType.LEN()) {
153 evaluate::FoldingContext &foldingContext{context.foldingContext()};
154 auto dummyLength{
155 ToInt64(Fold(foldingContext, common::Clone(*dummy.type.LEN())))};
156 auto actualLength{
157 ToInt64(Fold(foldingContext, common::Clone(*actualType.LEN())))};
158 if (dummyLength && actualLength) {
159 bool canAssociate{CanAssociateWithStorageSequence(dummy)};
160 if (dummy.type.Rank() > 0 && canAssociate) {
161 // Character storage sequence association (F'2023 15.5.2.12p4)
162 if (auto dummySize{evaluate::ToInt64(evaluate::Fold(
163 foldingContext, evaluate::GetSize(dummy.type.shape())))}) {
164 auto dummyChars{*dummySize * *dummyLength};
165 if (actualType.Rank() == 0 && !actualIsAssumedRank) {
166 evaluate::DesignatorFolder folder{
167 context.foldingContext(), /*getLastComponent=*/true};
168 if (auto actualOffset{folder.FoldDesignator(actual)}) {
169 std::int64_t actualChars{*actualLength};
170 if (static_cast<std::size_t>(actualOffset->offset()) >=
171 actualOffset->symbol().size() ||
172 !evaluate::IsContiguous(
173 actualOffset->symbol(), foldingContext)) {
174 // If substring, take rest of substring
175 if (*actualLength > 0) {
176 actualChars -=
177 (actualOffset->offset() / actualType.type().kind()) %
178 *actualLength;
179 }
180 } else {
181 actualChars = (static_cast<std::int64_t>(
182 actualOffset->symbol().size()) -
183 actualOffset->offset()) /
184 actualType.type().kind();
185 }
186 if (actualChars < dummyChars) {
187 if (extentErrors) {
188 messages.Say(
189 "Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_err_en_US,
190 static_cast<std::intmax_t>(actualChars), dummyName,
191 static_cast<std::intmax_t>(dummyChars));
192 } else if (context.ShouldWarn(
193 common::UsageWarning::ShortCharacterActual)) {
194 messages.Say(common::UsageWarning::ShortCharacterActual,
195 "Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_warn_en_US,
196 static_cast<std::intmax_t>(actualChars), dummyName,
197 static_cast<std::intmax_t>(dummyChars));
198 }
199 }
200 }
201 } else { // actual.type.Rank() > 0
202 if (auto actualSize{evaluate::ToInt64(evaluate::Fold(
203 foldingContext, evaluate::GetSize(actualType.shape())))};
204 actualSize &&
205 *actualSize * *actualLength < *dummySize * *dummyLength) {
206 if (extentErrors) {
207 messages.Say(
208 "Actual argument array has fewer characters (%jd) than %s array (%jd)"_err_en_US,
209 static_cast<std::intmax_t>(*actualSize * *actualLength),
210 dummyName,
211 static_cast<std::intmax_t>(*dummySize * *dummyLength));
212 } else if (context.ShouldWarn(
213 common::UsageWarning::ShortCharacterActual)) {
214 messages.Say(common::UsageWarning::ShortCharacterActual,
215 "Actual argument array has fewer characters (%jd) than %s array (%jd)"_warn_en_US,
216 static_cast<std::intmax_t>(*actualSize * *actualLength),
217 dummyName,
218 static_cast<std::intmax_t>(*dummySize * *dummyLength));
219 }
220 }
221 }
222 }
223 } else if (*actualLength != *dummyLength) {
224 // Not using storage sequence association, and the lengths don't
225 // match.
226 if (!canAssociate) {
227 // F'2023 15.5.2.5 paragraph 4
228 messages.Say(
229 "Actual argument variable length '%jd' does not match the expected length '%jd'"_err_en_US,
230 *actualLength, *dummyLength);
231 } else if (*actualLength < *dummyLength) {
232 CHECK(dummy.type.Rank() == 0);
233 bool isVariable{evaluate::IsVariable(actual)};
234 if (context.ShouldWarn(
235 common::UsageWarning::ShortCharacterActual)) {
236 if (isVariable) {
237 messages.Say(common::UsageWarning::ShortCharacterActual,
238 "Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US,
239 *actualLength, *dummyLength);
240 } else {
241 messages.Say(common::UsageWarning::ShortCharacterActual,
242 "Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US,
243 *actualLength, *dummyLength);
244 }
245 }
246 if (!isVariable) {
247 auto converted{
248 ConvertToType(dummy.type.type(), std::move(actual))};
249 CHECK(converted);
250 actual = std::move(*converted);
251 actualType.set_LEN(SubscriptIntExpr{*dummyLength});
252 }
253 }
254 }
255 }
256 }
257 }
258 }
259
260 // Automatic conversion of different-kind INTEGER scalar actual
261 // argument expressions (not variables) to INTEGER scalar dummies.
262 // We return nonstandard INTEGER(8) results from intrinsic functions
263 // like SIZE() by default in order to facilitate the use of large
264 // arrays. Emit a warning when downconverting.
265 static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
266 const characteristics::TypeAndShape &dummyType,
267 characteristics::TypeAndShape &actualType,
268 parser::ContextualMessages &messages, SemanticsContext &semanticsContext) {
269 if (dummyType.type().category() == TypeCategory::Integer &&
270 actualType.type().category() == TypeCategory::Integer &&
271 dummyType.type().kind() != actualType.type().kind() &&
272 dummyType.Rank() == 0 && actualType.Rank() == 0 &&
273 !evaluate::IsVariable(actual)) {
274 auto converted{
275 evaluate::ConvertToType(dummyType.type(), std::move(actual))};
276 CHECK(converted);
277 actual = std::move(*converted);
278 if (dummyType.type().kind() < actualType.type().kind()) {
279 if (!semanticsContext.IsEnabled(
280 common::LanguageFeature::ActualIntegerConvertedToSmallerKind)) {
281 messages.Say(
282 "Actual argument scalar expression of type INTEGER(%d) cannot be implicitly converted to smaller dummy argument type INTEGER(%d)"_err_en_US,
283 actualType.type().kind(), dummyType.type().kind());
284 } else if (semanticsContext.ShouldWarn(common::LanguageFeature::
285 ActualIntegerConvertedToSmallerKind)) {
286 messages.Say(
287 common::LanguageFeature::ActualIntegerConvertedToSmallerKind,
288 "Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_port_en_US,
289 actualType.type().kind(), dummyType.type().kind());
290 }
291 }
292 actualType = dummyType;
293 }
294 }
295
296 // Automatic conversion of different-kind LOGICAL scalar actual argument
297 // expressions (not variables) to LOGICAL scalar dummies when the dummy is of
298 // default logical kind. This allows expressions in dummy arguments to work when
299 // the default logical kind is not the one used in LogicalResult. This will
300 // always be safe even when downconverting so no warning is needed.
301 static void ConvertLogicalActual(evaluate::Expr<evaluate::SomeType> &actual,
302 const characteristics::TypeAndShape &dummyType,
303 characteristics::TypeAndShape &actualType) {
304 if (dummyType.type().category() == TypeCategory::Logical &&
305 actualType.type().category() == TypeCategory::Logical &&
306 dummyType.type().kind() != actualType.type().kind() &&
307 !evaluate::IsVariable(actual)) {
308 auto converted{
309 evaluate::ConvertToType(dummyType.type(), std::move(actual))};
310 CHECK(converted);
311 actual = std::move(*converted);
312 actualType = dummyType;
313 }
314 }
315
316 static bool DefersSameTypeParameters(
317 const DerivedTypeSpec *actual, const DerivedTypeSpec *dummy) {
318 if (actual && dummy) {
319 for (const auto &pair : actual->parameters()) {
320 const ParamValue &actualValue{pair.second};
321 const ParamValue *dummyValue{dummy->FindParameter(pair.first)};
322 if (!dummyValue ||
323 (actualValue.isDeferred() != dummyValue->isDeferred())) {
324 return false;
325 }
326 }
327 }
328 return true;
329 }
330
331 static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
332 const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
333 characteristics::TypeAndShape &actualType, bool isElemental,
334 SemanticsContext &context, evaluate::FoldingContext &foldingContext,
335 const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
336 bool allowActualArgumentConversions, bool extentErrors,
337 const characteristics::Procedure &procedure,
338 const evaluate::ActualArgument &arg) {
339
340 // Basic type & rank checking
341 parser::ContextualMessages &messages{foldingContext.messages()};
342 CheckCharacterActual(
343 actual, dummy, actualType, context, messages, extentErrors, dummyName);
344 bool dummyIsAllocatable{
345 dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
346 bool dummyIsPointer{
347 dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
348 bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer};
349 allowActualArgumentConversions &= !dummyIsAllocatableOrPointer;
350 bool typesCompatibleWithIgnoreTKR{
351 (dummy.ignoreTKR.test(common::IgnoreTKR::Type) &&
352 (dummy.type.type().category() == TypeCategory::Derived ||
353 actualType.type().category() == TypeCategory::Derived ||
354 dummy.type.type().category() != actualType.type().category())) ||
355 (dummy.ignoreTKR.test(common::IgnoreTKR::Kind) &&
356 dummy.type.type().category() == actualType.type().category())};
357 allowActualArgumentConversions &= !typesCompatibleWithIgnoreTKR;
358 if (allowActualArgumentConversions) {
359 ConvertIntegerActual(actual, dummy.type, actualType, messages, context);
360 ConvertLogicalActual(actual, dummy.type, actualType);
361 }
362 bool typesCompatible{typesCompatibleWithIgnoreTKR ||
363 dummy.type.type().IsTkCompatibleWith(actualType.type())};
364 int dummyRank{dummy.type.Rank()};
365 if (typesCompatible) {
366 if (const auto *constantChar{
367 evaluate::UnwrapConstantValue<evaluate::Ascii>(actual)};
368 constantChar && constantChar->wasHollerith() &&
369 dummy.type.type().IsUnlimitedPolymorphic() &&
370 context.ShouldWarn(common::LanguageFeature::HollerithPolymorphic)) {
371 messages.Say(common::LanguageFeature::HollerithPolymorphic,
372 "passing Hollerith to unlimited polymorphic as if it were CHARACTER"_port_en_US);
373 }
374 } else if (dummyRank == 0 && allowActualArgumentConversions) {
375 // Extension: pass Hollerith literal to scalar as if it had been BOZ
376 if (auto converted{evaluate::HollerithToBOZ(
377 foldingContext, actual, dummy.type.type())}) {
378 if (context.ShouldWarn(
379 common::LanguageFeature::HollerithOrCharacterAsBOZ)) {
380 messages.Say(common::LanguageFeature::HollerithOrCharacterAsBOZ,
381 "passing Hollerith or character literal as if it were BOZ"_port_en_US);
382 }
383 actual = *converted;
384 actualType.type() = dummy.type.type();
385 typesCompatible = true;
386 }
387 }
388 bool dummyIsAssumedRank{dummy.type.attrs().test(
389 characteristics::TypeAndShape::Attr::AssumedRank)};
390 bool actualIsAssumedSize{actualType.attrs().test(
391 characteristics::TypeAndShape::Attr::AssumedSize)};
392 bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
393 bool actualIsPointer{evaluate::IsObjectPointer(actual)};
394 bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
395 bool actualMayBeAssumedSize{actualIsAssumedSize ||
396 (actualIsAssumedRank && !actualIsPointer && !actualIsAllocatable)};
397 bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
398 const auto *actualDerived{evaluate::GetDerivedTypeSpec(actualType.type())};
399 if (typesCompatible) {
400 if (isElemental) {
401 } else if (dummyIsAssumedRank) {
402 if (actualMayBeAssumedSize && dummy.intent == common::Intent::Out) {
403 // An INTENT(OUT) dummy might be a no-op at run time
404 bool dummyHasSignificantIntentOut{actualIsPolymorphic ||
405 (actualDerived &&
406 (actualDerived->HasDefaultInitialization(
407 /*ignoreAllocatable=*/false, /*ignorePointer=*/true) ||
408 actualDerived->HasDestruction()))};
409 const char *actualDesc{
410 actualIsAssumedSize ? "Assumed-size" : "Assumed-rank"};
411 if (dummyHasSignificantIntentOut) {
412 messages.Say(
413 "%s actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization"_err_en_US,
414 actualDesc);
415 } else {
416 context.Warn(common::UsageWarning::Portability, messages.at(),
417 "%s actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument"_port_en_US,
418 actualDesc);
419 }
420 }
421 } else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
422 } else if (dummyRank > 0 && !dummyIsAllocatableOrPointer &&
423 !dummy.type.attrs().test(
424 characteristics::TypeAndShape::Attr::AssumedShape) &&
425 !dummy.type.attrs().test(
426 characteristics::TypeAndShape::Attr::DeferredShape) &&
427 (actualType.Rank() > 0 || IsArrayElement(actual))) {
428 // Sequence association (15.5.2.11) applies -- rank need not match
429 // if the actual argument is an array or array element designator,
430 // and the dummy is an array, but not assumed-shape or an INTENT(IN)
431 // pointer that's standing in for an assumed-shape dummy.
432 } else if (dummy.type.shape() && actualType.shape()) {
433 // Let CheckConformance accept actual scalars; storage association
434 // cases are checked here below.
435 CheckConformance(messages, *dummy.type.shape(), *actualType.shape(),
436 dummyIsAllocatableOrPointer
437 ? evaluate::CheckConformanceFlags::None
438 : evaluate::CheckConformanceFlags::RightScalarExpandable,
439 "dummy argument", "actual argument");
440 }
441 } else {
442 const auto &len{actualType.LEN()};
443 messages.Say(
444 "Actual argument type '%s' is not compatible with dummy argument type '%s'"_err_en_US,
445 actualType.type().AsFortran(len ? len->AsFortran() : ""),
446 dummy.type.type().AsFortran());
447 }
448
449 bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()};
450 bool dummyIsAssumedSize{dummy.type.attrs().test(
451 characteristics::TypeAndShape::Attr::AssumedSize)};
452 bool dummyIsAsynchronous{
453 dummy.attrs.test(characteristics::DummyDataObject::Attr::Asynchronous)};
454 bool dummyIsVolatile{
455 dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)};
456 bool dummyIsValue{
457 dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};
458 bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
459 if (actualIsPolymorphic && dummyIsPolymorphic &&
460 actualIsCoindexed) { // 15.5.2.4(2)
461 messages.Say(
462 "Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US,
463 dummyName);
464 }
465 if (actualIsPolymorphic && !dummyIsPolymorphic &&
466 actualIsAssumedSize) { // 15.5.2.4(2)
467 messages.Say(
468 "Assumed-size polymorphic array may not be associated with a monomorphic %s"_err_en_US,
469 dummyName);
470 }
471
472 // Derived type actual argument checks
473 const Symbol *actualFirstSymbol{evaluate::GetFirstSymbol(actual)};
474 bool actualIsAsynchronous{
475 actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)};
476 bool actualIsVolatile{
477 actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};
478 if (actualDerived && !actualDerived->IsVectorType()) {
479 if (dummy.type.type().IsAssumedType()) {
480 if (!actualDerived->parameters().empty()) { // 15.5.2.4(2)
481 messages.Say(
482 "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
483 dummyName);
484 }
485 if (const Symbol *
486 tbp{FindImmediateComponent(*actualDerived, [](const Symbol &symbol) {
487 return symbol.has<ProcBindingDetails>();
488 })}) { // 15.5.2.4(2)
489 evaluate::SayWithDeclaration(messages, *tbp,
490 "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
491 dummyName, tbp->name());
492 }
493 auto finals{FinalsForDerivedTypeInstantiation(*actualDerived)};
494 if (!finals.empty()) { // 15.5.2.4(2)
495 SourceName name{finals.front()->name()};
496 if (auto *msg{messages.Say(
497 "Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US,
498 dummyName, actualDerived->typeSymbol().name(), name)}) {
499 msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US,
500 name, actualDerived->typeSymbol().name());
501 }
502 }
503 }
504 if (actualIsCoindexed) {
505 if (dummy.intent != common::Intent::In && !dummyIsValue) {
506 if (auto bad{FindAllocatableUltimateComponent(
507 *actualDerived)}) { // 15.5.2.4(6)
508 evaluate::SayWithDeclaration(messages, *bad,
509 "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
510 bad.BuildResultDesignatorName(), dummyName);
511 }
512 }
513 if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537
514 const Symbol &coarray{coarrayRef->GetLastSymbol()};
515 if (const DeclTypeSpec * type{coarray.GetType()}) {
516 if (const DerivedTypeSpec * derived{type->AsDerived()}) {
517 if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
518 evaluate::SayWithDeclaration(messages, coarray,
519 "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
520 coarray.name(), bad.BuildResultDesignatorName(), dummyName);
521 }
522 }
523 }
524 }
525 }
526 if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
527 if (auto bad{semantics::FindCoarrayUltimateComponent(*actualDerived)}) {
528 evaluate::SayWithDeclaration(messages, *bad,
529 "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
530 dummyName, bad.BuildResultDesignatorName());
531 }
532 }
533 }
534
535 // Rank and shape checks
536 const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)};
537 if (actualLastSymbol) {
538 actualLastSymbol = &ResolveAssociations(*actualLastSymbol);
539 }
540 const ObjectEntityDetails *actualLastObject{actualLastSymbol
541 ? actualLastSymbol->detailsIf<ObjectEntityDetails>()
542 : nullptr};
543 int actualRank{actualType.Rank()};
544 if (dummy.type.attrs().test(
545 characteristics::TypeAndShape::Attr::AssumedShape)) {
546 // 15.5.2.4(16)
547 if (actualIsAssumedRank) {
548 messages.Say(
549 "Assumed-rank actual argument may not be associated with assumed-shape %s"_err_en_US,
550 dummyName);
551 } else if (actualRank == 0) {
552 messages.Say(
553 "Scalar actual argument may not be associated with assumed-shape %s"_err_en_US,
554 dummyName);
555 } else if (actualIsAssumedSize && actualLastSymbol) {
556 evaluate::SayWithDeclaration(messages, *actualLastSymbol,
557 "Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
558 dummyName);
559 }
560 } else if (dummyRank > 0) {
561 bool basicError{false};
562 if (actualRank == 0 && !actualIsAssumedRank &&
563 !dummyIsAllocatableOrPointer) {
564 // Actual is scalar, dummy is an array. F'2023 15.5.2.5p14
565 if (actualIsCoindexed) {
566 basicError = true;
567 messages.Say(
568 "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
569 dummyName);
570 }
571 bool actualIsArrayElement{IsArrayElement(actual)};
572 bool actualIsCKindCharacter{
573 actualType.type().category() == TypeCategory::Character &&
574 actualType.type().kind() == 1};
575 if (!actualIsCKindCharacter) {
576 if (!actualIsArrayElement &&
577 !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&
578 !dummyIsAssumedRank &&
579 !dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
580 basicError = true;
581 messages.Say(
582 "Whole scalar actual argument may not be associated with a %s array"_err_en_US,
583 dummyName);
584 }
585 if (actualIsPolymorphic) {
586 basicError = true;
587 messages.Say(
588 "Polymorphic scalar may not be associated with a %s array"_err_en_US,
589 dummyName);
590 }
591 if (actualIsArrayElement && actualLastSymbol &&
592 !evaluate::IsContiguous(*actualLastSymbol, foldingContext) &&
593 !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
594 if (IsPointer(*actualLastSymbol)) {
595 basicError = true;
596 messages.Say(
597 "Element of pointer array may not be associated with a %s array"_err_en_US,
598 dummyName);
599 } else if (IsAssumedShape(*actualLastSymbol) &&
600 !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
601 basicError = true;
602 messages.Say(
603 "Element of assumed-shape array may not be associated with a %s array"_err_en_US,
604 dummyName);
605 }
606 }
607 }
608 }
609 // Storage sequence association (F'2023 15.5.2.12p3) checks.
610 // Character storage sequence association is checked in
611 // CheckCharacterActual().
612 if (!basicError &&
613 actualType.type().category() != TypeCategory::Character &&
614 CanAssociateWithStorageSequence(dummy) &&
615 !dummy.attrs.test(
616 characteristics::DummyDataObject::Attr::DeducedFromActual)) {
617 if (auto dummySize{evaluate::ToInt64(evaluate::Fold(
618 foldingContext, evaluate::GetSize(dummy.type.shape())))}) {
619 if (actualIsAssumedRank) {
620 if (!context.languageFeatures().IsEnabled(
621 common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {
622 messages.Say(
623 "Assumed-rank array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
624 } else {
625 context.Warn(
626 common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
627 messages.at(),
628 "Assumed-rank array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
629 }
630 } else if (actualRank == 0) {
631 if (evaluate::IsArrayElement(actual)) {
632 // Actual argument is a scalar array element
633 evaluate::DesignatorFolder folder{
634 context.foldingContext(), /*getLastComponent=*/true};
635 if (auto actualOffset{folder.FoldDesignator(actual)}) {
636 std::optional<std::int64_t> actualElements;
637 if (static_cast<std::size_t>(actualOffset->offset()) >=
638 actualOffset->symbol().size() ||
639 !evaluate::IsContiguous(
640 actualOffset->symbol(), foldingContext)) {
641 actualElements = 1;
642 } else if (auto actualSymType{evaluate::DynamicType::From(
643 actualOffset->symbol())}) {
644 if (auto actualSymTypeBytes{
645 evaluate::ToInt64(evaluate::Fold(foldingContext,
646 actualSymType->MeasureSizeInBytes(
647 foldingContext, false)))};
648 actualSymTypeBytes && *actualSymTypeBytes > 0) {
649 actualElements = (static_cast<std::int64_t>(
650 actualOffset->symbol().size()) -
651 actualOffset->offset()) /
652 *actualSymTypeBytes;
653 }
654 }
655 if (actualElements && *actualElements < *dummySize) {
656 if (extentErrors) {
657 messages.Say(
658 "Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_err_en_US,
659 static_cast<std::intmax_t>(*actualElements), dummyName,
660 static_cast<std::intmax_t>(*dummySize));
661 } else if (context.ShouldWarn(
662 common::UsageWarning::ShortArrayActual)) {
663 messages.Say(common::UsageWarning::ShortArrayActual,
664 "Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US,
665 static_cast<std::intmax_t>(*actualElements), dummyName,
666 static_cast<std::intmax_t>(*dummySize));
667 }
668 }
669 }
670 }
671 } else {
672 if (auto actualSize{evaluate::ToInt64(evaluate::Fold(
673 foldingContext, evaluate::GetSize(actualType.shape())))};
674 actualSize && *actualSize < *dummySize) {
675 if (extentErrors) {
676 messages.Say(
677 "Actual argument array has fewer elements (%jd) than %s array (%jd)"_err_en_US,
678 static_cast<std::intmax_t>(*actualSize), dummyName,
679 static_cast<std::intmax_t>(*dummySize));
680 } else if (context.ShouldWarn(
681 common::UsageWarning::ShortArrayActual)) {
682 messages.Say(common::UsageWarning::ShortArrayActual,
683 "Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US,
684 static_cast<std::intmax_t>(*actualSize), dummyName,
685 static_cast<std::intmax_t>(*dummySize));
686 }
687 }
688 }
689 }
690 }
691 }
692 if (actualLastObject && actualLastObject->IsCoarray() &&
693 IsAllocatable(*actualLastSymbol) && dummy.intent == common::Intent::Out &&
694 !(intrinsic &&
695 evaluate::AcceptsIntentOutAllocatableCoarray(
696 intrinsic->name))) { // C846
697 messages.Say(
698 "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
699 actualLastSymbol->name(), dummyName);
700 }
701
702 // Definability checking
703 // Problems with polymorphism are caught in the callee's definition.
704 if (scope) {
705 std::optional<parser::MessageFixedText> undefinableMessage;
706 if (dummy.intent == common::Intent::Out) {
707 undefinableMessage =
708 "Actual argument associated with INTENT(OUT) %s is not definable"_err_en_US;
709 } else if (dummy.intent == common::Intent::InOut) {
710 undefinableMessage =
711 "Actual argument associated with INTENT(IN OUT) %s is not definable"_err_en_US;
712 } else if (context.ShouldWarn(common::LanguageFeature::
713 UndefinableAsynchronousOrVolatileActual)) {
714 if (dummy.attrs.test(
715 characteristics::DummyDataObject::Attr::Asynchronous)) {
716 undefinableMessage =
717 "Actual argument associated with ASYNCHRONOUS %s is not definable"_warn_en_US;
718 } else if (dummy.attrs.test(
719 characteristics::DummyDataObject::Attr::Volatile)) {
720 undefinableMessage =
721 "Actual argument associated with VOLATILE %s is not definable"_warn_en_US;
722 }
723 }
724 if (undefinableMessage) {
725 DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
726 if (isElemental) { // 15.5.2.4(21)
727 flags.set(DefinabilityFlag::VectorSubscriptIsOk);
728 }
729 if (actualIsPointer && dummyIsPointer) { // 19.6.8
730 flags.set(DefinabilityFlag::PointerDefinition);
731 }
732 if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) {
733 if (whyNot->IsFatal()) {
734 if (auto *msg{messages.Say(*undefinableMessage, dummyName)}) {
735 if (!msg->IsFatal()) {
736 msg->set_languageFeature(common::LanguageFeature::
737 UndefinableAsynchronousOrVolatileActual);
738 }
739 msg->Attach(
740 std::move(whyNot->set_severity(parser::Severity::Because)));
741 }
742 } else {
743 messages.Say(std::move(*whyNot));
744 }
745 }
746 } else if (dummy.intent != common::Intent::In ||
747 (dummyIsPointer && !actualIsPointer)) {
748 if (auto named{evaluate::ExtractNamedEntity(actual)}) {
749 if (const Symbol & base{named->GetFirstSymbol()};
750 IsFunctionResult(base)) {
751 context.NoteDefinedSymbol(base);
752 }
753 }
754 }
755 }
756
757 // Cases when temporaries might be needed but must not be permitted.
758 bool actualIsContiguous{IsSimplyContiguous(actual, foldingContext)};
759 bool dummyIsAssumedShape{dummy.type.attrs().test(
760 characteristics::TypeAndShape::Attr::AssumedShape)};
761 bool dummyIsContiguous{
762 dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
763 if ((actualIsAsynchronous || actualIsVolatile) &&
764 (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
765 if (actualIsCoindexed) { // C1538
766 messages.Say(
767 "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
768 dummyName);
769 }
770 if ((actualRank > 0 || actualIsAssumedRank) && !actualIsContiguous) {
771 if (dummyIsContiguous ||
772 !(dummyIsAssumedShape || dummyIsAssumedRank ||
773 (actualIsPointer && dummyIsPointer))) { // C1539 & C1540
774 messages.Say(
775 "ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous ASYNCHRONOUS or VOLATILE %s"_err_en_US,
776 dummyName);
777 }
778 }
779 }
780
781 // 15.5.2.6 -- dummy is ALLOCATABLE
782 bool dummyIsOptional{
783 dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
784 bool actualIsNull{evaluate::IsNullPointer(actual)};
785 if (dummyIsAllocatable) {
786 if (actualIsAllocatable) {
787 if (actualIsCoindexed && dummy.intent != common::Intent::In) {
788 messages.Say(
789 "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,
790 dummyName);
791 }
792 } else if (actualIsNull) {
793 if (dummyIsOptional) {
794 } else if (dummy.intent == common::Intent::In) {
795 // Extension (Intel, NAG, XLF): a NULL() pointer is an acceptable
796 // actual argument for an INTENT(IN) allocatable dummy, and it
797 // is treated as an unassociated allocatable.
798 if (context.ShouldWarn(
799 common::LanguageFeature::NullActualForAllocatable)) {
800 messages.Say(common::LanguageFeature::NullActualForAllocatable,
801 "Allocatable %s is associated with a null pointer"_port_en_US,
802 dummyName);
803 }
804 } else {
805 messages.Say(
806 "A null pointer may not be associated with allocatable %s without INTENT(IN)"_err_en_US,
807 dummyName);
808 }
809 } else {
810 messages.Say(
811 "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US,
812 dummyName);
813 }
814 if (!actualIsCoindexed && actualLastSymbol &&
815 actualLastSymbol->Corank() != dummy.type.corank()) {
816 messages.Say(
817 "ALLOCATABLE %s has corank %d but actual argument has corank %d"_err_en_US,
818 dummyName, dummy.type.corank(), actualLastSymbol->Corank());
819 }
820 }
821
822 // 15.5.2.7 -- dummy is POINTER
823 if (dummyIsPointer) {
824 if (actualIsPointer || dummy.intent == common::Intent::In) {
825 if (scope) {
826 semantics::CheckPointerAssignment(context, messages.at(), dummyName,
827 dummy, actual, *scope,
828 /*isAssumedRank=*/dummyIsAssumedRank);
829 }
830 } else if (!actualIsPointer) {
831 messages.Say(
832 "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
833 dummyName);
834 }
835 }
836
837 // 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE
838 // For INTENT(IN), and for a polymorphic actual being associated with a
839 // monomorphic dummy, we relax two checks that are in Fortran to
840 // prevent the callee from changing the type or to avoid having
841 // to use a descriptor.
842 if (!typesCompatible) {
843 // Don't pile on the errors emitted above
844 } else if ((actualIsPointer && dummyIsPointer) ||
845 (actualIsAllocatable && dummyIsAllocatable)) {
846 bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()};
847 bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()};
848 bool checkTypeCompatibility{true};
849 if (actualIsUnlimited != dummyIsUnlimited) {
850 checkTypeCompatibility = false;
851 if (dummyIsUnlimited && dummy.intent == common::Intent::In &&
852 context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
853 if (context.ShouldWarn(
854 common::LanguageFeature::RelaxedIntentInChecking)) {
855 messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
856 "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both should be so"_port_en_US);
857 }
858 } else {
859 messages.Say(
860 "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so"_err_en_US);
861 }
862 } else if (dummyIsPolymorphic != actualIsPolymorphic) {
863 if (dummyIsPolymorphic && dummy.intent == common::Intent::In &&
864 context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
865 if (context.ShouldWarn(
866 common::LanguageFeature::RelaxedIntentInChecking)) {
867 messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
868 "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_port_en_US);
869 }
870 } else if (actualIsPolymorphic &&
871 context.IsEnabled(common::LanguageFeature::
872 PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {
873 if (context.ShouldWarn(common::LanguageFeature::
874 PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {
875 messages.Say(
876 common::LanguageFeature::
877 PolymorphicActualAllocatableOrPointerToMonomorphicDummy,
878 "If a POINTER or ALLOCATABLE actual argument is polymorphic, the corresponding dummy argument should also be so"_port_en_US);
879 }
880 } else {
881 checkTypeCompatibility = false;
882 messages.Say(
883 "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);
884 }
885 }
886 if (checkTypeCompatibility && !actualIsUnlimited) {
887 if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) {
888 if (dummy.intent == common::Intent::In &&
889 context.IsEnabled(
890 common::LanguageFeature::RelaxedIntentInChecking)) {
891 if (context.ShouldWarn(
892 common::LanguageFeature::RelaxedIntentInChecking)) {
893 messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
894 "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US);
895 }
896 } else {
897 messages.Say(
898 "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US);
899 }
900 }
901 // 15.5.2.5(4)
902 const auto *dummyDerived{evaluate::GetDerivedTypeSpec(dummy.type.type())};
903 if (!DefersSameTypeParameters(actualDerived, dummyDerived) ||
904 dummy.type.type().HasDeferredTypeParameter() !=
905 actualType.type().HasDeferredTypeParameter()) {
906 messages.Say(
907 "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
908 }
909 }
910 }
911
912 // 15.5.2.8 -- coarray dummy arguments
913 if (dummy.type.corank() > 0) {
914 if (actualType.corank() == 0) {
915 messages.Say(
916 "Actual argument associated with coarray %s must be a coarray"_err_en_US,
917 dummyName);
918 }
919 if (dummyIsVolatile) {
920 if (!actualIsVolatile) {
921 messages.Say(
922 "non-VOLATILE coarray may not be associated with VOLATILE coarray %s"_err_en_US,
923 dummyName);
924 }
925 } else {
926 if (actualIsVolatile) {
927 messages.Say(
928 "VOLATILE coarray may not be associated with non-VOLATILE coarray %s"_err_en_US,
929 dummyName);
930 }
931 }
932 if (actualRank == dummyRank && !actualIsContiguous) {
933 if (dummyIsContiguous) {
934 messages.Say(
935 "Actual argument associated with a CONTIGUOUS coarray %s must be simply contiguous"_err_en_US,
936 dummyName);
937 } else if (!dummyIsAssumedShape && !dummyIsAssumedRank) {
938 messages.Say(
939 "Actual argument associated with coarray %s (not assumed shape or rank) must be simply contiguous"_err_en_US,
940 dummyName);
941 }
942 }
943 }
944
945 // NULL(MOLD=) checking for non-intrinsic procedures
946 if (!intrinsic && !dummyIsAllocatableOrPointer && !dummyIsOptional &&
947 actualIsNull) {
948 messages.Say(
949 "Actual argument associated with %s may not be null pointer %s"_err_en_US,
950 dummyName, actual.AsFortran());
951 }
952
953 // Warn about dubious actual argument association with a TARGET dummy
954 // argument
955 if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) &&
956 context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) {
957 bool actualIsVariable{evaluate::IsVariable(actual)};
958 bool actualIsTemp{!actualIsVariable || HasVectorSubscript(actual) ||
959 evaluate::ExtractCoarrayRef(actual)};
960 if (actualIsTemp) {
961 messages.Say(common::UsageWarning::NonTargetPassedToTarget,
962 "Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US,
963 dummyName, actual.AsFortran());
964 } else {
965 auto actualSymbolVector{GetSymbolVector(actual)};
966 if (!evaluate::GetLastTarget(actualSymbolVector)) {
967 messages.Say(common::UsageWarning::NonTargetPassedToTarget,
968 "Any pointer associated with TARGET %s during this call must not be used afterwards, as '%s' is not a target"_warn_en_US,
969 dummyName, actual.AsFortran());
970 }
971 }
972 }
973
974 // CUDA specific checks
975 // TODO: These are disabled in OpenACC constructs, which may not be
976 // correct when the target is not a GPU.
977 if (!intrinsic &&
978 !dummy.attrs.test(characteristics::DummyDataObject::Attr::Value) &&
979 !FindOpenACCConstructContaining(scope)) {
980 std::optional<common::CUDADataAttr> actualDataAttr, dummyDataAttr;
981 if (const auto *actualObject{actualLastSymbol
982 ? actualLastSymbol->detailsIf<ObjectEntityDetails>()
983 : nullptr}) {
984 actualDataAttr = actualObject->cudaDataAttr();
985 }
986 dummyDataAttr = dummy.cudaDataAttr;
987 // Treat MANAGED like DEVICE for nonallocatable nonpointer arguments to
988 // device subprograms
989 if (procedure.cudaSubprogramAttrs.value_or(
990 common::CUDASubprogramAttrs::Host) !=
991 common::CUDASubprogramAttrs::Host &&
992 !dummy.attrs.test(
993 characteristics::DummyDataObject::Attr::Allocatable) &&
994 !dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)) {
995 if (!dummyDataAttr || *dummyDataAttr == common::CUDADataAttr::Managed) {
996 dummyDataAttr = common::CUDADataAttr::Device;
997 }
998 if ((!actualDataAttr && FindCUDADeviceContext(scope)) ||
999 (actualDataAttr &&
1000 *actualDataAttr == common::CUDADataAttr::Managed)) {
1001 actualDataAttr = common::CUDADataAttr::Device;
1002 }
1003 }
1004 std::optional<std::string> warning;
1005 if (!common::AreCompatibleCUDADataAttrs(dummyDataAttr, actualDataAttr,
1006 dummy.ignoreTKR, &warning,
1007 /*allowUnifiedMatchingRule=*/true, &context.languageFeatures())) {
1008 auto toStr{[](std::optional<common::CUDADataAttr> x) {
1009 return x ? "ATTRIBUTES("s +
1010 parser::ToUpperCaseLetters(common::EnumToString(*x)) + ")"s
1011 : "no CUDA data attribute"s;
1012 }};
1013 messages.Say(
1014 "%s has %s but its associated actual argument has %s"_err_en_US,
1015 dummyName, toStr(dummyDataAttr), toStr(actualDataAttr));
1016 }
1017 if (warning && context.ShouldWarn(common::UsageWarning::CUDAUsage)) {
1018 messages.Say(common::UsageWarning::CUDAUsage, "%s"_warn_en_US,
1019 std::move(*warning));
1020 }
1021 }
1022
1023 // Warning for breaking F'2023 change with character allocatables
1024 if (intrinsic && dummy.intent != common::Intent::In) {
1025 WarnOnDeferredLengthCharacterScalar(
1026 context, &actual, messages.at(), dummyName.c_str());
1027 }
1028
1029 // %VAL() and %REF() checking for explicit interface
1030 if ((arg.isPercentRef() || arg.isPercentVal()) &&
1031 dummy.IsPassedByDescriptor(procedure.IsBindC())) {
1032 messages.Say(
1033 "%%VAL or %%REF are not allowed for %s that must be passed by means of a descriptor"_err_en_US,
1034 dummyName);
1035 }
1036 if (arg.isPercentVal() &&
1037 (!actualType.type().IsLengthlessIntrinsicType() ||
1038 actualType.Rank() != 0)) {
1039 messages.Say(
1040 "%VAL argument must be a scalar numeric or logical expression"_err_en_US);
1041 }
1042 }
1043
1044 static void CheckProcedureArg(evaluate::ActualArgument &arg,
1045 const characteristics::Procedure &proc,
1046 const characteristics::DummyProcedure &dummy, const std::string &dummyName,
1047 SemanticsContext &context, bool ignoreImplicitVsExplicit) {
1048 evaluate::FoldingContext &foldingContext{context.foldingContext()};
1049 parser::ContextualMessages &messages{foldingContext.messages()};
1050 auto restorer{
1051 messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
1052 const characteristics::Procedure &interface { dummy.procedure.value() };
1053 if (const auto *expr{arg.UnwrapExpr()}) {
1054 bool dummyIsPointer{
1055 dummy.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
1056 const auto *argProcDesignator{
1057 std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
1058 const auto *argProcSymbol{
1059 argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
1060 if (argProcSymbol) {
1061 if (const auto *subp{
1062 argProcSymbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
1063 if (subp->stmtFunction()) {
1064 evaluate::SayWithDeclaration(messages, *argProcSymbol,
1065 "Statement function '%s' may not be passed as an actual argument"_err_en_US,
1066 argProcSymbol->name());
1067 return;
1068 }
1069 } else if (argProcSymbol->has<ProcBindingDetails>()) {
1070 if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure)) {
1071 evaluate::SayWithDeclaration(messages, *argProcSymbol,
1072 "Procedure binding '%s' passed as an actual argument"_err_en_US,
1073 argProcSymbol->name());
1074 } else if (context.ShouldWarn(
1075 common::LanguageFeature::BindingAsProcedure)) {
1076 evaluate::SayWithDeclaration(messages, *argProcSymbol,
1077 common::LanguageFeature::BindingAsProcedure,
1078 "Procedure binding '%s' passed as an actual argument"_port_en_US,
1079 argProcSymbol->name());
1080 }
1081 }
1082 }
1083 if (auto argChars{characteristics::DummyArgument::FromActual(
1084 "actual argument", *expr, foldingContext,
1085 /*forImplicitInterface=*/true)}) {
1086 if (!argChars->IsTypelessIntrinsicDummy()) {
1087 if (auto *argProc{
1088 std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
1089 characteristics::Procedure &argInterface{argProc->procedure.value()};
1090 argInterface.attrs.reset(
1091 characteristics::Procedure::Attr::NullPointer);
1092 if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
1093 // It's ok to pass ELEMENTAL unrestricted intrinsic functions.
1094 argInterface.attrs.reset(
1095 characteristics::Procedure::Attr::Elemental);
1096 } else if (argInterface.attrs.test(
1097 characteristics::Procedure::Attr::Elemental)) {
1098 if (argProcSymbol) { // C1533
1099 evaluate::SayWithDeclaration(messages, *argProcSymbol,
1100 "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
1101 argProcSymbol->name());
1102 return; // avoid piling on with checks below
1103 } else {
1104 argInterface.attrs.reset(
1105 characteristics::Procedure::Attr::NullPointer);
1106 }
1107 }
1108 if (interface.HasExplicitInterface()) {
1109 std::string whyNot;
1110 std::optional<std::string> warning;
1111 if (!interface.IsCompatibleWith(argInterface,
1112 ignoreImplicitVsExplicit, &whyNot,
1113 /*specificIntrinsic=*/nullptr, &warning)) {
1114 // 15.5.2.9(1): Explicit interfaces must match
1115 if (argInterface.HasExplicitInterface()) {
1116 messages.Say(
1117 "Actual procedure argument has interface incompatible with %s: %s"_err_en_US,
1118 dummyName, whyNot);
1119 return;
1120 } else if (proc.IsPure()) {
1121 messages.Say(
1122 "Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US,
1123 dummyName);
1124 } else if (context.ShouldWarn(
1125 common::UsageWarning::ImplicitInterfaceActual)) {
1126 messages.Say(common::UsageWarning::ImplicitInterfaceActual,
1127 "Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US,
1128 dummyName);
1129 }
1130 } else if (warning &&
1131 context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) {
1132 messages.Say(common::UsageWarning::ProcDummyArgShapes,
1133 "Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US,
1134 dummyName, std::move(*warning));
1135 }
1136 } else { // 15.5.2.9(2,3)
1137 if (interface.IsSubroutine() && argInterface.IsFunction()) {
1138 messages.Say(
1139 "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
1140 dummyName);
1141 } else if (interface.IsFunction()) {
1142 if (argInterface.IsFunction()) {
1143 std::string whyNot;
1144 if (!interface.functionResult->IsCompatibleWith(
1145 *argInterface.functionResult, &whyNot)) {
1146 messages.Say(
1147 "Actual argument function associated with procedure %s is not compatible: %s"_err_en_US,
1148 dummyName, whyNot);
1149 }
1150 } else if (argInterface.IsSubroutine()) {
1151 messages.Say(
1152 "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
1153 dummyName);
1154 }
1155 }
1156 }
1157 } else {
1158 messages.Say(
1159 "Actual argument associated with procedure %s is not a procedure"_err_en_US,
1160 dummyName);
1161 }
1162 } else if (IsNullPointer(*expr)) {
1163 if (!dummyIsPointer &&
1164 !dummy.attrs.test(
1165 characteristics::DummyProcedure::Attr::Optional)) {
1166 messages.Say(
1167 "Actual argument associated with procedure %s is a null pointer"_err_en_US,
1168 dummyName);
1169 }
1170 } else {
1171 messages.Say(
1172 "Actual argument associated with procedure %s is typeless"_err_en_US,
1173 dummyName);
1174 }
1175 }
1176 if (dummyIsPointer && dummy.intent != common::Intent::In) {
1177 const Symbol *last{GetLastSymbol(*expr)};
1178 if (last && IsProcedurePointer(*last)) {
1179 if (dummy.intent != common::Intent::Default &&
1180 IsIntentIn(last->GetUltimate())) { // 19.6.8
1181 messages.Say(
1182 "Actual argument associated with procedure pointer %s may not be INTENT(IN)"_err_en_US,
1183 dummyName);
1184 }
1185 } else if (!(dummy.intent == common::Intent::Default &&
1186 IsNullProcedurePointer(*expr))) {
1187 // 15.5.2.9(5) -- dummy procedure POINTER
1188 // Interface compatibility has already been checked above
1189 messages.Say(
1190 "Actual argument associated with procedure pointer %s must be a pointer unless INTENT(IN)"_err_en_US,
1191 dummyName);
1192 }
1193 }
1194 } else {
1195 messages.Say(
1196 "Assumed-type argument may not be forwarded as procedure %s"_err_en_US,
1197 dummyName);
1198 }
1199 }
1200
1201 // Allow BOZ literal actual arguments when they can be converted to a known
1202 // dummy argument type
1203 static void ConvertBOZLiteralArg(
1204 evaluate::ActualArgument &arg, const evaluate::DynamicType &type) {
1205 if (auto *expr{arg.UnwrapExpr()}) {
1206 if (IsBOZLiteral(*expr)) {
1207 if (auto converted{evaluate::ConvertToType(type, SomeExpr{*expr})}) {
1208 arg = std::move(*converted);
1209 }
1210 }
1211 }
1212 }
1213
1214 static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
1215 const characteristics::DummyArgument &dummy,
1216 const characteristics::Procedure &proc, SemanticsContext &context,
1217 const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
1218 bool allowActualArgumentConversions, bool extentErrors,
1219 bool ignoreImplicitVsExplicit) {
1220 evaluate::FoldingContext &foldingContext{context.foldingContext()};
1221 auto &messages{foldingContext.messages()};
1222 std::string dummyName{"dummy argument"};
1223 if (!dummy.name.empty()) {
1224 dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
1225 }
1226 auto restorer{
1227 messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
1228 auto CheckActualArgForLabel = [&](evaluate::ActualArgument &arg) {
1229 if (arg.isAlternateReturn()) {
1230 messages.Say(
1231 "Alternate return label '%d' cannot be associated with %s"_err_en_US,
1232 arg.GetLabel(), dummyName);
1233 return false;
1234 } else {
1235 return true;
1236 }
1237 };
1238 common::visit(
1239 common::visitors{
1240 [&](const characteristics::DummyDataObject &object) {
1241 if (CheckActualArgForLabel(arg)) {
1242 ConvertBOZLiteralArg(arg, object.type.type());
1243 if (auto *expr{arg.UnwrapExpr()}) {
1244 if (auto type{characteristics::TypeAndShape::Characterize(
1245 *expr, foldingContext)}) {
1246 arg.set_dummyIntent(object.intent);
1247 bool isElemental{
1248 object.type.Rank() == 0 && proc.IsElemental()};
1249 CheckExplicitDataArg(object, dummyName, *expr, *type,
1250 isElemental, context, foldingContext, scope, intrinsic,
1251 allowActualArgumentConversions, extentErrors, proc, arg);
1252 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
1253 IsBOZLiteral(*expr)) {
1254 // ok
1255 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
1256 evaluate::IsNullObjectPointer(*expr)) {
1257 // ok, ASSOCIATED(NULL(without MOLD=))
1258 } else if (object.type.attrs().test(characteristics::
1259 TypeAndShape::Attr::AssumedRank) &&
1260 evaluate::IsNullObjectPointer(*expr) &&
1261 (object.attrs.test(
1262 characteristics::DummyDataObject::Attr::Allocatable) ||
1263 object.attrs.test(
1264 characteristics::DummyDataObject::Attr::Pointer) ||
1265 !object.attrs.test(characteristics::DummyDataObject::
1266 Attr::Optional))) {
1267 messages.Say(
1268 "NULL() without MOLD= must not be associated with an assumed-rank dummy argument that is ALLOCATABLE, POINTER, or non-OPTIONAL"_err_en_US);
1269 } else if ((object.attrs.test(characteristics::DummyDataObject::
1270 Attr::Pointer) ||
1271 object.attrs.test(characteristics::
1272 DummyDataObject::Attr::Optional)) &&
1273 evaluate::IsNullObjectPointer(*expr)) {
1274 // FOO(NULL(without MOLD=))
1275 if (object.type.type().IsAssumedLengthCharacter()) {
1276 messages.Say(
1277 "Actual argument associated with %s is a NULL() pointer without a MOLD= to provide a character length"_err_en_US,
1278 dummyName);
1279 } else if (const DerivedTypeSpec *
1280 derived{GetDerivedTypeSpec(object.type.type())}) {
1281 for (const auto &[pName, pValue] : derived->parameters()) {
1282 if (pValue.isAssumed()) {
1283 messages.Say(
1284 "Actual argument associated with %s is a NULL() pointer without a MOLD= to provide a value for the assumed type parameter '%s'"_err_en_US,
1285 dummyName, pName.ToString());
1286 break;
1287 }
1288 }
1289 }
1290 } else if (object.attrs.test(characteristics::DummyDataObject::
1291 Attr::Allocatable) &&
1292 evaluate::IsNullPointer(*expr)) {
1293 if (object.intent == common::Intent::In) {
1294 // Extension (Intel, NAG, XLF); see CheckExplicitDataArg.
1295 if (context.ShouldWarn(common::LanguageFeature::
1296 NullActualForAllocatable)) {
1297 messages.Say(
1298 common::LanguageFeature::NullActualForAllocatable,
1299 "Allocatable %s is associated with NULL()"_port_en_US,
1300 dummyName);
1301 }
1302 } else {
1303 messages.Say(
1304 "NULL() actual argument '%s' may not be associated with allocatable %s without INTENT(IN)"_err_en_US,
1305 expr->AsFortran(), dummyName);
1306 }
1307 } else {
1308 messages.Say(
1309 "Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,
1310 expr->AsFortran(), dummyName);
1311 }
1312 } else {
1313 const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};
1314 if (!object.type.type().IsAssumedType()) {
1315 messages.Say(
1316 "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,
1317 assumed.name(), dummyName);
1318 } else if (object.type.attrs().test(characteristics::
1319 TypeAndShape::Attr::AssumedRank) &&
1320 !IsAssumedShape(assumed) &&
1321 !evaluate::IsAssumedRank(assumed)) {
1322 messages.Say( // C711
1323 "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US,
1324 assumed.name(), dummyName);
1325 }
1326 }
1327 }
1328 },
1329 [&](const characteristics::DummyProcedure &dummy) {
1330 if (CheckActualArgForLabel(arg)) {
1331 CheckProcedureArg(arg, proc, dummy, dummyName, context,
1332 ignoreImplicitVsExplicit);
1333 }
1334 },
1335 [&](const characteristics::AlternateReturn &) {
1336 // All semantic checking is done elsewhere
1337 },
1338 },
1339 dummy.u);
1340 }
1341
1342 static void RearrangeArguments(const characteristics::Procedure &proc,
1343 evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) {
1344 CHECK(proc.HasExplicitInterface());
1345 if (actuals.size() < proc.dummyArguments.size()) {
1346 actuals.resize(proc.dummyArguments.size());
1347 } else if (actuals.size() > proc.dummyArguments.size()) {
1348 messages.Say(
1349 "Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US,
1350 actuals.size(), proc.dummyArguments.size());
1351 }
1352 std::map<std::string, evaluate::ActualArgument> kwArgs;
1353 bool anyKeyword{false};
1354 int which{1};
1355 for (auto &x : actuals) {
1356 if (!x) {
1357 } else if (x->keyword()) {
1358 auto emplaced{
1359 kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};
1360 if (!emplaced.second) {
1361 messages.Say(*x->keyword(),
1362 "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
1363 *x->keyword());
1364 }
1365 x.reset();
1366 anyKeyword = true;
1367 } else if (anyKeyword) {
1368 messages.Say(x ? x->sourceLocation() : std::nullopt,
1369 "Actual argument #%d without a keyword may not follow any actual argument with a keyword"_err_en_US,
1370 which);
1371 }
1372 ++which;
1373 }
1374 if (!kwArgs.empty()) {
1375 int index{0};
1376 for (const auto &dummy : proc.dummyArguments) {
1377 if (!dummy.name.empty()) {
1378 auto iter{kwArgs.find(dummy.name)};
1379 if (iter != kwArgs.end()) {
1380 evaluate::ActualArgument &x{iter->second};
1381 if (actuals[index]) {
1382 messages.Say(*x.keyword(),
1383 "Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,
1384 *x.keyword(), index + 1);
1385 } else {
1386 actuals[index] = std::move(x);
1387 }
1388 kwArgs.erase(iter);
1389 }
1390 }
1391 ++index;
1392 }
1393 for (auto &bad : kwArgs) {
1394 evaluate::ActualArgument &x{bad.second};
1395 messages.Say(*x.keyword(),
1396 "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
1397 *x.keyword());
1398 }
1399 }
1400 }
1401
1402 // 15.8.1(3) -- In a reference to an elemental procedure, if any argument is an
1403 // array, each actual argument that corresponds to an INTENT(OUT) or
1404 // INTENT(INOUT) dummy argument shall be an array. The actual argument to an
1405 // ELEMENTAL procedure must conform.
1406 static bool CheckElementalConformance(parser::ContextualMessages &messages,
1407 const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
1408 evaluate::FoldingContext &context) {
1409 std::optional<evaluate::Shape> shape;
1410 std::string shapeName;
1411 int index{0};
1412 bool hasArrayArg{false};
1413 for (const auto &arg : actuals) {
1414 if (arg && !arg->isAlternateReturn() && arg->Rank() > 0) {
1415 hasArrayArg = true;
1416 break;
1417 }
1418 }
1419 for (const auto &arg : actuals) {
1420 const auto &dummy{proc.dummyArguments.at(index++)};
1421 if (arg) {
1422 if (const auto *expr{arg->UnwrapExpr()}) {
1423 if (const auto *wholeSymbol{evaluate::UnwrapWholeSymbolDataRef(arg)}) {
1424 wholeSymbol = &ResolveAssociations(*wholeSymbol);
1425 if (IsAssumedSizeArray(*wholeSymbol)) {
1426 evaluate::SayWithDeclaration(messages, *wholeSymbol,
1427 "Whole assumed-size array '%s' may not be used as an argument to an elemental procedure"_err_en_US,
1428 wholeSymbol->name());
1429 }
1430 }
1431 if (auto argShape{evaluate::GetShape(context, *expr)}) {
1432 if (GetRank(*argShape) > 0) {
1433 std::string argName{"actual argument ("s + expr->AsFortran() +
1434 ") corresponding to dummy argument #" + std::to_string(index) +
1435 " ('" + dummy.name + "')"};
1436 if (shape) {
1437 auto tristate{evaluate::CheckConformance(messages, *shape,
1438 *argShape, evaluate::CheckConformanceFlags::None,
1439 shapeName.c_str(), argName.c_str())};
1440 if (tristate && !*tristate) {
1441 return false;
1442 }
1443 } else {
1444 shape = std::move(argShape);
1445 shapeName = argName;
1446 }
1447 } else if ((dummy.GetIntent() == common::Intent::Out ||
1448 dummy.GetIntent() == common::Intent::InOut) &&
1449 hasArrayArg) {
1450 messages.Say(
1451 "In an elemental procedure reference with at least one array argument, actual argument %s that corresponds to an INTENT(OUT) or INTENT(INOUT) dummy argument must be an array"_err_en_US,
1452 expr->AsFortran());
1453 }
1454 }
1455 }
1456 }
1457 }
1458 return true;
1459 }
1460
1461 // ASSOCIATED (16.9.16)
1462 static void CheckAssociated(evaluate::ActualArguments &arguments,
1463 SemanticsContext &semanticsContext, const Scope *scope) {
1464 evaluate::FoldingContext &foldingContext{semanticsContext.foldingContext()};
1465 parser::ContextualMessages &messages{foldingContext.messages()};
1466 bool ok{true};
1467 if (arguments.size() < 2) {
1468 return;
1469 }
1470 if (const auto &pointerArg{arguments[0]}) {
1471 if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
1472 if (!IsPointer(*pointerExpr)) {
1473 messages.Say(pointerArg->sourceLocation(),
1474 "POINTER= argument of ASSOCIATED() must be a pointer"_err_en_US);
1475 return;
1476 }
1477 if (const auto &targetArg{arguments[1]}) {
1478 // The standard requires that the TARGET= argument, when present,
1479 // be a valid RHS for a pointer assignment that has the POINTER=
1480 // argument as its LHS. Some popular compilers misinterpret this
1481 // requirement more strongly than necessary, and actually validate
1482 // the POINTER= argument as if it were serving as the LHS of a pointer
1483 // assignment. This, perhaps unintentionally, excludes function
1484 // results, including NULL(), from being used there, as well as
1485 // INTENT(IN) dummy pointers. Detect these conditions and emit
1486 // portability warnings.
1487 if (semanticsContext.ShouldWarn(common::UsageWarning::Portability)) {
1488 if (!evaluate::ExtractDataRef(*pointerExpr) &&
1489 !evaluate::IsProcedurePointer(*pointerExpr)) {
1490 messages.Say(common::UsageWarning::Portability,
1491 pointerArg->sourceLocation(),
1492 "POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer"_port_en_US);
1493 } else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) {
1494 if (auto whyNot{WhyNotDefinable(
1495 pointerArg->sourceLocation().value_or(messages.at()),
1496 *scope,
1497 DefinabilityFlags{DefinabilityFlag::PointerDefinition,
1498 DefinabilityFlag::DoNotNoteDefinition},
1499 *pointerExpr)}) {
1500 if (whyNot->IsFatal()) {
1501 if (auto *msg{messages.Say(common::UsageWarning::Portability,
1502 pointerArg->sourceLocation(),
1503 "POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement"_port_en_US)}) {
1504 msg->Attach(std::move(
1505 whyNot->set_severity(parser::Severity::Because)));
1506 }
1507 } else {
1508 messages.Say(std::move(*whyNot));
1509 }
1510 }
1511 }
1512 }
1513 if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
1514 if (IsProcedurePointer(*pointerExpr) &&
1515 !IsBareNullPointer(pointerExpr)) { // POINTER= is a procedure
1516 if (auto pointerProc{characteristics::Procedure::Characterize(
1517 *pointerExpr, foldingContext)}) {
1518 if (IsBareNullPointer(targetExpr)) {
1519 } else if (IsProcedurePointerTarget(*targetExpr)) {
1520 if (auto targetProc{characteristics::Procedure::Characterize(
1521 *targetExpr, foldingContext)}) {
1522 bool isCall{!!UnwrapProcedureRef(*targetExpr)};
1523 std::string whyNot;
1524 std::optional<std::string> warning;
1525 const auto *targetProcDesignator{
1526 evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
1527 *targetExpr)};
1528 const evaluate::SpecificIntrinsic *specificIntrinsic{
1529 targetProcDesignator
1530 ? targetProcDesignator->GetSpecificIntrinsic()
1531 : nullptr};
1532 std::optional<parser::MessageFixedText> msg{
1533 CheckProcCompatibility(isCall, pointerProc, &*targetProc,
1534 specificIntrinsic, whyNot, warning,
1535 /*ignoreImplicitVsExplicit=*/false)};
1536 std::optional<common::UsageWarning> whichWarning;
1537 if (!msg && warning &&
1538 semanticsContext.ShouldWarn(
1539 common::UsageWarning::ProcDummyArgShapes)) {
1540 whichWarning = common::UsageWarning::ProcDummyArgShapes;
1541 msg =
1542 "Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US;
1543 whyNot = std::move(*warning);
1544 } else if (msg && !msg->IsFatal() &&
1545 semanticsContext.ShouldWarn(
1546 common::UsageWarning::ProcPointerCompatibility)) {
1547 whichWarning =
1548 common::UsageWarning::ProcPointerCompatibility;
1549 }
1550 if (msg && (msg->IsFatal() || whichWarning)) {
1551 if (auto *said{messages.Say(std::move(*msg),
1552 "pointer '" + pointerExpr->AsFortran() + "'",
1553 targetExpr->AsFortran(), whyNot)};
1554 said && whichWarning) {
1555 said->set_usageWarning(*whichWarning);
1556 }
1557 }
1558 }
1559 } else if (!IsNullProcedurePointer(*targetExpr)) {
1560 messages.Say(
1561 "POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US,
1562 pointerExpr->AsFortran(), targetExpr->AsFortran());
1563 }
1564 }
1565 } else if (IsVariable(*targetExpr) || IsNullPointer(*targetExpr)) {
1566 // Object pointer and target
1567 if (ExtractDataRef(*targetExpr)) {
1568 if (SymbolVector symbols{GetSymbolVector(*targetExpr)};
1569 !evaluate::GetLastTarget(symbols)) {
1570 parser::Message *msg{messages.Say(targetArg->sourceLocation(),
1571 "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
1572 targetExpr->AsFortran())};
1573 for (SymbolRef ref : symbols) {
1574 msg = evaluate::AttachDeclaration(msg, *ref);
1575 }
1576 } else if (HasVectorSubscript(*targetExpr) ||
1577 ExtractCoarrayRef(*targetExpr)) {
1578 messages.Say(targetArg->sourceLocation(),
1579 "TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US,
1580 targetExpr->AsFortran());
1581 }
1582 }
1583 if (const auto pointerType{pointerArg->GetType()}) {
1584 if (const auto targetType{targetArg->GetType()}) {
1585 ok = pointerType->IsTkCompatibleWith(*targetType);
1586 }
1587 }
1588 } else {
1589 messages.Say(
1590 "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,
1591 pointerExpr->AsFortran(), targetExpr->AsFortran());
1592 }
1593 if (!IsAssumedRank(*pointerExpr)) {
1594 if (IsAssumedRank(*targetExpr)) {
1595 messages.Say(
1596 "TARGET= argument '%s' may not be assumed-rank when POINTER= argument is not"_err_en_US,
1597 pointerExpr->AsFortran());
1598 } else if (pointerExpr->Rank() != targetExpr->Rank()) {
1599 messages.Say(
1600 "POINTER= argument and TARGET= argument have incompatible ranks %d and %d"_err_en_US,
1601 pointerExpr->Rank(), targetExpr->Rank());
1602 }
1603 }
1604 }
1605 }
1606 }
1607 } else {
1608 // No arguments to ASSOCIATED()
1609 ok = false;
1610 }
1611 if (!ok) {
1612 messages.Say(
1613 "Arguments of ASSOCIATED() must be a pointer and an optional valid target"_err_en_US);
1614 }
1615 }
1616
1617 // IMAGE_INDEX (F'2023 16.9.107)
1618 static void CheckImage_Index(evaluate::ActualArguments &arguments,
1619 parser::ContextualMessages &messages) {
1620 if (arguments[1] && arguments[0]) {
1621 if (const auto subArrShape{
1622 evaluate::GetShape(arguments[1]->UnwrapExpr())}) {
1623 if (const auto *coarrayArgSymbol{UnwrapWholeSymbolOrComponentDataRef(
1624 arguments[0]->UnwrapExpr())}) {
1625 const auto coarrayArgCorank = coarrayArgSymbol->Corank();
1626 if (const auto subArrSize = evaluate::ToInt64(*subArrShape->front())) {
1627 if (subArrSize != coarrayArgCorank) {
1628 messages.Say(arguments[1]->sourceLocation(),
1629 "The size of 'SUB=' (%jd) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (%d)"_err_en_US,
1630 static_cast<std::int64_t>(*subArrSize), coarrayArgCorank);
1631 }
1632 }
1633 }
1634 }
1635 }
1636 }
1637
1638 // Ensure that any optional argument that might be absent at run time
1639 // does not require data conversion.
1640 static void CheckMaxMin(const characteristics::Procedure &proc,
1641 evaluate::ActualArguments &arguments,
1642 parser::ContextualMessages &messages) {
1643 if (proc.functionResult) {
1644 if (const auto *typeAndShape{proc.functionResult->GetTypeAndShape()}) {
1645 for (std::size_t j{2}; j < arguments.size(); ++j) {
1646 if (arguments[j]) {
1647 if (const auto *expr{arguments[j]->UnwrapExpr()};
1648 expr && evaluate::MayBePassedAsAbsentOptional(*expr)) {
1649 if (auto thisType{expr->GetType()}) {
1650 if (thisType->category() == TypeCategory::Character &&
1651 typeAndShape->type().category() == TypeCategory::Character &&
1652 thisType->kind() == typeAndShape->type().kind()) {
1653 // don't care about lengths
1654 } else if (*thisType != typeAndShape->type()) {
1655 messages.Say(arguments[j]->sourceLocation(),
1656 "An actual argument to MAX/MIN requiring data conversion may not be OPTIONAL, POINTER, or ALLOCATABLE"_err_en_US);
1657 }
1658 }
1659 }
1660 }
1661 }
1662 }
1663 }
1664 }
1665
1666 static void CheckFree(evaluate::ActualArguments &arguments,
1667 parser::ContextualMessages &messages) {
1668 if (arguments.size() != 1) {
1669 messages.Say("FREE expects a single argument"_err_en_US);
1670 }
1671 auto arg = arguments[0];
1672 if (const Symbol * symbol{evaluate::UnwrapWholeSymbolDataRef(arg)};
1673 !symbol || !symbol->test(Symbol::Flag::CrayPointer)) {
1674 messages.Say("FREE should only be used with Cray pointers"_warn_en_US);
1675 }
1676 }
1677
1678 // MOVE_ALLOC (F'2023 16.9.147)
1679 static void CheckMove_Alloc(evaluate::ActualArguments &arguments,
1680 parser::ContextualMessages &messages) {
1681 if (arguments.size() >= 1) {
1682 evaluate::CheckForCoindexedObject(
1683 messages, arguments[0], "move_alloc", "from");
1684 }
1685 if (arguments.size() >= 2) {
1686 evaluate::CheckForCoindexedObject(
1687 messages, arguments[1], "move_alloc", "to");
1688 }
1689 if (arguments.size() >= 3) {
1690 evaluate::CheckForCoindexedObject(
1691 messages, arguments[2], "move_alloc", "stat");
1692 }
1693 if (arguments.size() >= 4) {
1694 evaluate::CheckForCoindexedObject(
1695 messages, arguments[3], "move_alloc", "errmsg");
1696 }
1697 if (arguments.size() >= 2 && arguments[0] && arguments[1]) {
1698 for (int j{0}; j < 2; ++j) {
1699 if (const Symbol *
1700 whole{UnwrapWholeSymbolOrComponentDataRef(arguments[j])};
1701 !whole || !IsAllocatable(whole->GetUltimate())) {
1702 messages.Say(*arguments[j]->sourceLocation(),
1703 "Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US, j + 1);
1704 }
1705 }
1706 auto type0{arguments[0]->GetType()};
1707 auto type1{arguments[1]->GetType()};
1708 if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) {
1709 messages.Say(arguments[1]->sourceLocation(),
1710 "When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US);
1711 }
1712 }
1713 }
1714
1715 // PRESENT (F'2023 16.9.163)
1716 static void CheckPresent(evaluate::ActualArguments &arguments,
1717 parser::ContextualMessages &messages) {
1718 if (arguments.size() == 1) {
1719 if (const auto &arg{arguments[0]}; arg) {
1720 const Symbol *symbol{nullptr};
1721 if (const auto *expr{arg->UnwrapExpr()}) {
1722 if (const auto *proc{
1723 std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
1724 symbol = proc->GetSymbol();
1725 } else {
1726 symbol = evaluate::UnwrapWholeSymbolDataRef(*expr);
1727 }
1728 } else {
1729 symbol = arg->GetAssumedTypeDummy();
1730 }
1731 if (!symbol ||
1732 !symbol->GetUltimate().attrs().test(semantics::Attr::OPTIONAL)) {
1733 messages.Say(arg ? arg->sourceLocation() : messages.at(),
1734 "Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument"_err_en_US);
1735 }
1736 }
1737 }
1738 }
1739
1740 // REDUCE (F'2023 16.9.173)
1741 static void CheckReduce(
1742 evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
1743 std::optional<evaluate::DynamicType> arrayType;
1744 parser::ContextualMessages &messages{context.messages()};
1745 if (const auto &array{arguments[0]}) {
1746 arrayType = array->GetType();
1747 if (!arguments[/*identity=*/4]) {
1748 if (const auto *expr{array->UnwrapExpr()}) {
1749 if (auto shape{
1750 evaluate::GetShape(context, *expr, /*invariantOnly=*/false)}) {
1751 if (const auto &dim{arguments[2]}; dim && array->Rank() > 1) {
1752 // Partial reduction
1753 auto dimVal{evaluate::ToInt64(dim->UnwrapExpr())};
1754 std::int64_t j{0};
1755 int zeroDims{0};
1756 bool isSelectedDimEmpty{false};
1757 for (const auto &extent : *shape) {
1758 ++j;
1759 if (evaluate::ToInt64(extent) == 0) {
1760 ++zeroDims;
1761 isSelectedDimEmpty |= dimVal && j == *dimVal;
1762 }
1763 }
1764 if (isSelectedDimEmpty && zeroDims == 1) {
1765 messages.Say(
1766 "IDENTITY= must be present when DIM=%d and the array has zero extent on that dimension"_err_en_US,
1767 static_cast<int>(dimVal.value()));
1768 }
1769 } else { // no DIM= or DIM=1 on a vector: total reduction
1770 for (const auto &extent : *shape) {
1771 if (evaluate::ToInt64(extent) == 0) {
1772 messages.Say(
1773 "IDENTITY= must be present when the array is empty and the result is scalar"_err_en_US);
1774 break;
1775 }
1776 }
1777 }
1778 }
1779 }
1780 }
1781 }
1782 std::optional<characteristics::Procedure> procChars;
1783 if (const auto &operation{arguments[1]}) {
1784 if (const auto *expr{operation->UnwrapExpr()}) {
1785 if (const auto *designator{
1786 std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
1787 procChars = characteristics::Procedure::Characterize(
1788 *designator, context, /*emitError=*/true);
1789 } else if (const auto *ref{
1790 std::get_if<evaluate::ProcedureRef>(&expr->u)}) {
1791 procChars = characteristics::Procedure::Characterize(*ref, context);
1792 }
1793 }
1794 }
1795 const auto *result{
1796 procChars ? procChars->functionResult->GetTypeAndShape() : nullptr};
1797 if (!procChars || !procChars->IsPure() ||
1798 procChars->dummyArguments.size() != 2 || !procChars->functionResult) {
1799 messages.Say(
1800 "OPERATION= argument of REDUCE() must be a pure function of two data arguments"_err_en_US);
1801 } else if (procChars->attrs.test(characteristics::Procedure::Attr::BindC)) {
1802 messages.Say(
1803 "A BIND(C) OPERATION= argument of REDUCE() is not supported"_err_en_US);
1804 } else if (!result || result->Rank() != 0) {
1805 messages.Say(
1806 "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US);
1807 } else if (result->type().IsPolymorphic() ||
1808 (arrayType && !arrayType->IsTkLenCompatibleWith(result->type()))) {
1809 messages.Say(
1810 "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US);
1811 } else {
1812 const characteristics::DummyDataObject *data[2]{};
1813 for (int j{0}; j < 2; ++j) {
1814 const auto &dummy{procChars->dummyArguments.at(j)};
1815 data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u);
1816 }
1817 if (!data[0] || !data[1]) {
1818 messages.Say(
1819 "OPERATION= argument of REDUCE() may not have dummy procedure arguments"_err_en_US);
1820 } else {
1821 for (int j{0}; j < 2; ++j) {
1822 if (data[j]->attrs.test(
1823 characteristics::DummyDataObject::Attr::Optional) ||
1824 data[j]->attrs.test(
1825 characteristics::DummyDataObject::Attr::Allocatable) ||
1826 data[j]->attrs.test(
1827 characteristics::DummyDataObject::Attr::Pointer) ||
1828 data[j]->type.Rank() != 0 || data[j]->type.type().IsPolymorphic() ||
1829 (arrayType &&
1830 !data[j]->type.type().IsTkCompatibleWith(*arrayType))) {
1831 messages.Say(
1832 "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
1833 }
1834 }
1835 static constexpr characteristics::DummyDataObject::Attr attrs[]{
1836 characteristics::DummyDataObject::Attr::Asynchronous,
1837 characteristics::DummyDataObject::Attr::Target,
1838 characteristics::DummyDataObject::Attr::Value,
1839 };
1840 for (std::size_t j{0}; j < sizeof attrs / sizeof *attrs; ++j) {
1841 if (data[0]->attrs.test(attrs[j]) != data[1]->attrs.test(attrs[j])) {
1842 messages.Say(
1843 "If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US);
1844 break;
1845 }
1846 }
1847 }
1848 }
1849 // When the MASK= is present and has no .TRUE. element, and there is
1850 // no IDENTITY=, it's an error.
1851 if (const auto &mask{arguments[3]}; mask && !arguments[/*identity*/ 4]) {
1852 if (const auto *expr{mask->UnwrapExpr()}) {
1853 if (const auto *logical{
1854 std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&expr->u)}) {
1855 if (common::visit(
1856 [](const auto &kindExpr) {
1857 using KindExprType = std::decay_t<decltype(kindExpr)>;
1858 using KindLogical = typename KindExprType::Result;
1859 if (const auto *c{evaluate::UnwrapConstantValue<KindLogical>(
1860 kindExpr)}) {
1861 for (const auto &element : c->values()) {
1862 if (element.IsTrue()) {
1863 return false;
1864 }
1865 }
1866 return true;
1867 }
1868 return false;
1869 },
1870 logical->u)) {
1871 messages.Say(
1872 "MASK= has no .TRUE. element, so IDENTITY= must be present"_err_en_US);
1873 }
1874 }
1875 }
1876 }
1877 }
1878
1879 // TRANSFER (16.9.193)
1880 static void CheckTransferOperandType(SemanticsContext &context,
1881 const evaluate::DynamicType &type, const char *which) {
1882 if (type.IsPolymorphic() &&
1883 context.ShouldWarn(common::UsageWarning::PolymorphicTransferArg)) {
1884 context.foldingContext().messages().Say(
1885 common::UsageWarning::PolymorphicTransferArg,
1886 "%s of TRANSFER is polymorphic"_warn_en_US, which);
1887 } else if (!type.IsUnlimitedPolymorphic() &&
1888 type.category() == TypeCategory::Derived &&
1889 context.ShouldWarn(common::UsageWarning::PointerComponentTransferArg)) {
1890 DirectComponentIterator directs{type.GetDerivedTypeSpec()};
1891 if (auto bad{std::find_if(directs.begin(), directs.end(), IsDescriptor)};
1892 bad != directs.end()) {
1893 evaluate::SayWithDeclaration(context.foldingContext().messages(), *bad,
1894 common::UsageWarning::PointerComponentTransferArg,
1895 "%s of TRANSFER contains allocatable or pointer component %s"_warn_en_US,
1896 which, bad.BuildResultDesignatorName());
1897 }
1898 }
1899 }
1900
1901 static void CheckTransfer(evaluate::ActualArguments &arguments,
1902 SemanticsContext &context, const Scope *scope) {
1903 evaluate::FoldingContext &foldingContext{context.foldingContext()};
1904 parser::ContextualMessages &messages{foldingContext.messages()};
1905 if (arguments.size() >= 2) {
1906 if (auto source{characteristics::TypeAndShape::Characterize(
1907 arguments[0], foldingContext)}) {
1908 CheckTransferOperandType(context, source->type(), "Source");
1909 if (auto mold{characteristics::TypeAndShape::Characterize(
1910 arguments[1], foldingContext)}) {
1911 CheckTransferOperandType(context, mold->type(), "Mold");
1912 if (mold->Rank() > 0 &&
1913 evaluate::ToInt64(
1914 evaluate::Fold(foldingContext,
1915 mold->MeasureElementSizeInBytes(foldingContext, false)))
1916 .value_or(1) == 0) {
1917 if (auto sourceSize{evaluate::ToInt64(evaluate::Fold(foldingContext,
1918 source->MeasureSizeInBytes(foldingContext)))}) {
1919 if (*sourceSize > 0) {
1920 messages.Say(
1921 "Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US);
1922 }
1923 } else if (context.ShouldWarn(common::UsageWarning::VoidMold)) {
1924 messages.Say(common::UsageWarning::VoidMold,
1925 "Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US);
1926 }
1927 }
1928 }
1929 }
1930 if (arguments.size() > 2) { // SIZE=
1931 if (const Symbol *
1932 whole{UnwrapWholeSymbolOrComponentDataRef(arguments[2])}) {
1933 if (IsOptional(*whole)) {
1934 messages.Say(
1935 "SIZE= argument may not be the optional dummy argument '%s'"_err_en_US,
1936 whole->name());
1937 } else if (context.ShouldWarn(
1938 common::UsageWarning::TransferSizePresence) &&
1939 IsAllocatableOrObjectPointer(whole)) {
1940 messages.Say(common::UsageWarning::TransferSizePresence,
1941 "SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
1942 }
1943 }
1944 }
1945 }
1946 }
1947
1948 static void CheckSpecificIntrinsic(const characteristics::Procedure &proc,
1949 evaluate::ActualArguments &arguments, SemanticsContext &context,
1950 const Scope *scope, const evaluate::SpecificIntrinsic &intrinsic) {
1951 if (intrinsic.name == "associated") {
1952 CheckAssociated(arguments, context, scope);
1953 } else if (intrinsic.name == "image_index") {
1954 CheckImage_Index(arguments, context.foldingContext().messages());
1955 } else if (intrinsic.name == "max" || intrinsic.name == "min") {
1956 CheckMaxMin(proc, arguments, context.foldingContext().messages());
1957 } else if (intrinsic.name == "move_alloc") {
1958 CheckMove_Alloc(arguments, context.foldingContext().messages());
1959 } else if (intrinsic.name == "present") {
1960 CheckPresent(arguments, context.foldingContext().messages());
1961 } else if (intrinsic.name == "reduce") {
1962 CheckReduce(arguments, context.foldingContext());
1963 } else if (intrinsic.name == "transfer") {
1964 CheckTransfer(arguments, context, scope);
1965 } else if (intrinsic.name == "free") {
1966 CheckFree(arguments, context.foldingContext().messages());
1967 }
1968 }
1969
1970 static parser::Messages CheckExplicitInterface(
1971 const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
1972 SemanticsContext &context, const Scope *scope,
1973 const evaluate::SpecificIntrinsic *intrinsic,
1974 bool allowActualArgumentConversions, bool extentErrors,
1975 bool ignoreImplicitVsExplicit) {
1976 evaluate::FoldingContext &foldingContext{context.foldingContext()};
1977 parser::ContextualMessages &messages{foldingContext.messages()};
1978 parser::Messages buffer;
1979 auto restorer{messages.SetMessages(buffer)};
1980 RearrangeArguments(proc, actuals, messages);
1981 if (!buffer.empty()) {
1982 return buffer;
1983 }
1984 int index{0};
1985 for (auto &actual : actuals) {
1986 const auto &dummy{proc.dummyArguments.at(index++)};
1987 if (actual) {
1988 CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic,
1989 allowActualArgumentConversions, extentErrors,
1990 ignoreImplicitVsExplicit);
1991 } else if (!dummy.IsOptional()) {
1992 if (dummy.name.empty()) {
1993 messages.Say(
1994 "Dummy argument #%d is not OPTIONAL and is not associated with "
1995 "an actual argument in this procedure reference"_err_en_US,
1996 index);
1997 } else {
1998 messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "
1999 "associated with an actual argument in this procedure "
2000 "reference"_err_en_US,
2001 dummy.name, index);
2002 }
2003 }
2004 }
2005 if (proc.IsElemental() && !buffer.AnyFatalError()) {
2006 CheckElementalConformance(messages, proc, actuals, foldingContext);
2007 }
2008 if (intrinsic) {
2009 CheckSpecificIntrinsic(proc, actuals, context, scope, *intrinsic);
2010 }
2011 return buffer;
2012 }
2013
2014 bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
2015 evaluate::ActualArguments &actuals, SemanticsContext &context,
2016 bool allowActualArgumentConversions) {
2017 return proc.HasExplicitInterface() &&
2018 !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr,
2019 allowActualArgumentConversions, /*extentErrors=*/false,
2020 /*ignoreImplicitVsExplicit=*/false)
2021 .AnyFatalError();
2022 }
2023
2024 bool CheckArgumentIsConstantExprInRange(
2025 const evaluate::ActualArguments &actuals, int index, int lowerBound,
2026 int upperBound, parser::ContextualMessages &messages) {
2027 CHECK(index >= 0 && static_cast<unsigned>(index) < actuals.size());
2028
2029 const std::optional<evaluate::ActualArgument> &argOptional{actuals[index]};
2030 if (!argOptional) {
2031 DIE("Actual argument should have value");
2032 return false;
2033 }
2034
2035 const evaluate::ActualArgument &arg{argOptional.value()};
2036 const evaluate::Expr<evaluate::SomeType> *argExpr{arg.UnwrapExpr()};
2037 CHECK(argExpr != nullptr);
2038
2039 if (!IsConstantExpr(*argExpr)) {
2040 messages.Say("Actual argument #%d must be a constant expression"_err_en_US,
2041 index + 1);
2042 return false;
2043 }
2044
2045 // This does not imply that the kind of the argument is 8. The kind
2046 // for the intrinsic's argument should have been check prior. This is just
2047 // a conversion so that we can read the constant value.
2048 auto scalarValue{evaluate::ToInt64(argExpr)};
2049 CHECK(scalarValue.has_value());
2050
2051 if (*scalarValue < lowerBound || *scalarValue > upperBound) {
2052 messages.Say(
2053 "Argument #%d must be a constant expression in range %d to %d"_err_en_US,
2054 index + 1, lowerBound, upperBound);
2055 return false;
2056 }
2057 return true;
2058 }
2059
2060 bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific,
2061 const evaluate::ActualArguments &actuals,
2062 evaluate::FoldingContext &context) {
2063 parser::ContextualMessages &messages{context.messages()};
2064
2065 if (specific.name() == "__ppc_mtfsf") {
2066 return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages);
2067 }
2068 if (specific.name() == "__ppc_mtfsfi") {
2069 return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages) &&
2070 CheckArgumentIsConstantExprInRange(actuals, 1, 0, 15, messages);
2071 }
2072 if (specific.name().ToString().compare(0, 14, "__ppc_vec_sld_") == 0) {
2073 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 15, messages);
2074 }
2075 if (specific.name().ToString().compare(0, 15, "__ppc_vec_sldw_") == 0) {
2076 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages);
2077 }
2078 if (specific.name().ToString().compare(0, 14, "__ppc_vec_ctf_") == 0) {
2079 return CheckArgumentIsConstantExprInRange(actuals, 1, 0, 31, messages);
2080 }
2081 if (specific.name().ToString().compare(0, 16, "__ppc_vec_permi_") == 0) {
2082 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages);
2083 }
2084 if (specific.name().ToString().compare(0, 21, "__ppc_vec_splat_s32__") == 0) {
2085 return CheckArgumentIsConstantExprInRange(actuals, 0, -16, 15, messages);
2086 }
2087 if (specific.name().ToString().compare(0, 16, "__ppc_vec_splat_") == 0) {
2088 // The value of arg2 in vec_splat must be a constant expression that is
2089 // greater than or equal to 0, and less than the number of elements in arg1.
2090 auto *expr{actuals[0].value().UnwrapExpr()};
2091 auto type{characteristics::TypeAndShape::Characterize(*expr, context)};
2092 assert(type && "unknown type");
2093 const auto *derived{evaluate::GetDerivedTypeSpec(type.value().type())};
2094 if (derived && derived->IsVectorType()) {
2095 for (const auto &pair : derived->parameters()) {
2096 if (pair.first == "element_kind") {
2097 auto vecElemKind{Fortran::evaluate::ToInt64(pair.second.GetExplicit())
2098 .value_or(0)};
2099 auto numElem{vecElemKind == 0 ? 0 : (16 / vecElemKind)};
2100 return CheckArgumentIsConstantExprInRange(
2101 actuals, 1, 0, numElem - 1, messages);
2102 }
2103 }
2104 } else
2105 assert(false && "vector type is expected");
2106 }
2107 return false;
2108 }
2109
2110 bool CheckWindowsIntrinsic(
2111 const Symbol &intrinsic, evaluate::FoldingContext &foldingContext) {
2112 parser::ContextualMessages &messages{foldingContext.messages()};
2113 // TODO: there are other intrinsics that are unsupported on Windows that
2114 // should be added here.
2115 if (intrinsic.name() == "getuid") {
2116 messages.Say(
2117 "User IDs do not exist on Windows. This function will always return 1"_warn_en_US);
2118 }
2119 if (intrinsic.name() == "getgid") {
2120 messages.Say(
2121 "Group IDs do not exist on Windows. This function will always return 1"_warn_en_US);
2122 }
2123 return true;
2124 }
2125
2126 bool CheckArguments(const characteristics::Procedure &proc,
2127 evaluate::ActualArguments &actuals, SemanticsContext &context,
2128 const Scope &scope, bool treatingExternalAsImplicit,
2129 bool ignoreImplicitVsExplicit,
2130 const evaluate::SpecificIntrinsic *intrinsic) {
2131 bool explicitInterface{proc.HasExplicitInterface()};
2132 evaluate::FoldingContext foldingContext{context.foldingContext()};
2133 parser::ContextualMessages &messages{foldingContext.messages()};
2134 bool allowArgumentConversions{true};
2135 if (!explicitInterface || treatingExternalAsImplicit) {
2136 parser::Messages buffer;
2137 {
2138 auto restorer{messages.SetMessages(buffer)};
2139 for (auto &actual : actuals) {
2140 if (actual) {
2141 CheckImplicitInterfaceArg(*actual, messages, context);
2142 }
2143 }
2144 }
2145 if (!buffer.empty()) {
2146 if (auto *msgs{messages.messages()}) {
2147 msgs->Annex(std::move(buffer));
2148 }
2149 return false; // don't pile on
2150 }
2151 allowArgumentConversions = false;
2152 }
2153 if (explicitInterface) {
2154 auto buffer{CheckExplicitInterface(proc, actuals, context, &scope,
2155 intrinsic, allowArgumentConversions,
2156 /*extentErrors=*/true, ignoreImplicitVsExplicit)};
2157 if (!buffer.empty()) {
2158 if (treatingExternalAsImplicit) {
2159 if (context.ShouldWarn(
2160 common::UsageWarning::KnownBadImplicitInterface)) {
2161 if (auto *msg{messages.Say(
2162 common::UsageWarning::KnownBadImplicitInterface,
2163 "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
2164 buffer.AttachTo(*msg, parser::Severity::Because);
2165 }
2166 } else {
2167 buffer.clear();
2168 }
2169 }
2170 if (auto *msgs{messages.messages()}) {
2171 msgs->Annex(std::move(buffer));
2172 }
2173 return false;
2174 }
2175 }
2176 return true;
2177 }
2178 } // namespace Fortran::semantics
LLVM monorepo