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