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