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