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