1 //===-- lib/Evaluate/characteristics.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 "flang/Evaluate/characteristics.h" 10 #include "flang/Common/indirection.h" 11 #include "flang/Evaluate/check-expression.h" 12 #include "flang/Evaluate/fold.h" 13 #include "flang/Evaluate/intrinsics.h" 14 #include "flang/Evaluate/tools.h" 15 #include "flang/Evaluate/type.h" 16 #include "flang/Parser/message.h" 17 #include "flang/Semantics/scope.h" 18 #include "flang/Semantics/symbol.h" 19 #include "flang/Semantics/tools.h" 20 #include "llvm/Support/raw_ostream.h" 21 #include <initializer_list> 22 23 using namespace Fortran::parser::literals; 24 25 namespace Fortran::evaluate::characteristics { 26 27 // Copy attributes from a symbol to dst based on the mapping in pairs. 28 template <typename A, typename B> 29 static void CopyAttrs(const semantics::Symbol &src, A &dst, 30 const std::initializer_list<std::pair<semantics::Attr, B>> &pairs) { 31 for (const auto &pair : pairs) { 32 if (src.attrs().test(pair.first)) { 33 dst.attrs.set(pair.second); 34 } 35 } 36 } 37 38 // Shapes of function results and dummy arguments have to have 39 // the same rank, the same deferred dimensions, and the same 40 // values for explicit dimensions when constant. 41 bool ShapesAreCompatible( 42 const Shape &x, const Shape &y, bool *possibleWarning) { 43 if (x.size() != y.size()) { 44 return false; 45 } 46 auto yIter{y.begin()}; 47 for (const auto &xDim : x) { 48 const auto &yDim{*yIter++}; 49 if (xDim && yDim) { 50 if (auto equiv{AreEquivalentInInterface(*xDim, *yDim)}) { 51 if (!*equiv) { 52 return false; 53 } 54 } else if (possibleWarning) { 55 *possibleWarning = true; 56 } 57 } else if (xDim || yDim) { 58 return false; 59 } 60 } 61 return true; 62 } 63 64 bool TypeAndShape::operator==(const TypeAndShape &that) const { 65 return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) && 66 attrs_ == that.attrs_ && corank_ == that.corank_; 67 } 68 69 TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) { 70 LEN_ = Fold(context, std::move(LEN_)); 71 if (LEN_) { 72 if (auto n{ToInt64(*LEN_)}) { 73 type_ = DynamicType{type_.kind(), *n}; 74 } 75 } 76 shape_ = Fold(context, std::move(shape_)); 77 return *this; 78 } 79 80 std::optional<TypeAndShape> TypeAndShape::Characterize( 81 const semantics::Symbol &symbol, FoldingContext &context, 82 bool invariantOnly) { 83 const auto &ultimate{symbol.GetUltimate()}; 84 return common::visit( 85 common::visitors{ 86 [&](const semantics::ProcEntityDetails &proc) { 87 if (proc.procInterface()) { 88 return Characterize( 89 *proc.procInterface(), context, invariantOnly); 90 } else if (proc.type()) { 91 return Characterize(*proc.type(), context, invariantOnly); 92 } else { 93 return std::optional<TypeAndShape>{}; 94 } 95 }, 96 [&](const semantics::AssocEntityDetails &assoc) { 97 return Characterize(assoc, context, invariantOnly); 98 }, 99 [&](const semantics::ProcBindingDetails &binding) { 100 return Characterize(binding.symbol(), context, invariantOnly); 101 }, 102 [&](const auto &x) -> std::optional<TypeAndShape> { 103 using Ty = std::decay_t<decltype(x)>; 104 if constexpr (std::is_same_v<Ty, semantics::EntityDetails> || 105 std::is_same_v<Ty, semantics::ObjectEntityDetails> || 106 std::is_same_v<Ty, semantics::TypeParamDetails>) { 107 if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) { 108 if (auto dyType{DynamicType::From(*type)}) { 109 TypeAndShape result{std::move(*dyType), 110 GetShape(context, ultimate, invariantOnly)}; 111 result.AcquireAttrs(ultimate); 112 result.AcquireLEN(ultimate); 113 return std::move(result.Rewrite(context)); 114 } 115 } 116 } 117 return std::nullopt; 118 }, 119 }, 120 // GetUltimate() used here, not ResolveAssociations(), because 121 // we need the type/rank of an associate entity from TYPE IS, 122 // CLASS IS, or RANK statement. 123 ultimate.details()); 124 } 125 126 std::optional<TypeAndShape> TypeAndShape::Characterize( 127 const semantics::AssocEntityDetails &assoc, FoldingContext &context, 128 bool invariantOnly) { 129 std::optional<TypeAndShape> result; 130 if (auto type{DynamicType::From(assoc.type())}) { 131 if (auto rank{assoc.rank()}) { 132 if (*rank >= 0 && *rank <= common::maxRank) { 133 result = TypeAndShape{std::move(*type), Shape(*rank)}; 134 } 135 } else if (auto shape{GetShape(context, assoc.expr(), invariantOnly)}) { 136 result = TypeAndShape{std::move(*type), std::move(*shape)}; 137 } 138 if (result && type->category() == TypeCategory::Character) { 139 if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc.expr())}) { 140 if (auto len{chExpr->LEN()}) { 141 result->set_LEN(std::move(*len)); 142 } 143 } 144 } 145 } 146 return Fold(context, std::move(result)); 147 } 148 149 std::optional<TypeAndShape> TypeAndShape::Characterize( 150 const semantics::DeclTypeSpec &spec, FoldingContext &context, 151 bool /*invariantOnly=*/) { 152 if (auto type{DynamicType::From(spec)}) { 153 return Fold(context, TypeAndShape{std::move(*type)}); 154 } else { 155 return std::nullopt; 156 } 157 } 158 159 std::optional<TypeAndShape> TypeAndShape::Characterize( 160 const ActualArgument &arg, FoldingContext &context, bool invariantOnly) { 161 if (const auto *expr{arg.UnwrapExpr()}) { 162 return Characterize(*expr, context, invariantOnly); 163 } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) { 164 return Characterize(*assumed, context, invariantOnly); 165 } else { 166 return std::nullopt; 167 } 168 } 169 170 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages, 171 const TypeAndShape &that, const char *thisIs, const char *thatIs, 172 bool omitShapeConformanceCheck, 173 enum CheckConformanceFlags::Flags flags) const { 174 if (!type_.IsTkCompatibleWith(that.type_)) { 175 messages.Say( 176 "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US, 177 thatIs, that.AsFortran(), thisIs, AsFortran()); 178 return false; 179 } 180 return omitShapeConformanceCheck || 181 CheckConformance(messages, shape_, that.shape_, flags, thisIs, thatIs) 182 .value_or(true /*fail only when nonconformance is known now*/); 183 } 184 185 std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureElementSizeInBytes( 186 FoldingContext &foldingContext, bool align) const { 187 if (LEN_) { 188 CHECK(type_.category() == TypeCategory::Character); 189 return Fold(foldingContext, 190 Expr<SubscriptInteger>{ 191 foldingContext.targetCharacteristics().GetByteSize( 192 type_.category(), type_.kind())} * 193 Expr<SubscriptInteger>{*LEN_}); 194 } 195 if (auto elementBytes{type_.MeasureSizeInBytes(foldingContext, align)}) { 196 return Fold(foldingContext, std::move(*elementBytes)); 197 } 198 return std::nullopt; 199 } 200 201 std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes( 202 FoldingContext &foldingContext) const { 203 if (auto elements{GetSize(Shape{shape_})}) { 204 // Sizes of arrays (even with single elements) are multiples of 205 // their alignments. 206 if (auto elementBytes{ 207 MeasureElementSizeInBytes(foldingContext, GetRank(shape_) > 0)}) { 208 return Fold( 209 foldingContext, std::move(*elements) * std::move(*elementBytes)); 210 } 211 } 212 return std::nullopt; 213 } 214 215 void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) { 216 if (IsAssumedShape(symbol)) { 217 attrs_.set(Attr::AssumedShape); 218 } else if (IsDeferredShape(symbol)) { 219 attrs_.set(Attr::DeferredShape); 220 } else if (semantics::IsAssumedSizeArray(symbol)) { 221 attrs_.set(Attr::AssumedSize); 222 } 223 if (const auto *object{ 224 symbol.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) { 225 corank_ = object->coshape().Rank(); 226 if (object->IsAssumedRank()) { 227 attrs_.set(Attr::AssumedRank); 228 } 229 if (object->IsCoarray()) { 230 attrs_.set(Attr::Coarray); 231 } 232 } 233 } 234 235 void TypeAndShape::AcquireLEN() { 236 if (auto len{type_.GetCharLength()}) { 237 LEN_ = std::move(len); 238 } 239 } 240 241 void TypeAndShape::AcquireLEN(const semantics::Symbol &symbol) { 242 if (type_.category() == TypeCategory::Character) { 243 if (auto len{DataRef{symbol}.LEN()}) { 244 LEN_ = std::move(*len); 245 } 246 } 247 } 248 249 std::string TypeAndShape::AsFortran() const { 250 return type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""); 251 } 252 253 llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const { 254 o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""); 255 attrs_.Dump(o, EnumToString); 256 if (!shape_.empty()) { 257 o << " dimension"; 258 char sep{'('}; 259 for (const auto &expr : shape_) { 260 o << sep; 261 sep = ','; 262 if (expr) { 263 expr->AsFortran(o); 264 } else { 265 o << ':'; 266 } 267 } 268 o << ')'; 269 } 270 return o; 271 } 272 273 bool DummyDataObject::operator==(const DummyDataObject &that) const { 274 return type == that.type && attrs == that.attrs && intent == that.intent && 275 coshape == that.coshape && cudaDataAttr == that.cudaDataAttr; 276 } 277 278 bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual, 279 std::string *whyNot, std::optional<std::string> *warning) const { 280 bool possibleWarning{false}; 281 if (!ShapesAreCompatible( 282 type.shape(), actual.type.shape(), &possibleWarning)) { 283 if (whyNot) { 284 *whyNot = "incompatible dummy data object shapes"; 285 } 286 return false; 287 } else if (warning && possibleWarning) { 288 *warning = "distinct dummy data object shapes"; 289 } 290 // Treat deduced dummy character type as if it were assumed-length character 291 // to avoid useless "implicit interfaces have distinct type" warnings from 292 // CALL FOO('abc'); CALL FOO('abcd'). 293 bool deducedAssumedLength{type.type().category() == TypeCategory::Character && 294 attrs.test(Attr::DeducedFromActual)}; 295 bool compatibleTypes{deducedAssumedLength 296 ? type.type().IsTkCompatibleWith(actual.type.type()) 297 : type.type().IsTkLenCompatibleWith(actual.type.type())}; 298 if (!compatibleTypes) { 299 if (whyNot) { 300 *whyNot = "incompatible dummy data object types: "s + 301 type.type().AsFortran() + " vs " + actual.type.type().AsFortran(); 302 } 303 return false; 304 } 305 if (type.type().IsPolymorphic() != actual.type.type().IsPolymorphic()) { 306 if (whyNot) { 307 *whyNot = "incompatible dummy data object polymorphism: "s + 308 type.type().AsFortran() + " vs " + actual.type.type().AsFortran(); 309 } 310 return false; 311 } 312 if (type.type().category() == TypeCategory::Character && 313 !deducedAssumedLength) { 314 if (actual.type.type().IsAssumedLengthCharacter() != 315 type.type().IsAssumedLengthCharacter()) { 316 if (whyNot) { 317 *whyNot = "assumed-length character vs explicit-length character"; 318 } 319 return false; 320 } 321 if (!type.type().IsAssumedLengthCharacter() && type.LEN() && 322 actual.type.LEN()) { 323 auto len{ToInt64(*type.LEN())}; 324 auto actualLen{ToInt64(*actual.type.LEN())}; 325 if (len.has_value() != actualLen.has_value()) { 326 if (whyNot) { 327 *whyNot = "constant-length vs non-constant-length character dummy " 328 "arguments"; 329 } 330 return false; 331 } else if (len && *len != *actualLen) { 332 if (whyNot) { 333 *whyNot = "character dummy arguments with distinct lengths"; 334 } 335 return false; 336 } 337 } 338 } 339 if (!IdenticalSignificantAttrs(attrs, actual.attrs) || 340 type.attrs() != actual.type.attrs()) { 341 if (whyNot) { 342 *whyNot = "incompatible dummy data object attributes"; 343 } 344 return false; 345 } 346 if (intent != actual.intent) { 347 if (whyNot) { 348 *whyNot = "incompatible dummy data object intents"; 349 } 350 return false; 351 } 352 if (coshape != actual.coshape) { 353 if (whyNot) { 354 *whyNot = "incompatible dummy data object coshapes"; 355 } 356 return false; 357 } 358 if (ignoreTKR != actual.ignoreTKR) { 359 if (whyNot) { 360 *whyNot = "incompatible !DIR$ IGNORE_TKR directives"; 361 } 362 } 363 if (!attrs.test(Attr::Value) && 364 !common::AreCompatibleCUDADataAttrs( 365 cudaDataAttr, actual.cudaDataAttr, ignoreTKR)) { 366 if (whyNot) { 367 *whyNot = "incompatible CUDA data attributes"; 368 } 369 } 370 return true; 371 } 372 373 static common::Intent GetIntent(const semantics::Attrs &attrs) { 374 if (attrs.test(semantics::Attr::INTENT_IN)) { 375 return common::Intent::In; 376 } else if (attrs.test(semantics::Attr::INTENT_OUT)) { 377 return common::Intent::Out; 378 } else if (attrs.test(semantics::Attr::INTENT_INOUT)) { 379 return common::Intent::InOut; 380 } else { 381 return common::Intent::Default; 382 } 383 } 384 385 std::optional<DummyDataObject> DummyDataObject::Characterize( 386 const semantics::Symbol &symbol, FoldingContext &context) { 387 if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}; 388 object || symbol.has<semantics::EntityDetails>()) { 389 if (auto type{TypeAndShape::Characterize( 390 symbol, context, /*invariantOnly=*/false)}) { 391 std::optional<DummyDataObject> result{std::move(*type)}; 392 using semantics::Attr; 393 CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result, 394 { 395 {Attr::OPTIONAL, DummyDataObject::Attr::Optional}, 396 {Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable}, 397 {Attr::ASYNCHRONOUS, DummyDataObject::Attr::Asynchronous}, 398 {Attr::CONTIGUOUS, DummyDataObject::Attr::Contiguous}, 399 {Attr::VALUE, DummyDataObject::Attr::Value}, 400 {Attr::VOLATILE, DummyDataObject::Attr::Volatile}, 401 {Attr::POINTER, DummyDataObject::Attr::Pointer}, 402 {Attr::TARGET, DummyDataObject::Attr::Target}, 403 }); 404 result->intent = GetIntent(symbol.attrs()); 405 result->ignoreTKR = GetIgnoreTKR(symbol); 406 if (object) { 407 result->cudaDataAttr = object->cudaDataAttr(); 408 if (!result->cudaDataAttr && 409 !result->attrs.test(DummyDataObject::Attr::Value) && 410 semantics::IsCUDADeviceContext(&symbol.owner())) { 411 result->cudaDataAttr = common::CUDADataAttr::Device; 412 } 413 } 414 return result; 415 } 416 } 417 return std::nullopt; 418 } 419 420 bool DummyDataObject::CanBePassedViaImplicitInterface( 421 std::string *whyNot) const { 422 if ((attrs & 423 Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional, 424 Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile}) 425 .any()) { 426 if (whyNot) { 427 *whyNot = "a dummy argument has the allocatable, asynchronous, optional, " 428 "pointer, target, value, or volatile attribute"; 429 } 430 return false; // 15.4.2.2(3)(a) 431 } else if ((type.attrs() & 432 TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape, 433 TypeAndShape::Attr::AssumedRank, 434 TypeAndShape::Attr::Coarray}) 435 .any()) { 436 if (whyNot) { 437 *whyNot = "a dummy argument is assumed-shape, assumed-rank, or a coarray"; 438 } 439 return false; // 15.4.2.2(3)(b-d) 440 } else if (type.type().IsPolymorphic()) { 441 if (whyNot) { 442 *whyNot = "a dummy argument is polymorphic"; 443 } 444 return false; // 15.4.2.2(3)(f) 445 } else if (cudaDataAttr) { 446 if (whyNot) { 447 *whyNot = "a dummy argument has a CUDA data attribute"; 448 } 449 return false; 450 } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) { 451 if (derived->parameters().empty()) { // 15.4.2.2(3)(e) 452 return true; 453 } else { 454 if (whyNot) { 455 *whyNot = "a dummy argument has derived type parameters"; 456 } 457 return false; 458 } 459 } else { 460 return true; 461 } 462 } 463 464 llvm::raw_ostream &DummyDataObject::Dump(llvm::raw_ostream &o) const { 465 attrs.Dump(o, EnumToString); 466 if (intent != common::Intent::Default) { 467 o << "INTENT(" << common::EnumToString(intent) << ')'; 468 } 469 type.Dump(o); 470 if (!coshape.empty()) { 471 char sep{'['}; 472 for (const auto &expr : coshape) { 473 expr.AsFortran(o << sep); 474 sep = ','; 475 } 476 } 477 if (cudaDataAttr) { 478 o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr); 479 } 480 if (!ignoreTKR.empty()) { 481 ignoreTKR.Dump(o << ' ', common::EnumToString); 482 } 483 return o; 484 } 485 486 DummyProcedure::DummyProcedure(Procedure &&p) 487 : procedure{new Procedure{std::move(p)}} {} 488 489 bool DummyProcedure::operator==(const DummyProcedure &that) const { 490 return attrs == that.attrs && intent == that.intent && 491 procedure.value() == that.procedure.value(); 492 } 493 494 bool DummyProcedure::IsCompatibleWith( 495 const DummyProcedure &actual, std::string *whyNot) const { 496 if (attrs != actual.attrs) { 497 if (whyNot) { 498 *whyNot = "incompatible dummy procedure attributes"; 499 } 500 return false; 501 } 502 if (intent != actual.intent) { 503 if (whyNot) { 504 *whyNot = "incompatible dummy procedure intents"; 505 } 506 return false; 507 } 508 if (!procedure.value().IsCompatibleWith(actual.procedure.value(), whyNot)) { 509 if (whyNot) { 510 *whyNot = "incompatible dummy procedure interfaces: "s + *whyNot; 511 } 512 return false; 513 } 514 return true; 515 } 516 517 bool DummyProcedure::CanBePassedViaImplicitInterface( 518 std::string *whyNot) const { 519 if ((attrs & Attrs{Attr::Optional, Attr::Pointer}).any()) { 520 if (whyNot) { 521 *whyNot = "a dummy procedure is optional or a pointer"; 522 } 523 return false; // 15.4.2.2(3)(a) 524 } 525 return true; 526 } 527 528 static std::string GetSeenProcs( 529 const semantics::UnorderedSymbolSet &seenProcs) { 530 // Sort the symbols so that they appear in the same order on all platforms 531 auto ordered{semantics::OrderBySourcePosition(seenProcs)}; 532 std::string result; 533 llvm::interleave( 534 ordered, 535 [&](const SymbolRef p) { result += '\'' + p->name().ToString() + '\''; }, 536 [&]() { result += ", "; }); 537 return result; 538 } 539 540 // These functions with arguments of type UnorderedSymbolSet are used with 541 // mutually recursive calls when characterizing a Procedure, a DummyArgument, 542 // or a DummyProcedure to detect circularly defined procedures as required by 543 // 15.4.3.6, paragraph 2. 544 static std::optional<DummyArgument> CharacterizeDummyArgument( 545 const semantics::Symbol &symbol, FoldingContext &context, 546 semantics::UnorderedSymbolSet seenProcs); 547 static std::optional<FunctionResult> CharacterizeFunctionResult( 548 const semantics::Symbol &symbol, FoldingContext &context, 549 semantics::UnorderedSymbolSet seenProcs); 550 551 static std::optional<Procedure> CharacterizeProcedure( 552 const semantics::Symbol &original, FoldingContext &context, 553 semantics::UnorderedSymbolSet seenProcs) { 554 const auto &symbol{ResolveAssociations(original)}; 555 if (seenProcs.find(symbol) != seenProcs.end()) { 556 std::string procsList{GetSeenProcs(seenProcs)}; 557 context.messages().Say(symbol.name(), 558 "Procedure '%s' is recursively defined. Procedures in the cycle:" 559 " %s"_err_en_US, 560 symbol.name(), procsList); 561 return std::nullopt; 562 } 563 seenProcs.insert(symbol); 564 auto result{common::visit( 565 common::visitors{ 566 [&](const semantics::SubprogramDetails &subp) 567 -> std::optional<Procedure> { 568 Procedure result; 569 if (subp.isFunction()) { 570 if (auto fr{CharacterizeFunctionResult( 571 subp.result(), context, seenProcs)}) { 572 result.functionResult = std::move(fr); 573 } else { 574 return std::nullopt; 575 } 576 } else { 577 result.attrs.set(Procedure::Attr::Subroutine); 578 } 579 for (const semantics::Symbol *arg : subp.dummyArgs()) { 580 if (!arg) { 581 if (subp.isFunction()) { 582 return std::nullopt; 583 } else { 584 result.dummyArguments.emplace_back(AlternateReturn{}); 585 } 586 } else if (auto argCharacteristics{CharacterizeDummyArgument( 587 *arg, context, seenProcs)}) { 588 result.dummyArguments.emplace_back( 589 std::move(argCharacteristics.value())); 590 } else { 591 return std::nullopt; 592 } 593 } 594 result.cudaSubprogramAttrs = subp.cudaSubprogramAttrs(); 595 return std::move(result); 596 }, 597 [&](const semantics::ProcEntityDetails &proc) 598 -> std::optional<Procedure> { 599 if (symbol.attrs().test(semantics::Attr::INTRINSIC)) { 600 // Fails when the intrinsic is not a specific intrinsic function 601 // from F'2018 table 16.2. In order to handle forward references, 602 // attempts to use impermissible intrinsic procedures as the 603 // interfaces of procedure pointers are caught and flagged in 604 // declaration checking in Semantics. 605 auto intrinsic{context.intrinsics().IsSpecificIntrinsicFunction( 606 symbol.name().ToString())}; 607 if (intrinsic && intrinsic->isRestrictedSpecific) { 608 intrinsic.reset(); // Exclude intrinsics from table 16.3. 609 } 610 return intrinsic; 611 } 612 if (const semantics::Symbol * 613 interfaceSymbol{proc.procInterface()}) { 614 auto result{ 615 CharacterizeProcedure(*interfaceSymbol, context, seenProcs)}; 616 if (result && (IsDummy(symbol) || IsPointer(symbol))) { 617 // Dummy procedures and procedure pointers may not be 618 // ELEMENTAL, but we do accept the use of elemental intrinsic 619 // functions as their interfaces. 620 result->attrs.reset(Procedure::Attr::Elemental); 621 } 622 return result; 623 } else { 624 Procedure result; 625 result.attrs.set(Procedure::Attr::ImplicitInterface); 626 const semantics::DeclTypeSpec *type{proc.type()}; 627 if (symbol.test(semantics::Symbol::Flag::Subroutine)) { 628 // ignore any implicit typing 629 result.attrs.set(Procedure::Attr::Subroutine); 630 if (proc.isCUDAKernel()) { 631 result.cudaSubprogramAttrs = 632 common::CUDASubprogramAttrs::Global; 633 } 634 } else if (type) { 635 if (auto resultType{DynamicType::From(*type)}) { 636 result.functionResult = FunctionResult{*resultType}; 637 } else { 638 return std::nullopt; 639 } 640 } else if (symbol.test(semantics::Symbol::Flag::Function)) { 641 return std::nullopt; 642 } 643 // The PASS name, if any, is not a characteristic. 644 return std::move(result); 645 } 646 }, 647 [&](const semantics::ProcBindingDetails &binding) { 648 if (auto result{CharacterizeProcedure( 649 binding.symbol(), context, seenProcs)}) { 650 if (binding.symbol().attrs().test(semantics::Attr::INTRINSIC)) { 651 result->attrs.reset(Procedure::Attr::Elemental); 652 } 653 if (!symbol.attrs().test(semantics::Attr::NOPASS)) { 654 auto passName{binding.passName()}; 655 for (auto &dummy : result->dummyArguments) { 656 if (!passName || dummy.name.c_str() == *passName) { 657 dummy.pass = true; 658 break; 659 } 660 } 661 } 662 return result; 663 } else { 664 return std::optional<Procedure>{}; 665 } 666 }, 667 [&](const semantics::UseDetails &use) { 668 return CharacterizeProcedure(use.symbol(), context, seenProcs); 669 }, 670 [](const semantics::UseErrorDetails &) { 671 // Ambiguous use-association will be handled later during symbol 672 // checks, ignore UseErrorDetails here without actual symbol usage. 673 return std::optional<Procedure>{}; 674 }, 675 [&](const semantics::HostAssocDetails &assoc) { 676 return CharacterizeProcedure(assoc.symbol(), context, seenProcs); 677 }, 678 [&](const semantics::GenericDetails &generic) { 679 if (const semantics::Symbol * specific{generic.specific()}) { 680 return CharacterizeProcedure(*specific, context, seenProcs); 681 } else { 682 return std::optional<Procedure>{}; 683 } 684 }, 685 [&](const semantics::EntityDetails &) { 686 context.messages().Say( 687 "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US, 688 symbol.name()); 689 return std::optional<Procedure>{}; 690 }, 691 [&](const semantics::SubprogramNameDetails &) { 692 context.messages().Say( 693 "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US, 694 symbol.name()); 695 return std::optional<Procedure>{}; 696 }, 697 [&](const auto &) { 698 context.messages().Say( 699 "'%s' is not a procedure"_err_en_US, symbol.name()); 700 return std::optional<Procedure>{}; 701 }, 702 }, 703 symbol.details())}; 704 if (result && !symbol.has<semantics::ProcBindingDetails>()) { 705 CopyAttrs<Procedure, Procedure::Attr>(symbol, *result, 706 { 707 {semantics::Attr::BIND_C, Procedure::Attr::BindC}, 708 }); 709 CopyAttrs<Procedure, Procedure::Attr>(DEREF(GetMainEntry(&symbol)), *result, 710 { 711 {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental}, 712 }); 713 if (IsPureProcedure(symbol) || // works for ENTRY too 714 (!IsExplicitlyImpureProcedure(symbol) && 715 result->attrs.test(Procedure::Attr::Elemental))) { 716 result->attrs.set(Procedure::Attr::Pure); 717 } 718 } 719 return result; 720 } 721 722 static std::optional<DummyProcedure> CharacterizeDummyProcedure( 723 const semantics::Symbol &symbol, FoldingContext &context, 724 semantics::UnorderedSymbolSet seenProcs) { 725 if (auto procedure{CharacterizeProcedure(symbol, context, seenProcs)}) { 726 // Dummy procedures may not be elemental. Elemental dummy procedure 727 // interfaces are errors when the interface is not intrinsic, and that 728 // error is caught elsewhere. Elemental intrinsic interfaces are 729 // made non-elemental. 730 procedure->attrs.reset(Procedure::Attr::Elemental); 731 DummyProcedure result{std::move(procedure.value())}; 732 CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result, 733 { 734 {semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional}, 735 {semantics::Attr::POINTER, DummyProcedure::Attr::Pointer}, 736 }); 737 result.intent = GetIntent(symbol.attrs()); 738 return result; 739 } else { 740 return std::nullopt; 741 } 742 } 743 744 llvm::raw_ostream &DummyProcedure::Dump(llvm::raw_ostream &o) const { 745 attrs.Dump(o, EnumToString); 746 if (intent != common::Intent::Default) { 747 o << "INTENT(" << common::EnumToString(intent) << ')'; 748 } 749 procedure.value().Dump(o); 750 return o; 751 } 752 753 llvm::raw_ostream &AlternateReturn::Dump(llvm::raw_ostream &o) const { 754 return o << '*'; 755 } 756 757 DummyArgument::~DummyArgument() {} 758 759 bool DummyArgument::operator==(const DummyArgument &that) const { 760 return u == that.u; // name and passed-object usage are not characteristics 761 } 762 763 bool DummyArgument::IsCompatibleWith(const DummyArgument &actual, 764 std::string *whyNot, std::optional<std::string> *warning) const { 765 if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) { 766 if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) { 767 return ifaceData->IsCompatibleWith(*actualData, whyNot, warning); 768 } 769 if (whyNot) { 770 *whyNot = "one dummy argument is an object, the other is not"; 771 } 772 } else if (const auto *ifaceProc{std::get_if<DummyProcedure>(&u)}) { 773 if (const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)}) { 774 return ifaceProc->IsCompatibleWith(*actualProc, whyNot); 775 } 776 if (whyNot) { 777 *whyNot = "one dummy argument is a procedure, the other is not"; 778 } 779 } else { 780 CHECK(std::holds_alternative<AlternateReturn>(u)); 781 if (std::holds_alternative<AlternateReturn>(actual.u)) { 782 return true; 783 } 784 if (whyNot) { 785 *whyNot = "one dummy argument is an alternate return, the other is not"; 786 } 787 } 788 return false; 789 } 790 791 static std::optional<DummyArgument> CharacterizeDummyArgument( 792 const semantics::Symbol &symbol, FoldingContext &context, 793 semantics::UnorderedSymbolSet seenProcs) { 794 auto name{symbol.name().ToString()}; 795 if (symbol.has<semantics::ObjectEntityDetails>() || 796 symbol.has<semantics::EntityDetails>()) { 797 if (auto obj{DummyDataObject::Characterize(symbol, context)}) { 798 return DummyArgument{std::move(name), std::move(obj.value())}; 799 } 800 } else if (auto proc{ 801 CharacterizeDummyProcedure(symbol, context, seenProcs)}) { 802 return DummyArgument{std::move(name), std::move(proc.value())}; 803 } 804 return std::nullopt; 805 } 806 807 std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name, 808 const Expr<SomeType> &expr, FoldingContext &context, 809 bool forImplicitInterface) { 810 return common::visit( 811 common::visitors{ 812 [&](const BOZLiteralConstant &) { 813 DummyDataObject obj{ 814 TypeAndShape{DynamicType::TypelessIntrinsicArgument()}}; 815 obj.attrs.set(DummyDataObject::Attr::DeducedFromActual); 816 return std::make_optional<DummyArgument>( 817 std::move(name), std::move(obj)); 818 }, 819 [&](const NullPointer &) { 820 DummyDataObject obj{ 821 TypeAndShape{DynamicType::TypelessIntrinsicArgument()}}; 822 obj.attrs.set(DummyDataObject::Attr::DeducedFromActual); 823 return std::make_optional<DummyArgument>( 824 std::move(name), std::move(obj)); 825 }, 826 [&](const ProcedureDesignator &designator) { 827 if (auto proc{Procedure::Characterize(designator, context)}) { 828 return std::make_optional<DummyArgument>( 829 std::move(name), DummyProcedure{std::move(*proc)}); 830 } else { 831 return std::optional<DummyArgument>{}; 832 } 833 }, 834 [&](const ProcedureRef &call) { 835 if (auto proc{Procedure::Characterize(call, context)}) { 836 return std::make_optional<DummyArgument>( 837 std::move(name), DummyProcedure{std::move(*proc)}); 838 } else { 839 return std::optional<DummyArgument>{}; 840 } 841 }, 842 [&](const auto &) { 843 if (auto type{TypeAndShape::Characterize(expr, context)}) { 844 if (forImplicitInterface && 845 !type->type().IsUnlimitedPolymorphic() && 846 type->type().IsPolymorphic()) { 847 // Pass the monomorphic declared type to an implicit interface 848 type->set_type(DynamicType{ 849 type->type().GetDerivedTypeSpec(), /*poly=*/false}); 850 } 851 DummyDataObject obj{std::move(*type)}; 852 obj.attrs.set(DummyDataObject::Attr::DeducedFromActual); 853 return std::make_optional<DummyArgument>( 854 std::move(name), std::move(obj)); 855 } else { 856 return std::optional<DummyArgument>{}; 857 } 858 }, 859 }, 860 expr.u); 861 } 862 863 std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name, 864 const ActualArgument &arg, FoldingContext &context, 865 bool forImplicitInterface) { 866 if (const auto *expr{arg.UnwrapExpr()}) { 867 return FromActual(std::move(name), *expr, context, forImplicitInterface); 868 } else if (arg.GetAssumedTypeDummy()) { 869 return std::nullopt; 870 } else { 871 return DummyArgument{AlternateReturn{}}; 872 } 873 } 874 875 bool DummyArgument::IsOptional() const { 876 return common::visit( 877 common::visitors{ 878 [](const DummyDataObject &data) { 879 return data.attrs.test(DummyDataObject::Attr::Optional); 880 }, 881 [](const DummyProcedure &proc) { 882 return proc.attrs.test(DummyProcedure::Attr::Optional); 883 }, 884 [](const AlternateReturn &) { return false; }, 885 }, 886 u); 887 } 888 889 void DummyArgument::SetOptional(bool value) { 890 common::visit(common::visitors{ 891 [value](DummyDataObject &data) { 892 data.attrs.set(DummyDataObject::Attr::Optional, value); 893 }, 894 [value](DummyProcedure &proc) { 895 proc.attrs.set(DummyProcedure::Attr::Optional, value); 896 }, 897 [](AlternateReturn &) { DIE("cannot set optional"); }, 898 }, 899 u); 900 } 901 902 void DummyArgument::SetIntent(common::Intent intent) { 903 common::visit(common::visitors{ 904 [intent](DummyDataObject &data) { data.intent = intent; }, 905 [intent](DummyProcedure &proc) { proc.intent = intent; }, 906 [](AlternateReturn &) { DIE("cannot set intent"); }, 907 }, 908 u); 909 } 910 911 common::Intent DummyArgument::GetIntent() const { 912 return common::visit( 913 common::visitors{ 914 [](const DummyDataObject &data) { return data.intent; }, 915 [](const DummyProcedure &proc) { return proc.intent; }, 916 [](const AlternateReturn &) -> common::Intent { 917 DIE("Alternate returns have no intent"); 918 }, 919 }, 920 u); 921 } 922 923 bool DummyArgument::CanBePassedViaImplicitInterface(std::string *whyNot) const { 924 if (const auto *object{std::get_if<DummyDataObject>(&u)}) { 925 return object->CanBePassedViaImplicitInterface(whyNot); 926 } else if (const auto *proc{std::get_if<DummyProcedure>(&u)}) { 927 return proc->CanBePassedViaImplicitInterface(whyNot); 928 } else { 929 return true; 930 } 931 } 932 933 bool DummyArgument::IsTypelessIntrinsicDummy() const { 934 const auto *argObj{std::get_if<characteristics::DummyDataObject>(&u)}; 935 return argObj && argObj->type.type().IsTypelessIntrinsicArgument(); 936 } 937 938 llvm::raw_ostream &DummyArgument::Dump(llvm::raw_ostream &o) const { 939 if (!name.empty()) { 940 o << name << '='; 941 } 942 if (pass) { 943 o << " PASS"; 944 } 945 common::visit([&](const auto &x) { x.Dump(o); }, u); 946 return o; 947 } 948 949 FunctionResult::FunctionResult(DynamicType t) : u{TypeAndShape{t}} {} 950 FunctionResult::FunctionResult(TypeAndShape &&t) : u{std::move(t)} {} 951 FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {} 952 FunctionResult::~FunctionResult() {} 953 954 bool FunctionResult::operator==(const FunctionResult &that) const { 955 return attrs == that.attrs && cudaDataAttr == that.cudaDataAttr && 956 u == that.u; 957 } 958 959 static std::optional<FunctionResult> CharacterizeFunctionResult( 960 const semantics::Symbol &symbol, FoldingContext &context, 961 semantics::UnorderedSymbolSet seenProcs) { 962 if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) { 963 if (auto type{TypeAndShape::Characterize( 964 symbol, context, /*invariantOnly=*/false)}) { 965 FunctionResult result{std::move(*type)}; 966 CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result, 967 { 968 {semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable}, 969 {semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous}, 970 {semantics::Attr::POINTER, FunctionResult::Attr::Pointer}, 971 }); 972 result.cudaDataAttr = object->cudaDataAttr(); 973 return result; 974 } 975 } else if (auto maybeProc{ 976 CharacterizeProcedure(symbol, context, seenProcs)}) { 977 FunctionResult result{std::move(*maybeProc)}; 978 result.attrs.set(FunctionResult::Attr::Pointer); 979 return result; 980 } 981 return std::nullopt; 982 } 983 984 std::optional<FunctionResult> FunctionResult::Characterize( 985 const Symbol &symbol, FoldingContext &context) { 986 semantics::UnorderedSymbolSet seenProcs; 987 return CharacterizeFunctionResult(symbol, context, seenProcs); 988 } 989 990 bool FunctionResult::IsAssumedLengthCharacter() const { 991 if (const auto *ts{std::get_if<TypeAndShape>(&u)}) { 992 return ts->type().IsAssumedLengthCharacter(); 993 } else { 994 return false; 995 } 996 } 997 998 bool FunctionResult::CanBeReturnedViaImplicitInterface( 999 std::string *whyNot) const { 1000 if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) { 1001 if (whyNot) { 1002 *whyNot = "the function result is a pointer or allocatable"; 1003 } 1004 return false; // 15.4.2.2(4)(b) 1005 } else if (cudaDataAttr) { 1006 if (whyNot) { 1007 *whyNot = "the function result has CUDA attributes"; 1008 } 1009 return false; 1010 } else if (const auto *typeAndShape{GetTypeAndShape()}) { 1011 if (typeAndShape->Rank() > 0) { 1012 if (whyNot) { 1013 *whyNot = "the function result is an array"; 1014 } 1015 return false; // 15.4.2.2(4)(a) 1016 } else { 1017 const DynamicType &type{typeAndShape->type()}; 1018 switch (type.category()) { 1019 case TypeCategory::Character: 1020 if (type.knownLength()) { 1021 return true; 1022 } else if (const auto *param{type.charLengthParamValue()}) { 1023 if (const auto &expr{param->GetExplicit()}) { 1024 if (IsConstantExpr(*expr)) { // 15.4.2.2(4)(c) 1025 return true; 1026 } else { 1027 if (whyNot) { 1028 *whyNot = "the function result's length is not constant"; 1029 } 1030 return false; 1031 } 1032 } else if (param->isAssumed()) { 1033 return true; 1034 } 1035 } 1036 if (whyNot) { 1037 *whyNot = "the function result's length is not known to the caller"; 1038 } 1039 return false; 1040 case TypeCategory::Derived: 1041 if (type.IsPolymorphic()) { 1042 if (whyNot) { 1043 *whyNot = "the function result is polymorphic"; 1044 } 1045 return false; 1046 } else { 1047 const auto &spec{type.GetDerivedTypeSpec()}; 1048 for (const auto &pair : spec.parameters()) { 1049 if (const auto &expr{pair.second.GetExplicit()}) { 1050 if (!IsConstantExpr(*expr)) { 1051 if (whyNot) { 1052 *whyNot = "the function result's derived type has a " 1053 "non-constant parameter"; 1054 } 1055 return false; // 15.4.2.2(4)(c) 1056 } 1057 } 1058 } 1059 return true; 1060 } 1061 default: 1062 return true; 1063 } 1064 } 1065 } else { 1066 if (whyNot) { 1067 *whyNot = "the function result has unknown type or shape"; 1068 } 1069 return false; // 15.4.2.2(4)(b) - procedure pointer? 1070 } 1071 } 1072 1073 static std::optional<std::string> AreIncompatibleFunctionResultShapes( 1074 const Shape &x, const Shape &y) { 1075 int rank{GetRank(x)}; 1076 if (int yrank{GetRank(y)}; yrank != rank) { 1077 return "rank "s + std::to_string(rank) + " vs " + std::to_string(yrank); 1078 } 1079 for (int j{0}; j < rank; ++j) { 1080 if (x[j] && y[j] && !(*x[j] == *y[j])) { 1081 return x[j]->AsFortran() + " vs " + y[j]->AsFortran(); 1082 } 1083 } 1084 return std::nullopt; 1085 } 1086 1087 bool FunctionResult::IsCompatibleWith( 1088 const FunctionResult &actual, std::string *whyNot) const { 1089 Attrs actualAttrs{actual.attrs}; 1090 if (!attrs.test(Attr::Contiguous)) { 1091 actualAttrs.reset(Attr::Contiguous); 1092 } 1093 if (attrs != actualAttrs) { 1094 if (whyNot) { 1095 *whyNot = "function results have incompatible attributes"; 1096 } 1097 } else if (cudaDataAttr != actual.cudaDataAttr) { 1098 if (whyNot) { 1099 *whyNot = "function results have incompatible CUDA data attributes"; 1100 } 1101 } else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) { 1102 if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) { 1103 std::optional<std::string> details; 1104 if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) { 1105 if (whyNot) { 1106 *whyNot = "function results have distinct ranks"; 1107 } 1108 } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) && 1109 (details = AreIncompatibleFunctionResultShapes( 1110 ifaceTypeShape->shape(), actualTypeShape->shape()))) { 1111 if (whyNot) { 1112 *whyNot = "function results have distinct extents (" + *details + ')'; 1113 } 1114 } else if (ifaceTypeShape->type() != actualTypeShape->type()) { 1115 if (ifaceTypeShape->type().category() != 1116 actualTypeShape->type().category()) { 1117 } else if (ifaceTypeShape->type().category() == 1118 TypeCategory::Character) { 1119 if (ifaceTypeShape->type().kind() == actualTypeShape->type().kind()) { 1120 if (IsAssumedLengthCharacter() || 1121 actual.IsAssumedLengthCharacter()) { 1122 return true; 1123 } else { 1124 auto len{ToInt64(ifaceTypeShape->LEN())}; 1125 auto actualLen{ToInt64(actualTypeShape->LEN())}; 1126 if (len.has_value() != actualLen.has_value()) { 1127 if (whyNot) { 1128 *whyNot = "constant-length vs non-constant-length character " 1129 "results"; 1130 } 1131 } else if (len && *len != *actualLen) { 1132 if (whyNot) { 1133 *whyNot = "character results with distinct lengths"; 1134 } 1135 } else { 1136 const auto *ifaceLenParam{ 1137 ifaceTypeShape->type().charLengthParamValue()}; 1138 const auto *actualLenParam{ 1139 actualTypeShape->type().charLengthParamValue()}; 1140 if (ifaceLenParam && actualLenParam && 1141 ifaceLenParam->isExplicit() != 1142 actualLenParam->isExplicit()) { 1143 if (whyNot) { 1144 *whyNot = 1145 "explicit-length vs deferred-length character results"; 1146 } 1147 } else { 1148 return true; 1149 } 1150 } 1151 } 1152 } 1153 } else if (ifaceTypeShape->type().category() == TypeCategory::Derived) { 1154 if (ifaceTypeShape->type().IsPolymorphic() == 1155 actualTypeShape->type().IsPolymorphic() && 1156 !ifaceTypeShape->type().IsUnlimitedPolymorphic() && 1157 !actualTypeShape->type().IsUnlimitedPolymorphic() && 1158 AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(), 1159 actualTypeShape->type().GetDerivedTypeSpec())) { 1160 return true; 1161 } 1162 } 1163 if (whyNot) { 1164 *whyNot = "function results have distinct types: "s + 1165 ifaceTypeShape->type().AsFortran() + " vs "s + 1166 actualTypeShape->type().AsFortran(); 1167 } 1168 } else { 1169 return true; 1170 } 1171 } else { 1172 if (whyNot) { 1173 *whyNot = "function result type and shape are not known"; 1174 } 1175 } 1176 } else { 1177 const auto *ifaceProc{std::get_if<CopyableIndirection<Procedure>>(&u)}; 1178 CHECK(ifaceProc != nullptr); 1179 if (const auto *actualProc{ 1180 std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) { 1181 if (ifaceProc->value().IsCompatibleWith(actualProc->value(), whyNot)) { 1182 return true; 1183 } 1184 if (whyNot) { 1185 *whyNot = 1186 "function results are incompatible procedure pointers: "s + *whyNot; 1187 } 1188 } else { 1189 if (whyNot) { 1190 *whyNot = 1191 "one function result is a procedure pointer, the other is not"; 1192 } 1193 } 1194 } 1195 return false; 1196 } 1197 1198 llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const { 1199 attrs.Dump(o, EnumToString); 1200 common::visit(common::visitors{ 1201 [&](const TypeAndShape &ts) { ts.Dump(o); }, 1202 [&](const CopyableIndirection<Procedure> &p) { 1203 p.value().Dump(o << " procedure(") << ')'; 1204 }, 1205 }, 1206 u); 1207 if (cudaDataAttr) { 1208 o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr); 1209 } 1210 return o; 1211 } 1212 1213 Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a) 1214 : functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} { 1215 } 1216 Procedure::Procedure(DummyArguments &&args, Attrs a) 1217 : dummyArguments{std::move(args)}, attrs{a} {} 1218 Procedure::~Procedure() {} 1219 1220 bool Procedure::operator==(const Procedure &that) const { 1221 return attrs == that.attrs && functionResult == that.functionResult && 1222 dummyArguments == that.dummyArguments && 1223 cudaSubprogramAttrs == that.cudaSubprogramAttrs; 1224 } 1225 1226 bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot, 1227 const SpecificIntrinsic *specificIntrinsic, 1228 std::optional<std::string> *warning) const { 1229 // 15.5.2.9(1): if dummy is not pure, actual need not be. 1230 // Ditto with elemental. 1231 Attrs actualAttrs{actual.attrs}; 1232 if (!attrs.test(Attr::Pure)) { 1233 actualAttrs.reset(Attr::Pure); 1234 } 1235 if (!attrs.test(Attr::Elemental) && specificIntrinsic) { 1236 actualAttrs.reset(Attr::Elemental); 1237 } 1238 Attrs differences{attrs ^ actualAttrs}; 1239 differences.reset(Attr::Subroutine); // dealt with specifically later 1240 if (!differences.empty()) { 1241 if (whyNot) { 1242 auto sep{": "s}; 1243 *whyNot = "incompatible procedure attributes"; 1244 differences.IterateOverMembers([&](Attr x) { 1245 *whyNot += sep + std::string{EnumToString(x)}; 1246 sep = ", "; 1247 }); 1248 } 1249 } else if ((IsFunction() && actual.IsSubroutine()) || 1250 (IsSubroutine() && actual.IsFunction())) { 1251 if (whyNot) { 1252 *whyNot = 1253 "incompatible procedures: one is a function, the other a subroutine"; 1254 } 1255 } else if (functionResult && actual.functionResult && 1256 !functionResult->IsCompatibleWith(*actual.functionResult, whyNot)) { 1257 } else if (cudaSubprogramAttrs != actual.cudaSubprogramAttrs) { 1258 if (whyNot) { 1259 *whyNot = "incompatible CUDA subprogram attributes"; 1260 } 1261 } else if (dummyArguments.size() != actual.dummyArguments.size()) { 1262 if (whyNot) { 1263 *whyNot = "distinct numbers of dummy arguments"; 1264 } 1265 } else { 1266 for (std::size_t j{0}; j < dummyArguments.size(); ++j) { 1267 // Subtlety: the dummy/actual distinction must be reversed for this 1268 // compatibility test in order to correctly check extended vs. 1269 // base types. Example: 1270 // subroutine s1(base); subroutine s2(extended) 1271 // procedure(s1), pointer :: p 1272 // p => s2 ! an error, s2 is more restricted, can't handle "base" 1273 std::optional<std::string> gotWarning; 1274 if (!actual.dummyArguments[j].IsCompatibleWith( 1275 dummyArguments[j], whyNot, warning ? &gotWarning : nullptr)) { 1276 if (whyNot) { 1277 *whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) + 1278 ": "s + *whyNot; 1279 } 1280 return false; 1281 } else if (warning && !*warning && gotWarning) { 1282 *warning = "possibly incompatible dummy argument #"s + 1283 std::to_string(j + 1) + ": "s + std::move(*gotWarning); 1284 } 1285 } 1286 return true; 1287 } 1288 return false; 1289 } 1290 1291 int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const { 1292 int argCount{static_cast<int>(dummyArguments.size())}; 1293 int index{0}; 1294 if (name) { 1295 while (index < argCount && *name != dummyArguments[index].name.c_str()) { 1296 ++index; 1297 } 1298 } 1299 CHECK(index < argCount); 1300 return index; 1301 } 1302 1303 bool Procedure::CanOverride( 1304 const Procedure &that, std::optional<int> passIndex) const { 1305 // A pure procedure may override an impure one (7.5.7.3(2)) 1306 if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) || 1307 that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) || 1308 functionResult != that.functionResult) { 1309 return false; 1310 } 1311 int argCount{static_cast<int>(dummyArguments.size())}; 1312 if (argCount != static_cast<int>(that.dummyArguments.size())) { 1313 return false; 1314 } 1315 for (int j{0}; j < argCount; ++j) { 1316 if (passIndex && j == *passIndex) { 1317 if (!that.dummyArguments[j].IsCompatibleWith(dummyArguments[j])) { 1318 return false; 1319 } 1320 } else if (dummyArguments[j] != that.dummyArguments[j]) { 1321 return false; 1322 } 1323 } 1324 return true; 1325 } 1326 1327 std::optional<Procedure> Procedure::Characterize( 1328 const semantics::Symbol &original, FoldingContext &context) { 1329 semantics::UnorderedSymbolSet seenProcs; 1330 return CharacterizeProcedure(original, context, seenProcs); 1331 } 1332 1333 std::optional<Procedure> Procedure::Characterize( 1334 const ProcedureDesignator &proc, FoldingContext &context) { 1335 if (const auto *symbol{proc.GetSymbol()}) { 1336 if (auto result{ 1337 characteristics::Procedure::Characterize(*symbol, context)}) { 1338 return result; 1339 } 1340 } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) { 1341 return intrinsic->characteristics.value(); 1342 } 1343 return std::nullopt; 1344 } 1345 1346 std::optional<Procedure> Procedure::Characterize( 1347 const ProcedureRef &ref, FoldingContext &context) { 1348 if (auto callee{Characterize(ref.proc(), context)}) { 1349 if (callee->functionResult) { 1350 if (const Procedure * 1351 proc{callee->functionResult->IsProcedurePointer()}) { 1352 return {*proc}; 1353 } 1354 } 1355 } 1356 return std::nullopt; 1357 } 1358 1359 std::optional<Procedure> Procedure::Characterize( 1360 const Expr<SomeType> &expr, FoldingContext &context) { 1361 if (const auto *procRef{UnwrapProcedureRef(expr)}) { 1362 return Characterize(*procRef, context); 1363 } else if (const auto *procDesignator{ 1364 std::get_if<ProcedureDesignator>(&expr.u)}) { 1365 return Characterize(*procDesignator, context); 1366 } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) { 1367 return Characterize(*symbol, context); 1368 } else { 1369 context.messages().Say( 1370 "Expression '%s' is not a procedure"_err_en_US, expr.AsFortran()); 1371 return std::nullopt; 1372 } 1373 } 1374 1375 std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc, 1376 const ActualArguments &args, FoldingContext &context) { 1377 auto callee{Characterize(proc, context)}; 1378 if (callee) { 1379 if (callee->dummyArguments.empty() && 1380 callee->attrs.test(Procedure::Attr::ImplicitInterface)) { 1381 int j{0}; 1382 for (const auto &arg : args) { 1383 ++j; 1384 if (arg) { 1385 if (auto dummy{DummyArgument::FromActual("x"s + std::to_string(j), 1386 *arg, context, 1387 /*forImplicitInterface=*/true)}) { 1388 callee->dummyArguments.emplace_back(std::move(*dummy)); 1389 continue; 1390 } 1391 } 1392 callee.reset(); 1393 break; 1394 } 1395 } 1396 } 1397 return callee; 1398 } 1399 1400 bool Procedure::CanBeCalledViaImplicitInterface(std::string *whyNot) const { 1401 if (attrs.test(Attr::Elemental)) { 1402 if (whyNot) { 1403 *whyNot = "the procedure is elemental"; 1404 } 1405 return false; // 15.4.2.2(5,6) 1406 } else if (attrs.test(Attr::BindC)) { 1407 if (whyNot) { 1408 *whyNot = "the procedure is BIND(C)"; 1409 } 1410 return false; // 15.4.2.2(5,6) 1411 } else if (cudaSubprogramAttrs && 1412 *cudaSubprogramAttrs != common::CUDASubprogramAttrs::Host && 1413 *cudaSubprogramAttrs != common::CUDASubprogramAttrs::Global) { 1414 if (whyNot) { 1415 *whyNot = "the procedure is CUDA but neither HOST nor GLOBAL"; 1416 } 1417 return false; 1418 } else if (IsFunction() && 1419 !functionResult->CanBeReturnedViaImplicitInterface(whyNot)) { 1420 return false; 1421 } else { 1422 for (const DummyArgument &arg : dummyArguments) { 1423 if (!arg.CanBePassedViaImplicitInterface(whyNot)) { 1424 return false; 1425 } 1426 } 1427 return true; 1428 } 1429 } 1430 1431 llvm::raw_ostream &Procedure::Dump(llvm::raw_ostream &o) const { 1432 attrs.Dump(o, EnumToString); 1433 if (functionResult) { 1434 functionResult->Dump(o << "TYPE(") << ") FUNCTION"; 1435 } else if (attrs.test(Attr::Subroutine)) { 1436 o << "SUBROUTINE"; 1437 } else { 1438 o << "EXTERNAL"; 1439 } 1440 char sep{'('}; 1441 for (const auto &dummy : dummyArguments) { 1442 dummy.Dump(o << sep); 1443 sep = ','; 1444 } 1445 o << (sep == '(' ? "()" : ")"); 1446 if (cudaSubprogramAttrs) { 1447 o << " cudaSubprogramAttrs: " << common::EnumToString(*cudaSubprogramAttrs); 1448 } 1449 return o; 1450 } 1451 1452 // Utility class to determine if Procedures, etc. are distinguishable 1453 class DistinguishUtils { 1454 public: 1455 explicit DistinguishUtils(const common::LanguageFeatureControl &features) 1456 : features_{features} {} 1457 1458 // Are these procedures distinguishable for a generic name? 1459 std::optional<bool> Distinguishable( 1460 const Procedure &, const Procedure &) const; 1461 // Are these procedures distinguishable for a generic operator or assignment? 1462 std::optional<bool> DistinguishableOpOrAssign( 1463 const Procedure &, const Procedure &) const; 1464 1465 private: 1466 struct CountDummyProcedures { 1467 CountDummyProcedures(const DummyArguments &args) { 1468 for (const DummyArgument &arg : args) { 1469 if (std::holds_alternative<DummyProcedure>(arg.u)) { 1470 total += 1; 1471 notOptional += !arg.IsOptional(); 1472 } 1473 } 1474 } 1475 int total{0}; 1476 int notOptional{0}; 1477 }; 1478 1479 bool AnyOptionalData(const DummyArguments &) const; 1480 bool AnyUnlimitedPolymorphicData(const DummyArguments &) const; 1481 bool Rule3Distinguishable(const Procedure &, const Procedure &) const; 1482 const DummyArgument *Rule1DistinguishingArg( 1483 const DummyArguments &, const DummyArguments &) const; 1484 int FindFirstToDistinguishByPosition( 1485 const DummyArguments &, const DummyArguments &) const; 1486 int FindLastToDistinguishByName( 1487 const DummyArguments &, const DummyArguments &) const; 1488 int CountCompatibleWith(const DummyArgument &, const DummyArguments &) const; 1489 int CountNotDistinguishableFrom( 1490 const DummyArgument &, const DummyArguments &) const; 1491 bool Distinguishable(const DummyArgument &, const DummyArgument &) const; 1492 bool Distinguishable(const DummyDataObject &, const DummyDataObject &) const; 1493 bool Distinguishable(const DummyProcedure &, const DummyProcedure &) const; 1494 bool Distinguishable(const FunctionResult &, const FunctionResult &) const; 1495 bool Distinguishable( 1496 const TypeAndShape &, const TypeAndShape &, common::IgnoreTKRSet) const; 1497 bool IsTkrCompatible(const DummyArgument &, const DummyArgument &) const; 1498 bool IsTkCompatible(const DummyDataObject &, const DummyDataObject &) const; 1499 const DummyArgument *GetAtEffectivePosition( 1500 const DummyArguments &, int) const; 1501 const DummyArgument *GetPassArg(const Procedure &) const; 1502 1503 const common::LanguageFeatureControl &features_; 1504 }; 1505 1506 // Simpler distinguishability rules for operators and assignment 1507 std::optional<bool> DistinguishUtils::DistinguishableOpOrAssign( 1508 const Procedure &proc1, const Procedure &proc2) const { 1509 if ((proc1.IsFunction() && proc2.IsSubroutine()) || 1510 (proc1.IsSubroutine() && proc2.IsFunction())) { 1511 return true; 1512 } 1513 auto &args1{proc1.dummyArguments}; 1514 auto &args2{proc2.dummyArguments}; 1515 if (args1.size() != args2.size()) { 1516 return true; // C1511: distinguishable based on number of arguments 1517 } 1518 for (std::size_t i{0}; i < args1.size(); ++i) { 1519 if (Distinguishable(args1[i], args2[i])) { 1520 return true; // C1511, C1512: distinguishable based on this arg 1521 } 1522 } 1523 return false; 1524 } 1525 1526 std::optional<bool> DistinguishUtils::Distinguishable( 1527 const Procedure &proc1, const Procedure &proc2) const { 1528 if ((proc1.IsFunction() && proc2.IsSubroutine()) || 1529 (proc1.IsSubroutine() && proc2.IsFunction())) { 1530 return true; 1531 } 1532 auto &args1{proc1.dummyArguments}; 1533 auto &args2{proc2.dummyArguments}; 1534 auto count1{CountDummyProcedures(args1)}; 1535 auto count2{CountDummyProcedures(args2)}; 1536 if (count1.notOptional > count2.total || count2.notOptional > count1.total) { 1537 return true; // distinguishable based on C1514 rule 2 1538 } 1539 if (Rule3Distinguishable(proc1, proc2)) { 1540 return true; // distinguishable based on C1514 rule 3 1541 } 1542 if (Rule1DistinguishingArg(args1, args2)) { 1543 return true; // distinguishable based on C1514 rule 1 1544 } 1545 int pos1{FindFirstToDistinguishByPosition(args1, args2)}; 1546 int name1{FindLastToDistinguishByName(args1, args2)}; 1547 if (pos1 >= 0 && pos1 <= name1) { 1548 return true; // distinguishable based on C1514 rule 4 1549 } 1550 int pos2{FindFirstToDistinguishByPosition(args2, args1)}; 1551 int name2{FindLastToDistinguishByName(args2, args1)}; 1552 if (pos2 >= 0 && pos2 <= name2) { 1553 return true; // distinguishable based on C1514 rule 4 1554 } 1555 if (proc1.cudaSubprogramAttrs != proc2.cudaSubprogramAttrs) { 1556 return true; 1557 } 1558 // If there are no optional or unlimited polymorphic dummy arguments, 1559 // then we know the result for sure; otherwise, it's possible for 1560 // the procedures to be unambiguous. 1561 if ((AnyOptionalData(args1) || AnyUnlimitedPolymorphicData(args1)) && 1562 (AnyOptionalData(args2) || AnyUnlimitedPolymorphicData(args2))) { 1563 return std::nullopt; // meaning "maybe" 1564 } else { 1565 return false; 1566 } 1567 } 1568 1569 bool DistinguishUtils::AnyOptionalData(const DummyArguments &args) const { 1570 for (const auto &arg : args) { 1571 if (std::holds_alternative<DummyDataObject>(arg.u) && arg.IsOptional()) { 1572 return true; 1573 } 1574 } 1575 return false; 1576 } 1577 1578 bool DistinguishUtils::AnyUnlimitedPolymorphicData( 1579 const DummyArguments &args) const { 1580 for (const auto &arg : args) { 1581 if (const auto *object{std::get_if<DummyDataObject>(&arg.u)}) { 1582 if (object->type.type().IsUnlimitedPolymorphic()) { 1583 return true; 1584 } 1585 } 1586 } 1587 return false; 1588 } 1589 1590 // C1514 rule 3: Procedures are distinguishable if both have a passed-object 1591 // dummy argument and those are distinguishable. 1592 bool DistinguishUtils::Rule3Distinguishable( 1593 const Procedure &proc1, const Procedure &proc2) const { 1594 const DummyArgument *pass1{GetPassArg(proc1)}; 1595 const DummyArgument *pass2{GetPassArg(proc2)}; 1596 return pass1 && pass2 && Distinguishable(*pass1, *pass2); 1597 } 1598 1599 // Find a non-passed-object dummy data object in one of the argument lists 1600 // that satisfies C1514 rule 1. I.e. x such that: 1601 // - m is the number of dummy data objects in one that are nonoptional, 1602 // are not passed-object, that x is TKR compatible with 1603 // - n is the number of non-passed-object dummy data objects, in the other 1604 // that are not distinguishable from x 1605 // - m is greater than n 1606 const DummyArgument *DistinguishUtils::Rule1DistinguishingArg( 1607 const DummyArguments &args1, const DummyArguments &args2) const { 1608 auto size1{args1.size()}; 1609 auto size2{args2.size()}; 1610 for (std::size_t i{0}; i < size1 + size2; ++i) { 1611 const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]}; 1612 if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) { 1613 if (CountCompatibleWith(x, args1) > 1614 CountNotDistinguishableFrom(x, args2) || 1615 CountCompatibleWith(x, args2) > 1616 CountNotDistinguishableFrom(x, args1)) { 1617 return &x; 1618 } 1619 } 1620 } 1621 return nullptr; 1622 } 1623 1624 // Find the index of the first nonoptional non-passed-object dummy argument 1625 // in args1 at an effective position such that either: 1626 // - args2 has no dummy argument at that effective position 1627 // - the dummy argument at that position is distinguishable from it 1628 int DistinguishUtils::FindFirstToDistinguishByPosition( 1629 const DummyArguments &args1, const DummyArguments &args2) const { 1630 int effective{0}; // position of arg1 in list, ignoring passed arg 1631 for (std::size_t i{0}; i < args1.size(); ++i) { 1632 const DummyArgument &arg1{args1.at(i)}; 1633 if (!arg1.pass && !arg1.IsOptional()) { 1634 const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)}; 1635 if (!arg2 || Distinguishable(arg1, *arg2)) { 1636 return i; 1637 } 1638 } 1639 effective += !arg1.pass; 1640 } 1641 return -1; 1642 } 1643 1644 // Find the index of the last nonoptional non-passed-object dummy argument 1645 // in args1 whose name is such that either: 1646 // - args2 has no dummy argument with that name 1647 // - the dummy argument with that name is distinguishable from it 1648 int DistinguishUtils::FindLastToDistinguishByName( 1649 const DummyArguments &args1, const DummyArguments &args2) const { 1650 std::map<std::string, const DummyArgument *> nameToArg; 1651 for (const auto &arg2 : args2) { 1652 nameToArg.emplace(arg2.name, &arg2); 1653 } 1654 for (int i = args1.size() - 1; i >= 0; --i) { 1655 const DummyArgument &arg1{args1.at(i)}; 1656 if (!arg1.pass && !arg1.IsOptional()) { 1657 auto it{nameToArg.find(arg1.name)}; 1658 if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) { 1659 return i; 1660 } 1661 } 1662 } 1663 return -1; 1664 } 1665 1666 // Count the dummy data objects in args that are nonoptional, are not 1667 // passed-object, and that x is TKR compatible with 1668 int DistinguishUtils::CountCompatibleWith( 1669 const DummyArgument &x, const DummyArguments &args) const { 1670 return llvm::count_if(args, [&](const DummyArgument &y) { 1671 return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y); 1672 }); 1673 } 1674 1675 // Return the number of dummy data objects in args that are not 1676 // distinguishable from x and not passed-object. 1677 int DistinguishUtils::CountNotDistinguishableFrom( 1678 const DummyArgument &x, const DummyArguments &args) const { 1679 return llvm::count_if(args, [&](const DummyArgument &y) { 1680 return !y.pass && std::holds_alternative<DummyDataObject>(y.u) && 1681 !Distinguishable(y, x); 1682 }); 1683 } 1684 1685 bool DistinguishUtils::Distinguishable( 1686 const DummyArgument &x, const DummyArgument &y) const { 1687 if (x.u.index() != y.u.index()) { 1688 return true; // different kind: data/proc/alt-return 1689 } 1690 return common::visit( 1691 common::visitors{ 1692 [&](const DummyDataObject &z) { 1693 return Distinguishable(z, std::get<DummyDataObject>(y.u)); 1694 }, 1695 [&](const DummyProcedure &z) { 1696 return Distinguishable(z, std::get<DummyProcedure>(y.u)); 1697 }, 1698 [&](const AlternateReturn &) { return false; }, 1699 }, 1700 x.u); 1701 } 1702 1703 bool DistinguishUtils::Distinguishable( 1704 const DummyDataObject &x, const DummyDataObject &y) const { 1705 using Attr = DummyDataObject::Attr; 1706 if (Distinguishable(x.type, y.type, x.ignoreTKR | y.ignoreTKR)) { 1707 return true; 1708 } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) && 1709 y.intent != common::Intent::In) { 1710 return true; 1711 } else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) && 1712 x.intent != common::Intent::In) { 1713 return true; 1714 } else if (!common::AreCompatibleCUDADataAttrs( 1715 x.cudaDataAttr, y.cudaDataAttr, x.ignoreTKR | y.ignoreTKR)) { 1716 return true; 1717 } else if (features_.IsEnabled( 1718 common::LanguageFeature::DistinguishableSpecifics) && 1719 (x.attrs.test(Attr::Allocatable) || x.attrs.test(Attr::Pointer)) && 1720 (y.attrs.test(Attr::Allocatable) || y.attrs.test(Attr::Pointer)) && 1721 (x.type.type().IsUnlimitedPolymorphic() != 1722 y.type.type().IsUnlimitedPolymorphic() || 1723 x.type.type().IsPolymorphic() != y.type.type().IsPolymorphic())) { 1724 // Extension: Per 15.5.2.5(2), an allocatable/pointer dummy and its 1725 // corresponding actual argument must both or neither be polymorphic, 1726 // and must both or neither be unlimited polymorphic. So when exactly 1727 // one of two dummy arguments is polymorphic or unlimited polymorphic, 1728 // any actual argument that is admissible to one of them cannot also match 1729 // the other one. 1730 return true; 1731 } else { 1732 return false; 1733 } 1734 } 1735 1736 bool DistinguishUtils::Distinguishable( 1737 const DummyProcedure &x, const DummyProcedure &y) const { 1738 const Procedure &xProc{x.procedure.value()}; 1739 const Procedure &yProc{y.procedure.value()}; 1740 if (Distinguishable(xProc, yProc).value_or(false)) { 1741 return true; 1742 } else { 1743 const std::optional<FunctionResult> &xResult{xProc.functionResult}; 1744 const std::optional<FunctionResult> &yResult{yProc.functionResult}; 1745 return xResult ? !yResult || Distinguishable(*xResult, *yResult) 1746 : yResult.has_value(); 1747 } 1748 } 1749 1750 bool DistinguishUtils::Distinguishable( 1751 const FunctionResult &x, const FunctionResult &y) const { 1752 if (x.u.index() != y.u.index()) { 1753 return true; // one is data object, one is procedure 1754 } 1755 if (x.cudaDataAttr != y.cudaDataAttr) { 1756 return true; 1757 } 1758 return common::visit( 1759 common::visitors{ 1760 [&](const TypeAndShape &z) { 1761 return Distinguishable( 1762 z, std::get<TypeAndShape>(y.u), common::IgnoreTKRSet{}); 1763 }, 1764 [&](const CopyableIndirection<Procedure> &z) { 1765 return Distinguishable(z.value(), 1766 std::get<CopyableIndirection<Procedure>>(y.u).value()) 1767 .value_or(false); 1768 }, 1769 }, 1770 x.u); 1771 } 1772 1773 bool DistinguishUtils::Distinguishable(const TypeAndShape &x, 1774 const TypeAndShape &y, common::IgnoreTKRSet ignoreTKR) const { 1775 if (!x.type().IsTkCompatibleWith(y.type(), ignoreTKR) && 1776 !y.type().IsTkCompatibleWith(x.type(), ignoreTKR)) { 1777 return true; 1778 } 1779 if (ignoreTKR.test(common::IgnoreTKR::Rank)) { 1780 } else if (x.attrs().test(TypeAndShape::Attr::AssumedRank) || 1781 y.attrs().test(TypeAndShape::Attr::AssumedRank)) { 1782 } else if (x.Rank() != y.Rank()) { 1783 return true; 1784 } 1785 return false; 1786 } 1787 1788 // Compatibility based on type, kind, and rank 1789 1790 bool DistinguishUtils::IsTkrCompatible( 1791 const DummyArgument &x, const DummyArgument &y) const { 1792 const auto *obj1{std::get_if<DummyDataObject>(&x.u)}; 1793 const auto *obj2{std::get_if<DummyDataObject>(&y.u)}; 1794 return obj1 && obj2 && IsTkCompatible(*obj1, *obj2) && 1795 (obj1->type.Rank() == obj2->type.Rank() || 1796 obj1->type.attrs().test(TypeAndShape::Attr::AssumedRank) || 1797 obj2->type.attrs().test(TypeAndShape::Attr::AssumedRank) || 1798 obj1->ignoreTKR.test(common::IgnoreTKR::Rank) || 1799 obj2->ignoreTKR.test(common::IgnoreTKR::Rank)); 1800 } 1801 1802 bool DistinguishUtils::IsTkCompatible( 1803 const DummyDataObject &x, const DummyDataObject &y) const { 1804 return x.type.type().IsTkCompatibleWith( 1805 y.type.type(), x.ignoreTKR | y.ignoreTKR); 1806 } 1807 1808 // Return the argument at the given index, ignoring the passed arg 1809 const DummyArgument *DistinguishUtils::GetAtEffectivePosition( 1810 const DummyArguments &args, int index) const { 1811 for (const DummyArgument &arg : args) { 1812 if (!arg.pass) { 1813 if (index == 0) { 1814 return &arg; 1815 } 1816 --index; 1817 } 1818 } 1819 return nullptr; 1820 } 1821 1822 // Return the passed-object dummy argument of this procedure, if any 1823 const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) const { 1824 for (const auto &arg : proc.dummyArguments) { 1825 if (arg.pass) { 1826 return &arg; 1827 } 1828 } 1829 return nullptr; 1830 } 1831 1832 std::optional<bool> Distinguishable( 1833 const common::LanguageFeatureControl &features, const Procedure &x, 1834 const Procedure &y) { 1835 return DistinguishUtils{features}.Distinguishable(x, y); 1836 } 1837 1838 std::optional<bool> DistinguishableOpOrAssign( 1839 const common::LanguageFeatureControl &features, const Procedure &x, 1840 const Procedure &y) { 1841 return DistinguishUtils{features}.DistinguishableOpOrAssign(x, y); 1842 } 1843 1844 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument) 1845 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure) 1846 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult) 1847 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure) 1848 } // namespace Fortran::evaluate::characteristics 1849 1850 template class Fortran::common::Indirection< 1851 Fortran::evaluate::characteristics::Procedure, true>; 1852