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