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