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