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