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