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