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