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