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