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