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 if (!common::AreCompatibleCUDADataAttrs(dummyDataAttr, actualDataAttr, 980 dummy.ignoreTKR, 981 /*allowUnifiedMatchingRule=*/true, &context.languageFeatures())) { 982 auto toStr{[](std::optional<common::CUDADataAttr> x) { 983 return x ? "ATTRIBUTES("s + 984 parser::ToUpperCaseLetters(common::EnumToString(*x)) + ")"s 985 : "no CUDA data attribute"s; 986 }}; 987 messages.Say( 988 "%s has %s but its associated actual argument has %s"_err_en_US, 989 dummyName, toStr(dummyDataAttr), toStr(actualDataAttr)); 990 } 991 } 992 993 // Warning for breaking F'2023 change with character allocatables 994 if (intrinsic && dummy.intent != common::Intent::In) { 995 WarnOnDeferredLengthCharacterScalar( 996 context, &actual, messages.at(), dummyName.c_str()); 997 } 998 999 // %VAL() and %REF() checking for explicit interface 1000 if ((arg.isPercentRef() || arg.isPercentVal()) && 1001 dummy.IsPassedByDescriptor(procedure.IsBindC())) { 1002 messages.Say( 1003 "%%VAL or %%REF are not allowed for %s that must be passed by means of a descriptor"_err_en_US, 1004 dummyName); 1005 } 1006 if (arg.isPercentVal() && 1007 (!actualType.type().IsLengthlessIntrinsicType() || 1008 actualType.Rank() != 0)) { 1009 messages.Say( 1010 "%VAL argument must be a scalar numeric or logical expression"_err_en_US); 1011 } 1012 } 1013 1014 static void CheckProcedureArg(evaluate::ActualArgument &arg, 1015 const characteristics::Procedure &proc, 1016 const characteristics::DummyProcedure &dummy, const std::string &dummyName, 1017 SemanticsContext &context, bool ignoreImplicitVsExplicit) { 1018 evaluate::FoldingContext &foldingContext{context.foldingContext()}; 1019 parser::ContextualMessages &messages{foldingContext.messages()}; 1020 auto restorer{ 1021 messages.SetLocation(arg.sourceLocation().value_or(messages.at()))}; 1022 const characteristics::Procedure &interface { dummy.procedure.value() }; 1023 if (const auto *expr{arg.UnwrapExpr()}) { 1024 bool dummyIsPointer{ 1025 dummy.attrs.test(characteristics::DummyProcedure::Attr::Pointer)}; 1026 const auto *argProcDesignator{ 1027 std::get_if<evaluate::ProcedureDesignator>(&expr->u)}; 1028 const auto *argProcSymbol{ 1029 argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}; 1030 if (argProcSymbol) { 1031 if (const auto *subp{ 1032 argProcSymbol->GetUltimate().detailsIf<SubprogramDetails>()}) { 1033 if (subp->stmtFunction()) { 1034 evaluate::SayWithDeclaration(messages, *argProcSymbol, 1035 "Statement function '%s' may not be passed as an actual argument"_err_en_US, 1036 argProcSymbol->name()); 1037 return; 1038 } 1039 } else if (argProcSymbol->has<ProcBindingDetails>()) { 1040 if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure)) { 1041 evaluate::SayWithDeclaration(messages, *argProcSymbol, 1042 "Procedure binding '%s' passed as an actual argument"_err_en_US, 1043 argProcSymbol->name()); 1044 } else if (context.ShouldWarn( 1045 common::LanguageFeature::BindingAsProcedure)) { 1046 evaluate::SayWithDeclaration(messages, *argProcSymbol, 1047 common::LanguageFeature::BindingAsProcedure, 1048 "Procedure binding '%s' passed as an actual argument"_port_en_US, 1049 argProcSymbol->name()); 1050 } 1051 } 1052 } 1053 if (auto argChars{characteristics::DummyArgument::FromActual( 1054 "actual argument", *expr, foldingContext, 1055 /*forImplicitInterface=*/true)}) { 1056 if (!argChars->IsTypelessIntrinsicDummy()) { 1057 if (auto *argProc{ 1058 std::get_if<characteristics::DummyProcedure>(&argChars->u)}) { 1059 characteristics::Procedure &argInterface{argProc->procedure.value()}; 1060 argInterface.attrs.reset( 1061 characteristics::Procedure::Attr::NullPointer); 1062 if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) { 1063 // It's ok to pass ELEMENTAL unrestricted intrinsic functions. 1064 argInterface.attrs.reset( 1065 characteristics::Procedure::Attr::Elemental); 1066 } else if (argInterface.attrs.test( 1067 characteristics::Procedure::Attr::Elemental)) { 1068 if (argProcSymbol) { // C1533 1069 evaluate::SayWithDeclaration(messages, *argProcSymbol, 1070 "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US, 1071 argProcSymbol->name()); 1072 return; // avoid piling on with checks below 1073 } else { 1074 argInterface.attrs.reset( 1075 characteristics::Procedure::Attr::NullPointer); 1076 } 1077 } 1078 if (interface.HasExplicitInterface()) { 1079 std::string whyNot; 1080 std::optional<std::string> warning; 1081 if (!interface.IsCompatibleWith(argInterface, 1082 ignoreImplicitVsExplicit, &whyNot, 1083 /*specificIntrinsic=*/nullptr, &warning)) { 1084 // 15.5.2.9(1): Explicit interfaces must match 1085 if (argInterface.HasExplicitInterface()) { 1086 messages.Say( 1087 "Actual procedure argument has interface incompatible with %s: %s"_err_en_US, 1088 dummyName, whyNot); 1089 return; 1090 } else if (proc.IsPure()) { 1091 messages.Say( 1092 "Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US, 1093 dummyName); 1094 } else if (context.ShouldWarn( 1095 common::UsageWarning::ImplicitInterfaceActual)) { 1096 messages.Say(common::UsageWarning::ImplicitInterfaceActual, 1097 "Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US, 1098 dummyName); 1099 } 1100 } else if (warning && 1101 context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) { 1102 messages.Say(common::UsageWarning::ProcDummyArgShapes, 1103 "Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US, 1104 dummyName, std::move(*warning)); 1105 } 1106 } else { // 15.5.2.9(2,3) 1107 if (interface.IsSubroutine() && argInterface.IsFunction()) { 1108 messages.Say( 1109 "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US, 1110 dummyName); 1111 } else if (interface.IsFunction()) { 1112 if (argInterface.IsFunction()) { 1113 std::string whyNot; 1114 if (!interface.functionResult->IsCompatibleWith( 1115 *argInterface.functionResult, &whyNot)) { 1116 messages.Say( 1117 "Actual argument function associated with procedure %s is not compatible: %s"_err_en_US, 1118 dummyName, whyNot); 1119 } 1120 } else if (argInterface.IsSubroutine()) { 1121 messages.Say( 1122 "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US, 1123 dummyName); 1124 } 1125 } 1126 } 1127 } else { 1128 messages.Say( 1129 "Actual argument associated with procedure %s is not a procedure"_err_en_US, 1130 dummyName); 1131 } 1132 } else if (IsNullPointer(*expr)) { 1133 if (!dummyIsPointer && 1134 !dummy.attrs.test( 1135 characteristics::DummyProcedure::Attr::Optional)) { 1136 messages.Say( 1137 "Actual argument associated with procedure %s is a null pointer"_err_en_US, 1138 dummyName); 1139 } 1140 } else { 1141 messages.Say( 1142 "Actual argument associated with procedure %s is typeless"_err_en_US, 1143 dummyName); 1144 } 1145 } 1146 if (dummyIsPointer && dummy.intent != common::Intent::In) { 1147 const Symbol *last{GetLastSymbol(*expr)}; 1148 if (last && IsProcedurePointer(*last)) { 1149 if (dummy.intent != common::Intent::Default && 1150 IsIntentIn(last->GetUltimate())) { // 19.6.8 1151 messages.Say( 1152 "Actual argument associated with procedure pointer %s may not be INTENT(IN)"_err_en_US, 1153 dummyName); 1154 } 1155 } else if (!(dummy.intent == common::Intent::Default && 1156 IsNullProcedurePointer(*expr))) { 1157 // 15.5.2.9(5) -- dummy procedure POINTER 1158 // Interface compatibility has already been checked above 1159 messages.Say( 1160 "Actual argument associated with procedure pointer %s must be a pointer unless INTENT(IN)"_err_en_US, 1161 dummyName); 1162 } 1163 } 1164 } else { 1165 messages.Say( 1166 "Assumed-type argument may not be forwarded as procedure %s"_err_en_US, 1167 dummyName); 1168 } 1169 } 1170 1171 // Allow BOZ literal actual arguments when they can be converted to a known 1172 // dummy argument type 1173 static void ConvertBOZLiteralArg( 1174 evaluate::ActualArgument &arg, const evaluate::DynamicType &type) { 1175 if (auto *expr{arg.UnwrapExpr()}) { 1176 if (IsBOZLiteral(*expr)) { 1177 if (auto converted{evaluate::ConvertToType(type, SomeExpr{*expr})}) { 1178 arg = std::move(*converted); 1179 } 1180 } 1181 } 1182 } 1183 1184 static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, 1185 const characteristics::DummyArgument &dummy, 1186 const characteristics::Procedure &proc, SemanticsContext &context, 1187 const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, 1188 bool allowActualArgumentConversions, bool extentErrors, 1189 bool ignoreImplicitVsExplicit) { 1190 evaluate::FoldingContext &foldingContext{context.foldingContext()}; 1191 auto &messages{foldingContext.messages()}; 1192 std::string dummyName{"dummy argument"}; 1193 if (!dummy.name.empty()) { 1194 dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='"; 1195 } 1196 auto restorer{ 1197 messages.SetLocation(arg.sourceLocation().value_or(messages.at()))}; 1198 auto CheckActualArgForLabel = [&](evaluate::ActualArgument &arg) { 1199 if (arg.isAlternateReturn()) { 1200 messages.Say( 1201 "Alternate return label '%d' cannot be associated with %s"_err_en_US, 1202 arg.GetLabel(), dummyName); 1203 return false; 1204 } else { 1205 return true; 1206 } 1207 }; 1208 common::visit( 1209 common::visitors{ 1210 [&](const characteristics::DummyDataObject &object) { 1211 if (CheckActualArgForLabel(arg)) { 1212 ConvertBOZLiteralArg(arg, object.type.type()); 1213 if (auto *expr{arg.UnwrapExpr()}) { 1214 if (auto type{characteristics::TypeAndShape::Characterize( 1215 *expr, foldingContext)}) { 1216 arg.set_dummyIntent(object.intent); 1217 bool isElemental{ 1218 object.type.Rank() == 0 && proc.IsElemental()}; 1219 CheckExplicitDataArg(object, dummyName, *expr, *type, 1220 isElemental, context, foldingContext, scope, intrinsic, 1221 allowActualArgumentConversions, extentErrors, proc, arg); 1222 } else if (object.type.type().IsTypelessIntrinsicArgument() && 1223 IsBOZLiteral(*expr)) { 1224 // ok 1225 } else if (object.type.type().IsTypelessIntrinsicArgument() && 1226 evaluate::IsNullObjectPointer(*expr)) { 1227 // ok, ASSOCIATED(NULL(without MOLD=)) 1228 } else if (object.type.attrs().test(characteristics:: 1229 TypeAndShape::Attr::AssumedRank) && 1230 evaluate::IsNullObjectPointer(*expr) && 1231 (object.attrs.test( 1232 characteristics::DummyDataObject::Attr::Allocatable) || 1233 object.attrs.test( 1234 characteristics::DummyDataObject::Attr::Pointer) || 1235 !object.attrs.test(characteristics::DummyDataObject:: 1236 Attr::Optional))) { 1237 messages.Say( 1238 "NULL() without MOLD= must not be associated with an assumed-rank dummy argument that is ALLOCATABLE, POINTER, or non-OPTIONAL"_err_en_US); 1239 } else if ((object.attrs.test(characteristics::DummyDataObject:: 1240 Attr::Pointer) || 1241 object.attrs.test(characteristics:: 1242 DummyDataObject::Attr::Optional)) && 1243 evaluate::IsNullObjectPointer(*expr)) { 1244 // FOO(NULL(without MOLD=)) 1245 if (object.type.type().IsAssumedLengthCharacter()) { 1246 messages.Say( 1247 "Actual argument associated with %s is a NULL() pointer without a MOLD= to provide a character length"_err_en_US, 1248 dummyName); 1249 } else if (const DerivedTypeSpec * 1250 derived{GetDerivedTypeSpec(object.type.type())}) { 1251 for (const auto &[pName, pValue] : derived->parameters()) { 1252 if (pValue.isAssumed()) { 1253 messages.Say( 1254 "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, 1255 dummyName, pName.ToString()); 1256 break; 1257 } 1258 } 1259 } 1260 } else if (object.attrs.test(characteristics::DummyDataObject:: 1261 Attr::Allocatable) && 1262 evaluate::IsNullPointer(*expr)) { 1263 if (object.intent == common::Intent::In) { 1264 // Extension (Intel, NAG, XLF); see CheckExplicitDataArg. 1265 if (context.ShouldWarn(common::LanguageFeature:: 1266 NullActualForAllocatable)) { 1267 messages.Say( 1268 common::LanguageFeature::NullActualForAllocatable, 1269 "Allocatable %s is associated with NULL()"_port_en_US, 1270 dummyName); 1271 } 1272 } else { 1273 messages.Say( 1274 "NULL() actual argument '%s' may not be associated with allocatable %s without INTENT(IN)"_err_en_US, 1275 expr->AsFortran(), dummyName); 1276 } 1277 } else { 1278 messages.Say( 1279 "Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US, 1280 expr->AsFortran(), dummyName); 1281 } 1282 } else { 1283 const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())}; 1284 if (!object.type.type().IsAssumedType()) { 1285 messages.Say( 1286 "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US, 1287 assumed.name(), dummyName); 1288 } else if (object.type.attrs().test(characteristics:: 1289 TypeAndShape::Attr::AssumedRank) && 1290 !IsAssumedShape(assumed) && 1291 !evaluate::IsAssumedRank(assumed)) { 1292 messages.Say( // C711 1293 "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US, 1294 assumed.name(), dummyName); 1295 } 1296 } 1297 } 1298 }, 1299 [&](const characteristics::DummyProcedure &dummy) { 1300 if (CheckActualArgForLabel(arg)) { 1301 CheckProcedureArg(arg, proc, dummy, dummyName, context, 1302 ignoreImplicitVsExplicit); 1303 } 1304 }, 1305 [&](const characteristics::AlternateReturn &) { 1306 // All semantic checking is done elsewhere 1307 }, 1308 }, 1309 dummy.u); 1310 } 1311 1312 static void RearrangeArguments(const characteristics::Procedure &proc, 1313 evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) { 1314 CHECK(proc.HasExplicitInterface()); 1315 if (actuals.size() < proc.dummyArguments.size()) { 1316 actuals.resize(proc.dummyArguments.size()); 1317 } else if (actuals.size() > proc.dummyArguments.size()) { 1318 messages.Say( 1319 "Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US, 1320 actuals.size(), proc.dummyArguments.size()); 1321 } 1322 std::map<std::string, evaluate::ActualArgument> kwArgs; 1323 bool anyKeyword{false}; 1324 int which{1}; 1325 for (auto &x : actuals) { 1326 if (!x) { 1327 } else if (x->keyword()) { 1328 auto emplaced{ 1329 kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))}; 1330 if (!emplaced.second) { 1331 messages.Say(*x->keyword(), 1332 "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US, 1333 *x->keyword()); 1334 } 1335 x.reset(); 1336 anyKeyword = true; 1337 } else if (anyKeyword) { 1338 messages.Say(x ? x->sourceLocation() : std::nullopt, 1339 "Actual argument #%d without a keyword may not follow any actual argument with a keyword"_err_en_US, 1340 which); 1341 } 1342 ++which; 1343 } 1344 if (!kwArgs.empty()) { 1345 int index{0}; 1346 for (const auto &dummy : proc.dummyArguments) { 1347 if (!dummy.name.empty()) { 1348 auto iter{kwArgs.find(dummy.name)}; 1349 if (iter != kwArgs.end()) { 1350 evaluate::ActualArgument &x{iter->second}; 1351 if (actuals[index]) { 1352 messages.Say(*x.keyword(), 1353 "Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US, 1354 *x.keyword(), index + 1); 1355 } else { 1356 actuals[index] = std::move(x); 1357 } 1358 kwArgs.erase(iter); 1359 } 1360 } 1361 ++index; 1362 } 1363 for (auto &bad : kwArgs) { 1364 evaluate::ActualArgument &x{bad.second}; 1365 messages.Say(*x.keyword(), 1366 "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US, 1367 *x.keyword()); 1368 } 1369 } 1370 } 1371 1372 // 15.8.1(3) -- In a reference to an elemental procedure, if any argument is an 1373 // array, each actual argument that corresponds to an INTENT(OUT) or 1374 // INTENT(INOUT) dummy argument shall be an array. The actual argument to an 1375 // ELEMENTAL procedure must conform. 1376 static bool CheckElementalConformance(parser::ContextualMessages &messages, 1377 const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, 1378 evaluate::FoldingContext &context) { 1379 std::optional<evaluate::Shape> shape; 1380 std::string shapeName; 1381 int index{0}; 1382 bool hasArrayArg{false}; 1383 for (const auto &arg : actuals) { 1384 if (arg && !arg->isAlternateReturn() && arg->Rank() > 0) { 1385 hasArrayArg = true; 1386 break; 1387 } 1388 } 1389 for (const auto &arg : actuals) { 1390 const auto &dummy{proc.dummyArguments.at(index++)}; 1391 if (arg) { 1392 if (const auto *expr{arg->UnwrapExpr()}) { 1393 if (const auto *wholeSymbol{evaluate::UnwrapWholeSymbolDataRef(arg)}) { 1394 wholeSymbol = &ResolveAssociations(*wholeSymbol); 1395 if (IsAssumedSizeArray(*wholeSymbol)) { 1396 evaluate::SayWithDeclaration(messages, *wholeSymbol, 1397 "Whole assumed-size array '%s' may not be used as an argument to an elemental procedure"_err_en_US, 1398 wholeSymbol->name()); 1399 } 1400 } 1401 if (auto argShape{evaluate::GetShape(context, *expr)}) { 1402 if (GetRank(*argShape) > 0) { 1403 std::string argName{"actual argument ("s + expr->AsFortran() + 1404 ") corresponding to dummy argument #" + std::to_string(index) + 1405 " ('" + dummy.name + "')"}; 1406 if (shape) { 1407 auto tristate{evaluate::CheckConformance(messages, *shape, 1408 *argShape, evaluate::CheckConformanceFlags::None, 1409 shapeName.c_str(), argName.c_str())}; 1410 if (tristate && !*tristate) { 1411 return false; 1412 } 1413 } else { 1414 shape = std::move(argShape); 1415 shapeName = argName; 1416 } 1417 } else if ((dummy.GetIntent() == common::Intent::Out || 1418 dummy.GetIntent() == common::Intent::InOut) && 1419 hasArrayArg) { 1420 messages.Say( 1421 "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, 1422 expr->AsFortran()); 1423 } 1424 } 1425 } 1426 } 1427 } 1428 return true; 1429 } 1430 1431 // ASSOCIATED (16.9.16) 1432 static void CheckAssociated(evaluate::ActualArguments &arguments, 1433 SemanticsContext &semanticsContext, const Scope *scope) { 1434 evaluate::FoldingContext &foldingContext{semanticsContext.foldingContext()}; 1435 parser::ContextualMessages &messages{foldingContext.messages()}; 1436 bool ok{true}; 1437 if (arguments.size() < 2) { 1438 return; 1439 } 1440 if (const auto &pointerArg{arguments[0]}) { 1441 if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) { 1442 if (!IsPointer(*pointerExpr)) { 1443 messages.Say(pointerArg->sourceLocation(), 1444 "POINTER= argument of ASSOCIATED() must be a pointer"_err_en_US); 1445 return; 1446 } 1447 if (const auto &targetArg{arguments[1]}) { 1448 // The standard requires that the TARGET= argument, when present, 1449 // be a valid RHS for a pointer assignment that has the POINTER= 1450 // argument as its LHS. Some popular compilers misinterpret this 1451 // requirement more strongly than necessary, and actually validate 1452 // the POINTER= argument as if it were serving as the LHS of a pointer 1453 // assignment. This, perhaps unintentionally, excludes function 1454 // results, including NULL(), from being used there, as well as 1455 // INTENT(IN) dummy pointers. Detect these conditions and emit 1456 // portability warnings. 1457 if (semanticsContext.ShouldWarn(common::UsageWarning::Portability)) { 1458 if (!evaluate::ExtractDataRef(*pointerExpr) && 1459 !evaluate::IsProcedurePointer(*pointerExpr)) { 1460 messages.Say(common::UsageWarning::Portability, 1461 pointerArg->sourceLocation(), 1462 "POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer"_port_en_US); 1463 } else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) { 1464 if (auto whyNot{WhyNotDefinable( 1465 pointerArg->sourceLocation().value_or(messages.at()), 1466 *scope, 1467 DefinabilityFlags{DefinabilityFlag::PointerDefinition, 1468 DefinabilityFlag::DoNotNoteDefinition}, 1469 *pointerExpr)}) { 1470 if (whyNot->IsFatal()) { 1471 if (auto *msg{messages.Say(common::UsageWarning::Portability, 1472 pointerArg->sourceLocation(), 1473 "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)}) { 1474 msg->Attach(std::move( 1475 whyNot->set_severity(parser::Severity::Because))); 1476 } 1477 } else { 1478 messages.Say(std::move(*whyNot)); 1479 } 1480 } 1481 } 1482 } 1483 if (const auto *targetExpr{targetArg->UnwrapExpr()}) { 1484 if (IsProcedurePointer(*pointerExpr) && 1485 !IsBareNullPointer(pointerExpr)) { // POINTER= is a procedure 1486 if (auto pointerProc{characteristics::Procedure::Characterize( 1487 *pointerExpr, foldingContext)}) { 1488 if (IsBareNullPointer(targetExpr)) { 1489 } else if (IsProcedurePointerTarget(*targetExpr)) { 1490 if (auto targetProc{characteristics::Procedure::Characterize( 1491 *targetExpr, foldingContext)}) { 1492 bool isCall{!!UnwrapProcedureRef(*targetExpr)}; 1493 std::string whyNot; 1494 std::optional<std::string> warning; 1495 const auto *targetProcDesignator{ 1496 evaluate::UnwrapExpr<evaluate::ProcedureDesignator>( 1497 *targetExpr)}; 1498 const evaluate::SpecificIntrinsic *specificIntrinsic{ 1499 targetProcDesignator 1500 ? targetProcDesignator->GetSpecificIntrinsic() 1501 : nullptr}; 1502 std::optional<parser::MessageFixedText> msg{ 1503 CheckProcCompatibility(isCall, pointerProc, &*targetProc, 1504 specificIntrinsic, whyNot, warning, 1505 /*ignoreImplicitVsExplicit=*/false)}; 1506 std::optional<common::UsageWarning> whichWarning; 1507 if (!msg && warning && 1508 semanticsContext.ShouldWarn( 1509 common::UsageWarning::ProcDummyArgShapes)) { 1510 whichWarning = common::UsageWarning::ProcDummyArgShapes; 1511 msg = 1512 "Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US; 1513 whyNot = std::move(*warning); 1514 } else if (msg && !msg->IsFatal() && 1515 semanticsContext.ShouldWarn( 1516 common::UsageWarning::ProcPointerCompatibility)) { 1517 whichWarning = 1518 common::UsageWarning::ProcPointerCompatibility; 1519 } 1520 if (msg && (msg->IsFatal() || whichWarning)) { 1521 if (auto *said{messages.Say(std::move(*msg), 1522 "pointer '" + pointerExpr->AsFortran() + "'", 1523 targetExpr->AsFortran(), whyNot)}; 1524 said && whichWarning) { 1525 said->set_usageWarning(*whichWarning); 1526 } 1527 } 1528 } 1529 } else if (!IsNullProcedurePointer(*targetExpr)) { 1530 messages.Say( 1531 "POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US, 1532 pointerExpr->AsFortran(), targetExpr->AsFortran()); 1533 } 1534 } 1535 } else if (IsVariable(*targetExpr) || IsNullPointer(*targetExpr)) { 1536 // Object pointer and target 1537 if (ExtractDataRef(*targetExpr)) { 1538 if (SymbolVector symbols{GetSymbolVector(*targetExpr)}; 1539 !evaluate::GetLastTarget(symbols)) { 1540 parser::Message *msg{messages.Say(targetArg->sourceLocation(), 1541 "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US, 1542 targetExpr->AsFortran())}; 1543 for (SymbolRef ref : symbols) { 1544 msg = evaluate::AttachDeclaration(msg, *ref); 1545 } 1546 } else if (HasVectorSubscript(*targetExpr) || 1547 ExtractCoarrayRef(*targetExpr)) { 1548 messages.Say(targetArg->sourceLocation(), 1549 "TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US, 1550 targetExpr->AsFortran()); 1551 } 1552 } 1553 if (const auto pointerType{pointerArg->GetType()}) { 1554 if (const auto targetType{targetArg->GetType()}) { 1555 ok = pointerType->IsTkCompatibleWith(*targetType); 1556 } 1557 } 1558 } else { 1559 messages.Say( 1560 "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US, 1561 pointerExpr->AsFortran(), targetExpr->AsFortran()); 1562 } 1563 if (!IsAssumedRank(*pointerExpr)) { 1564 if (IsAssumedRank(*targetExpr)) { 1565 messages.Say( 1566 "TARGET= argument '%s' may not be assumed-rank when POINTER= argument is not"_err_en_US, 1567 pointerExpr->AsFortran()); 1568 } else if (pointerExpr->Rank() != targetExpr->Rank()) { 1569 messages.Say( 1570 "POINTER= argument and TARGET= argument have incompatible ranks %d and %d"_err_en_US, 1571 pointerExpr->Rank(), targetExpr->Rank()); 1572 } 1573 } 1574 } 1575 } 1576 } 1577 } else { 1578 // No arguments to ASSOCIATED() 1579 ok = false; 1580 } 1581 if (!ok) { 1582 messages.Say( 1583 "Arguments of ASSOCIATED() must be a pointer and an optional valid target"_err_en_US); 1584 } 1585 } 1586 1587 // IMAGE_INDEX (F'2023 16.9.107) 1588 static void CheckImage_Index(evaluate::ActualArguments &arguments, 1589 parser::ContextualMessages &messages) { 1590 if (arguments[1] && arguments[0]) { 1591 if (const auto subArrShape{ 1592 evaluate::GetShape(arguments[1]->UnwrapExpr())}) { 1593 if (const auto *coarrayArgSymbol{UnwrapWholeSymbolOrComponentDataRef( 1594 arguments[0]->UnwrapExpr())}) { 1595 const auto coarrayArgCorank = coarrayArgSymbol->Corank(); 1596 if (const auto subArrSize = evaluate::ToInt64(*subArrShape->front())) { 1597 if (subArrSize != coarrayArgCorank) { 1598 messages.Say(arguments[1]->sourceLocation(), 1599 "The size of 'SUB=' (%jd) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (%d)"_err_en_US, 1600 static_cast<std::int64_t>(*subArrSize), coarrayArgCorank); 1601 } 1602 } 1603 } 1604 } 1605 } 1606 } 1607 1608 // Ensure that any optional argument that might be absent at run time 1609 // does not require data conversion. 1610 static void CheckMaxMin(const characteristics::Procedure &proc, 1611 evaluate::ActualArguments &arguments, 1612 parser::ContextualMessages &messages) { 1613 if (proc.functionResult) { 1614 if (const auto *typeAndShape{proc.functionResult->GetTypeAndShape()}) { 1615 for (std::size_t j{2}; j < arguments.size(); ++j) { 1616 if (arguments[j]) { 1617 if (const auto *expr{arguments[j]->UnwrapExpr()}; 1618 expr && evaluate::MayBePassedAsAbsentOptional(*expr)) { 1619 if (auto thisType{expr->GetType()}) { 1620 if (thisType->category() == TypeCategory::Character && 1621 typeAndShape->type().category() == TypeCategory::Character && 1622 thisType->kind() == typeAndShape->type().kind()) { 1623 // don't care about lengths 1624 } else if (*thisType != typeAndShape->type()) { 1625 messages.Say(arguments[j]->sourceLocation(), 1626 "An actual argument to MAX/MIN requiring data conversion may not be OPTIONAL, POINTER, or ALLOCATABLE"_err_en_US); 1627 } 1628 } 1629 } 1630 } 1631 } 1632 } 1633 } 1634 } 1635 1636 static void CheckFree(evaluate::ActualArguments &arguments, 1637 parser::ContextualMessages &messages) { 1638 if (arguments.size() != 1) { 1639 messages.Say("FREE expects a single argument"_err_en_US); 1640 } 1641 auto arg = arguments[0]; 1642 if (const Symbol * symbol{evaluate::UnwrapWholeSymbolDataRef(arg)}; 1643 !symbol || !symbol->test(Symbol::Flag::CrayPointer)) { 1644 messages.Say("FREE should only be used with Cray pointers"_warn_en_US); 1645 } 1646 } 1647 1648 // MOVE_ALLOC (F'2023 16.9.147) 1649 static void CheckMove_Alloc(evaluate::ActualArguments &arguments, 1650 parser::ContextualMessages &messages) { 1651 if (arguments.size() >= 1) { 1652 evaluate::CheckForCoindexedObject( 1653 messages, arguments[0], "move_alloc", "from"); 1654 } 1655 if (arguments.size() >= 2) { 1656 evaluate::CheckForCoindexedObject( 1657 messages, arguments[1], "move_alloc", "to"); 1658 } 1659 if (arguments.size() >= 3) { 1660 evaluate::CheckForCoindexedObject( 1661 messages, arguments[2], "move_alloc", "stat"); 1662 } 1663 if (arguments.size() >= 4) { 1664 evaluate::CheckForCoindexedObject( 1665 messages, arguments[3], "move_alloc", "errmsg"); 1666 } 1667 if (arguments.size() >= 2 && arguments[0] && arguments[1]) { 1668 for (int j{0}; j < 2; ++j) { 1669 if (const Symbol * 1670 whole{UnwrapWholeSymbolOrComponentDataRef(arguments[j])}; 1671 !whole || !IsAllocatable(whole->GetUltimate())) { 1672 messages.Say(*arguments[j]->sourceLocation(), 1673 "Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US, j + 1); 1674 } 1675 } 1676 auto type0{arguments[0]->GetType()}; 1677 auto type1{arguments[1]->GetType()}; 1678 if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) { 1679 messages.Say(arguments[1]->sourceLocation(), 1680 "When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US); 1681 } 1682 } 1683 } 1684 1685 // PRESENT (F'2023 16.9.163) 1686 static void CheckPresent(evaluate::ActualArguments &arguments, 1687 parser::ContextualMessages &messages) { 1688 if (arguments.size() == 1) { 1689 if (const auto &arg{arguments[0]}; arg) { 1690 const Symbol *symbol{nullptr}; 1691 if (const auto *expr{arg->UnwrapExpr()}) { 1692 if (const auto *proc{ 1693 std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) { 1694 symbol = proc->GetSymbol(); 1695 } else { 1696 symbol = evaluate::UnwrapWholeSymbolDataRef(*expr); 1697 } 1698 } else { 1699 symbol = arg->GetAssumedTypeDummy(); 1700 } 1701 if (!symbol || 1702 !symbol->GetUltimate().attrs().test(semantics::Attr::OPTIONAL)) { 1703 messages.Say(arg ? arg->sourceLocation() : messages.at(), 1704 "Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument"_err_en_US); 1705 } 1706 } 1707 } 1708 } 1709 1710 // REDUCE (F'2023 16.9.173) 1711 static void CheckReduce( 1712 evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) { 1713 std::optional<evaluate::DynamicType> arrayType; 1714 parser::ContextualMessages &messages{context.messages()}; 1715 if (const auto &array{arguments[0]}) { 1716 arrayType = array->GetType(); 1717 if (!arguments[/*identity=*/4]) { 1718 if (const auto *expr{array->UnwrapExpr()}) { 1719 if (auto shape{ 1720 evaluate::GetShape(context, *expr, /*invariantOnly=*/false)}) { 1721 if (const auto &dim{arguments[2]}; dim && array->Rank() > 1) { 1722 // Partial reduction 1723 auto dimVal{evaluate::ToInt64(dim->UnwrapExpr())}; 1724 std::int64_t j{0}; 1725 int zeroDims{0}; 1726 bool isSelectedDimEmpty{false}; 1727 for (const auto &extent : *shape) { 1728 ++j; 1729 if (evaluate::ToInt64(extent) == 0) { 1730 ++zeroDims; 1731 isSelectedDimEmpty |= dimVal && j == *dimVal; 1732 } 1733 } 1734 if (isSelectedDimEmpty && zeroDims == 1) { 1735 messages.Say( 1736 "IDENTITY= must be present when DIM=%d and the array has zero extent on that dimension"_err_en_US, 1737 static_cast<int>(dimVal.value())); 1738 } 1739 } else { // no DIM= or DIM=1 on a vector: total reduction 1740 for (const auto &extent : *shape) { 1741 if (evaluate::ToInt64(extent) == 0) { 1742 messages.Say( 1743 "IDENTITY= must be present when the array is empty and the result is scalar"_err_en_US); 1744 break; 1745 } 1746 } 1747 } 1748 } 1749 } 1750 } 1751 } 1752 std::optional<characteristics::Procedure> procChars; 1753 if (const auto &operation{arguments[1]}) { 1754 if (const auto *expr{operation->UnwrapExpr()}) { 1755 if (const auto *designator{ 1756 std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) { 1757 procChars = characteristics::Procedure::Characterize( 1758 *designator, context, /*emitError=*/true); 1759 } else if (const auto *ref{ 1760 std::get_if<evaluate::ProcedureRef>(&expr->u)}) { 1761 procChars = characteristics::Procedure::Characterize(*ref, context); 1762 } 1763 } 1764 } 1765 const auto *result{ 1766 procChars ? procChars->functionResult->GetTypeAndShape() : nullptr}; 1767 if (!procChars || !procChars->IsPure() || 1768 procChars->dummyArguments.size() != 2 || !procChars->functionResult) { 1769 messages.Say( 1770 "OPERATION= argument of REDUCE() must be a pure function of two data arguments"_err_en_US); 1771 } else if (procChars->attrs.test(characteristics::Procedure::Attr::BindC)) { 1772 messages.Say( 1773 "A BIND(C) OPERATION= argument of REDUCE() is not supported"_err_en_US); 1774 } else if (!result || result->Rank() != 0) { 1775 messages.Say( 1776 "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US); 1777 } else if (result->type().IsPolymorphic() || 1778 (arrayType && !arrayType->IsTkLenCompatibleWith(result->type()))) { 1779 messages.Say( 1780 "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US); 1781 } else { 1782 const characteristics::DummyDataObject *data[2]{}; 1783 for (int j{0}; j < 2; ++j) { 1784 const auto &dummy{procChars->dummyArguments.at(j)}; 1785 data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u); 1786 } 1787 if (!data[0] || !data[1]) { 1788 messages.Say( 1789 "OPERATION= argument of REDUCE() may not have dummy procedure arguments"_err_en_US); 1790 } else { 1791 for (int j{0}; j < 2; ++j) { 1792 if (data[j]->attrs.test( 1793 characteristics::DummyDataObject::Attr::Optional) || 1794 data[j]->attrs.test( 1795 characteristics::DummyDataObject::Attr::Allocatable) || 1796 data[j]->attrs.test( 1797 characteristics::DummyDataObject::Attr::Pointer) || 1798 data[j]->type.Rank() != 0 || data[j]->type.type().IsPolymorphic() || 1799 (arrayType && 1800 !data[j]->type.type().IsTkCompatibleWith(*arrayType))) { 1801 messages.Say( 1802 "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); 1803 } 1804 } 1805 static constexpr characteristics::DummyDataObject::Attr attrs[]{ 1806 characteristics::DummyDataObject::Attr::Asynchronous, 1807 characteristics::DummyDataObject::Attr::Target, 1808 characteristics::DummyDataObject::Attr::Value, 1809 }; 1810 for (std::size_t j{0}; j < sizeof attrs / sizeof *attrs; ++j) { 1811 if (data[0]->attrs.test(attrs[j]) != data[1]->attrs.test(attrs[j])) { 1812 messages.Say( 1813 "If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US); 1814 break; 1815 } 1816 } 1817 } 1818 } 1819 // When the MASK= is present and has no .TRUE. element, and there is 1820 // no IDENTITY=, it's an error. 1821 if (const auto &mask{arguments[3]}; mask && !arguments[/*identity*/ 4]) { 1822 if (const auto *expr{mask->UnwrapExpr()}) { 1823 if (const auto *logical{ 1824 std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&expr->u)}) { 1825 if (common::visit( 1826 [](const auto &kindExpr) { 1827 using KindExprType = std::decay_t<decltype(kindExpr)>; 1828 using KindLogical = typename KindExprType::Result; 1829 if (const auto *c{evaluate::UnwrapConstantValue<KindLogical>( 1830 kindExpr)}) { 1831 for (const auto &element : c->values()) { 1832 if (element.IsTrue()) { 1833 return false; 1834 } 1835 } 1836 return true; 1837 } 1838 return false; 1839 }, 1840 logical->u)) { 1841 messages.Say( 1842 "MASK= has no .TRUE. element, so IDENTITY= must be present"_err_en_US); 1843 } 1844 } 1845 } 1846 } 1847 } 1848 1849 // TRANSFER (16.9.193) 1850 static void CheckTransferOperandType(SemanticsContext &context, 1851 const evaluate::DynamicType &type, const char *which) { 1852 if (type.IsPolymorphic() && 1853 context.ShouldWarn(common::UsageWarning::PolymorphicTransferArg)) { 1854 context.foldingContext().messages().Say( 1855 common::UsageWarning::PolymorphicTransferArg, 1856 "%s of TRANSFER is polymorphic"_warn_en_US, which); 1857 } else if (!type.IsUnlimitedPolymorphic() && 1858 type.category() == TypeCategory::Derived && 1859 context.ShouldWarn(common::UsageWarning::PointerComponentTransferArg)) { 1860 DirectComponentIterator directs{type.GetDerivedTypeSpec()}; 1861 if (auto bad{std::find_if(directs.begin(), directs.end(), IsDescriptor)}; 1862 bad != directs.end()) { 1863 evaluate::SayWithDeclaration(context.foldingContext().messages(), *bad, 1864 common::UsageWarning::PointerComponentTransferArg, 1865 "%s of TRANSFER contains allocatable or pointer component %s"_warn_en_US, 1866 which, bad.BuildResultDesignatorName()); 1867 } 1868 } 1869 } 1870 1871 static void CheckTransfer(evaluate::ActualArguments &arguments, 1872 SemanticsContext &context, const Scope *scope) { 1873 evaluate::FoldingContext &foldingContext{context.foldingContext()}; 1874 parser::ContextualMessages &messages{foldingContext.messages()}; 1875 if (arguments.size() >= 2) { 1876 if (auto source{characteristics::TypeAndShape::Characterize( 1877 arguments[0], foldingContext)}) { 1878 CheckTransferOperandType(context, source->type(), "Source"); 1879 if (auto mold{characteristics::TypeAndShape::Characterize( 1880 arguments[1], foldingContext)}) { 1881 CheckTransferOperandType(context, mold->type(), "Mold"); 1882 if (mold->Rank() > 0 && 1883 evaluate::ToInt64( 1884 evaluate::Fold(foldingContext, 1885 mold->MeasureElementSizeInBytes(foldingContext, false))) 1886 .value_or(1) == 0) { 1887 if (auto sourceSize{evaluate::ToInt64(evaluate::Fold(foldingContext, 1888 source->MeasureSizeInBytes(foldingContext)))}) { 1889 if (*sourceSize > 0) { 1890 messages.Say( 1891 "Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US); 1892 } 1893 } else if (context.ShouldWarn(common::UsageWarning::VoidMold)) { 1894 messages.Say(common::UsageWarning::VoidMold, 1895 "Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US); 1896 } 1897 } 1898 } 1899 } 1900 if (arguments.size() > 2) { // SIZE= 1901 if (const Symbol * 1902 whole{UnwrapWholeSymbolOrComponentDataRef(arguments[2])}) { 1903 if (IsOptional(*whole)) { 1904 messages.Say( 1905 "SIZE= argument may not be the optional dummy argument '%s'"_err_en_US, 1906 whole->name()); 1907 } else if (context.ShouldWarn( 1908 common::UsageWarning::TransferSizePresence) && 1909 IsAllocatableOrObjectPointer(whole)) { 1910 messages.Say(common::UsageWarning::TransferSizePresence, 1911 "SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US); 1912 } 1913 } 1914 } 1915 } 1916 } 1917 1918 static void CheckSpecificIntrinsic(const characteristics::Procedure &proc, 1919 evaluate::ActualArguments &arguments, SemanticsContext &context, 1920 const Scope *scope, const evaluate::SpecificIntrinsic &intrinsic) { 1921 if (intrinsic.name == "associated") { 1922 CheckAssociated(arguments, context, scope); 1923 } else if (intrinsic.name == "image_index") { 1924 CheckImage_Index(arguments, context.foldingContext().messages()); 1925 } else if (intrinsic.name == "max" || intrinsic.name == "min") { 1926 CheckMaxMin(proc, arguments, context.foldingContext().messages()); 1927 } else if (intrinsic.name == "move_alloc") { 1928 CheckMove_Alloc(arguments, context.foldingContext().messages()); 1929 } else if (intrinsic.name == "present") { 1930 CheckPresent(arguments, context.foldingContext().messages()); 1931 } else if (intrinsic.name == "reduce") { 1932 CheckReduce(arguments, context.foldingContext()); 1933 } else if (intrinsic.name == "transfer") { 1934 CheckTransfer(arguments, context, scope); 1935 } else if (intrinsic.name == "free") { 1936 CheckFree(arguments, context.foldingContext().messages()); 1937 } 1938 } 1939 1940 static parser::Messages CheckExplicitInterface( 1941 const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, 1942 SemanticsContext &context, const Scope *scope, 1943 const evaluate::SpecificIntrinsic *intrinsic, 1944 bool allowActualArgumentConversions, bool extentErrors, 1945 bool ignoreImplicitVsExplicit) { 1946 evaluate::FoldingContext &foldingContext{context.foldingContext()}; 1947 parser::ContextualMessages &messages{foldingContext.messages()}; 1948 parser::Messages buffer; 1949 auto restorer{messages.SetMessages(buffer)}; 1950 RearrangeArguments(proc, actuals, messages); 1951 if (!buffer.empty()) { 1952 return buffer; 1953 } 1954 int index{0}; 1955 for (auto &actual : actuals) { 1956 const auto &dummy{proc.dummyArguments.at(index++)}; 1957 if (actual) { 1958 CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic, 1959 allowActualArgumentConversions, extentErrors, 1960 ignoreImplicitVsExplicit); 1961 } else if (!dummy.IsOptional()) { 1962 if (dummy.name.empty()) { 1963 messages.Say( 1964 "Dummy argument #%d is not OPTIONAL and is not associated with " 1965 "an actual argument in this procedure reference"_err_en_US, 1966 index); 1967 } else { 1968 messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not " 1969 "associated with an actual argument in this procedure " 1970 "reference"_err_en_US, 1971 dummy.name, index); 1972 } 1973 } 1974 } 1975 if (proc.IsElemental() && !buffer.AnyFatalError()) { 1976 CheckElementalConformance(messages, proc, actuals, foldingContext); 1977 } 1978 if (intrinsic) { 1979 CheckSpecificIntrinsic(proc, actuals, context, scope, *intrinsic); 1980 } 1981 return buffer; 1982 } 1983 1984 bool CheckInterfaceForGeneric(const characteristics::Procedure &proc, 1985 evaluate::ActualArguments &actuals, SemanticsContext &context, 1986 bool allowActualArgumentConversions) { 1987 return proc.HasExplicitInterface() && 1988 !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr, 1989 allowActualArgumentConversions, /*extentErrors=*/false, 1990 /*ignoreImplicitVsExplicit=*/false) 1991 .AnyFatalError(); 1992 } 1993 1994 bool CheckArgumentIsConstantExprInRange( 1995 const evaluate::ActualArguments &actuals, int index, int lowerBound, 1996 int upperBound, parser::ContextualMessages &messages) { 1997 CHECK(index >= 0 && static_cast<unsigned>(index) < actuals.size()); 1998 1999 const std::optional<evaluate::ActualArgument> &argOptional{actuals[index]}; 2000 if (!argOptional) { 2001 DIE("Actual argument should have value"); 2002 return false; 2003 } 2004 2005 const evaluate::ActualArgument &arg{argOptional.value()}; 2006 const evaluate::Expr<evaluate::SomeType> *argExpr{arg.UnwrapExpr()}; 2007 CHECK(argExpr != nullptr); 2008 2009 if (!IsConstantExpr(*argExpr)) { 2010 messages.Say("Actual argument #%d must be a constant expression"_err_en_US, 2011 index + 1); 2012 return false; 2013 } 2014 2015 // This does not imply that the kind of the argument is 8. The kind 2016 // for the intrinsic's argument should have been check prior. This is just 2017 // a conversion so that we can read the constant value. 2018 auto scalarValue{evaluate::ToInt64(argExpr)}; 2019 CHECK(scalarValue.has_value()); 2020 2021 if (*scalarValue < lowerBound || *scalarValue > upperBound) { 2022 messages.Say( 2023 "Argument #%d must be a constant expression in range %d to %d"_err_en_US, 2024 index + 1, lowerBound, upperBound); 2025 return false; 2026 } 2027 return true; 2028 } 2029 2030 bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific, 2031 const evaluate::ActualArguments &actuals, 2032 evaluate::FoldingContext &context) { 2033 parser::ContextualMessages &messages{context.messages()}; 2034 2035 if (specific.name() == "__ppc_mtfsf") { 2036 return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages); 2037 } 2038 if (specific.name() == "__ppc_mtfsfi") { 2039 return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages) && 2040 CheckArgumentIsConstantExprInRange(actuals, 1, 0, 15, messages); 2041 } 2042 if (specific.name().ToString().compare(0, 14, "__ppc_vec_sld_") == 0) { 2043 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 15, messages); 2044 } 2045 if (specific.name().ToString().compare(0, 15, "__ppc_vec_sldw_") == 0) { 2046 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages); 2047 } 2048 if (specific.name().ToString().compare(0, 14, "__ppc_vec_ctf_") == 0) { 2049 return CheckArgumentIsConstantExprInRange(actuals, 1, 0, 31, messages); 2050 } 2051 if (specific.name().ToString().compare(0, 16, "__ppc_vec_permi_") == 0) { 2052 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages); 2053 } 2054 if (specific.name().ToString().compare(0, 21, "__ppc_vec_splat_s32__") == 0) { 2055 return CheckArgumentIsConstantExprInRange(actuals, 0, -16, 15, messages); 2056 } 2057 if (specific.name().ToString().compare(0, 16, "__ppc_vec_splat_") == 0) { 2058 // The value of arg2 in vec_splat must be a constant expression that is 2059 // greater than or equal to 0, and less than the number of elements in arg1. 2060 auto *expr{actuals[0].value().UnwrapExpr()}; 2061 auto type{characteristics::TypeAndShape::Characterize(*expr, context)}; 2062 assert(type && "unknown type"); 2063 const auto *derived{evaluate::GetDerivedTypeSpec(type.value().type())}; 2064 if (derived && derived->IsVectorType()) { 2065 for (const auto &pair : derived->parameters()) { 2066 if (pair.first == "element_kind") { 2067 auto vecElemKind{Fortran::evaluate::ToInt64(pair.second.GetExplicit()) 2068 .value_or(0)}; 2069 auto numElem{vecElemKind == 0 ? 0 : (16 / vecElemKind)}; 2070 return CheckArgumentIsConstantExprInRange( 2071 actuals, 1, 0, numElem - 1, messages); 2072 } 2073 } 2074 } else 2075 assert(false && "vector type is expected"); 2076 } 2077 return false; 2078 } 2079 2080 bool CheckWindowsIntrinsic( 2081 const Symbol &intrinsic, evaluate::FoldingContext &foldingContext) { 2082 parser::ContextualMessages &messages{foldingContext.messages()}; 2083 // TODO: there are other intrinsics that are unsupported on Windows that 2084 // should be added here. 2085 if (intrinsic.name() == "getuid") { 2086 messages.Say( 2087 "User IDs do not exist on Windows. This function will always return 1"_warn_en_US); 2088 } 2089 if (intrinsic.name() == "getgid") { 2090 messages.Say( 2091 "Group IDs do not exist on Windows. This function will always return 1"_warn_en_US); 2092 } 2093 return true; 2094 } 2095 2096 bool CheckArguments(const characteristics::Procedure &proc, 2097 evaluate::ActualArguments &actuals, SemanticsContext &context, 2098 const Scope &scope, bool treatingExternalAsImplicit, 2099 bool ignoreImplicitVsExplicit, 2100 const evaluate::SpecificIntrinsic *intrinsic) { 2101 bool explicitInterface{proc.HasExplicitInterface()}; 2102 evaluate::FoldingContext foldingContext{context.foldingContext()}; 2103 parser::ContextualMessages &messages{foldingContext.messages()}; 2104 bool allowArgumentConversions{true}; 2105 if (!explicitInterface || treatingExternalAsImplicit) { 2106 parser::Messages buffer; 2107 { 2108 auto restorer{messages.SetMessages(buffer)}; 2109 for (auto &actual : actuals) { 2110 if (actual) { 2111 CheckImplicitInterfaceArg(*actual, messages, context); 2112 } 2113 } 2114 } 2115 if (!buffer.empty()) { 2116 if (auto *msgs{messages.messages()}) { 2117 msgs->Annex(std::move(buffer)); 2118 } 2119 return false; // don't pile on 2120 } 2121 allowArgumentConversions = false; 2122 } 2123 if (explicitInterface) { 2124 auto buffer{CheckExplicitInterface(proc, actuals, context, &scope, 2125 intrinsic, allowArgumentConversions, 2126 /*extentErrors=*/true, ignoreImplicitVsExplicit)}; 2127 if (!buffer.empty()) { 2128 if (treatingExternalAsImplicit) { 2129 if (context.ShouldWarn( 2130 common::UsageWarning::KnownBadImplicitInterface)) { 2131 if (auto *msg{messages.Say( 2132 common::UsageWarning::KnownBadImplicitInterface, 2133 "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) { 2134 buffer.AttachTo(*msg, parser::Severity::Because); 2135 } 2136 } else { 2137 buffer.clear(); 2138 } 2139 } 2140 if (auto *msgs{messages.messages()}) { 2141 msgs->Annex(std::move(buffer)); 2142 } 2143 return false; 2144 } 2145 } 2146 return true; 2147 } 2148 } // namespace Fortran::semantics 2149