xref: /llvm-project/flang/lib/Evaluate/characteristics.cpp (revision 61b1390e2afccac4c64f491f761d25f78b225ac4) 
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 <initializer_list>
20 #include <ostream>
21 
22 using namespace Fortran::parser::literals;
23 
24 namespace Fortran::evaluate::characteristics {
25 
26 // Copy attributes from a symbol to dst based on the mapping in pairs.
27 template<typename A, typename B>
28 static void CopyAttrs(const semantics::Symbol &src, A &dst,
29     const std::initializer_list<std::pair<semantics::Attr, B>> &pairs) {
30   for (const auto &pair : pairs) {
31     if (src.attrs().test(pair.first)) {
32       dst.attrs.set(pair.second);
33     }
34   }
35 }
36 
37 // Shapes of function results and dummy arguments have to have
38 // the same rank, the same deferred dimensions, and the same
39 // values for explicit dimensions when constant.
40 bool ShapesAreCompatible(const Shape &x, const Shape &y) {
41   if (x.size() != y.size()) {
42     return false;
43   }
44   auto yIter{y.begin()};
45   for (const auto &xDim : x) {
46     const auto &yDim{*yIter++};
47     if (xDim) {
48       if (!yDim || ToInt64(*xDim) != ToInt64(*yDim)) {
49         return false;
50       }
51     } else if (yDim) {
52       return false;
53     }
54   }
55   return true;
56 }
57 
58 bool TypeAndShape::operator==(const TypeAndShape &that) const {
59   return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) &&
60       attrs_ == that.attrs_ && corank_ == that.corank_;
61 }
62 
63 std::optional<TypeAndShape> TypeAndShape::Characterize(
64     const semantics::Symbol &symbol, FoldingContext &context) {
65   return std::visit(
66       common::visitors{
67           [&](const semantics::ObjectEntityDetails &object) {
68             return Characterize(object);
69           },
70           [&](const semantics::ProcEntityDetails &proc) {
71             const semantics::ProcInterface &interface{proc.interface()};
72             if (interface.type()) {
73               return Characterize(*interface.type());
74             } else if (interface.symbol()) {
75               return Characterize(*interface.symbol(), context);
76             } else {
77               return std::optional<TypeAndShape>{};
78             }
79           },
80           [&](const semantics::UseDetails &use) {
81             return Characterize(use.symbol(), context);
82           },
83           [&](const semantics::HostAssocDetails &assoc) {
84             return Characterize(assoc.symbol(), context);
85           },
86           [&](const semantics::AssocEntityDetails &assoc) {
87             return Characterize(assoc, context);
88           },
89           [](const auto &) { return std::optional<TypeAndShape>{}; },
90       },
91       symbol.details());
92 }
93 
94 std::optional<TypeAndShape> TypeAndShape::Characterize(
95     const semantics::ObjectEntityDetails &object) {
96   if (auto type{DynamicType::From(object.type())}) {
97     TypeAndShape result{std::move(*type)};
98     result.AcquireShape(object);
99     return result;
100   } else {
101     return std::nullopt;
102   }
103 }
104 
105 std::optional<TypeAndShape> TypeAndShape::Characterize(
106     const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
107   if (auto type{DynamicType::From(assoc.type())}) {
108     if (auto shape{GetShape(context, assoc.expr())}) {
109       return TypeAndShape{std::move(*type), std::move(*shape)};
110     }
111   }
112   return std::nullopt;
113 }
114 
115 std::optional<TypeAndShape> TypeAndShape::Characterize(
116     const semantics::DeclTypeSpec &spec) {
117   if (auto type{DynamicType::From(spec)}) {
118     return TypeAndShape{std::move(*type)};
119   } else {
120     return std::nullopt;
121   }
122 }
123 
124 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
125     const TypeAndShape &that, const char *thisIs, const char *thatIs,
126     bool isElemental) const {
127   const auto &len{that.LEN()};
128   if (!type_.IsTypeCompatibleWith(that.type_)) {
129     messages.Say(
130         "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
131         thatIs, that.type_.AsFortran(len ? len->AsFortran() : ""), thisIs,
132         type_.AsFortran());
133     return false;
134   }
135   return isElemental ||
136       CheckConformance(messages, shape_, that.shape_, thisIs, thatIs);
137 }
138 
139 void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
140   CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank));
141   corank_ = object.coshape().Rank();
142   if (object.IsAssumedRank()) {
143     attrs_.set(Attr::AssumedRank);
144     return;
145   }
146   if (object.IsAssumedShape()) {
147     attrs_.set(Attr::AssumedShape);
148   }
149   if (object.IsAssumedSize()) {
150     attrs_.set(Attr::AssumedSize);
151   }
152   if (object.IsDeferredShape()) {
153     attrs_.set(Attr::DeferredShape);
154   }
155   if (object.IsCoarray()) {
156     attrs_.set(Attr::Coarray);
157   }
158   for (const semantics::ShapeSpec &dim : object.shape()) {
159     if (dim.ubound().GetExplicit()) {
160       Expr<SubscriptInteger> extent{*dim.ubound().GetExplicit()};
161       if (auto lbound{dim.lbound().GetExplicit()}) {
162         extent =
163             std::move(extent) + Expr<SubscriptInteger>{1} - std::move(*lbound);
164       }
165       shape_.emplace_back(std::move(extent));
166     } else {
167       shape_.push_back(std::nullopt);
168     }
169   }
170 }
171 
172 void TypeAndShape::AcquireLEN() {
173   if (type_.category() == TypeCategory::Character) {
174     if (const auto *param{type_.charLength()}) {
175       if (const auto &intExpr{param->GetExplicit()}) {
176         LEN_ = *intExpr;
177       }
178     }
179   }
180 }
181 
182 std::ostream &TypeAndShape::Dump(std::ostream &o) const {
183   o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
184   attrs_.Dump(o, EnumToString);
185   if (!shape_.empty()) {
186     o << " dimension(";
187     char sep{'('};
188     for (const auto &expr : shape_) {
189       o << sep;
190       sep = ',';
191       if (expr) {
192         expr->AsFortran(o);
193       } else {
194         o << ':';
195       }
196     }
197     o << ')';
198   }
199   return o;
200 }
201 
202 bool DummyDataObject::operator==(const DummyDataObject &that) const {
203   return type == that.type && attrs == that.attrs && intent == that.intent &&
204       coshape == that.coshape;
205 }
206 
207 static common::Intent GetIntent(const semantics::Attrs &attrs) {
208   if (attrs.test(semantics::Attr::INTENT_IN)) {
209     return common::Intent::In;
210   } else if (attrs.test(semantics::Attr::INTENT_OUT)) {
211     return common::Intent::Out;
212   } else if (attrs.test(semantics::Attr::INTENT_INOUT)) {
213     return common::Intent::InOut;
214   } else {
215     return common::Intent::Default;
216   }
217 }
218 
219 std::optional<DummyDataObject> DummyDataObject::Characterize(
220     const semantics::Symbol &symbol) {
221   if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
222     if (auto type{TypeAndShape::Characterize(*obj)}) {
223       std::optional<DummyDataObject> result{std::move(*type)};
224       using semantics::Attr;
225       CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
226           {
227               {Attr::OPTIONAL, DummyDataObject::Attr::Optional},
228               {Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable},
229               {Attr::ASYNCHRONOUS, DummyDataObject::Attr::Asynchronous},
230               {Attr::CONTIGUOUS, DummyDataObject::Attr::Contiguous},
231               {Attr::VALUE, DummyDataObject::Attr::Value},
232               {Attr::VOLATILE, DummyDataObject::Attr::Volatile},
233               {Attr::POINTER, DummyDataObject::Attr::Pointer},
234               {Attr::TARGET, DummyDataObject::Attr::Target},
235           });
236       result->intent = GetIntent(symbol.attrs());
237       return result;
238     }
239   }
240   return std::nullopt;
241 }
242 
243 bool DummyDataObject::CanBePassedViaImplicitInterface() const {
244   if ((attrs &
245           Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional,
246               Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile})
247           .any()) {
248     return false;  // 15.4.2.2(3)(a)
249   } else if ((type.attrs() &
250                  TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape,
251                      TypeAndShape::Attr::AssumedRank,
252                      TypeAndShape::Attr::Coarray})
253                  .any()) {
254     return false;  // 15.4.2.2(3)(b-d)
255   } else if (type.type().IsPolymorphic()) {
256     return false;  // 15.4.2.2(3)(f)
257   } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) {
258     return derived->parameters().empty();  // 15.4.2.2(3)(e)
259   } else {
260     return true;
261   }
262 }
263 
264 std::ostream &DummyDataObject::Dump(std::ostream &o) const {
265   attrs.Dump(o, EnumToString);
266   if (intent != common::Intent::Default) {
267     o << "INTENT(" << common::EnumToString(intent) << ')';
268   }
269   type.Dump(o);
270   if (!coshape.empty()) {
271     char sep{'['};
272     for (const auto &expr : coshape) {
273       expr.AsFortran(o << sep);
274       sep = ',';
275     }
276   }
277   return o;
278 }
279 
280 DummyProcedure::DummyProcedure(Procedure &&p)
281   : procedure{new Procedure{std::move(p)}} {}
282 
283 bool DummyProcedure::operator==(const DummyProcedure &that) const {
284   return attrs == that.attrs && intent == that.intent &&
285       procedure.value() == that.procedure.value();
286 }
287 
288 std::optional<DummyProcedure> DummyProcedure::Characterize(
289     const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
290   if (auto procedure{Procedure::Characterize(symbol, intrinsics)}) {
291     // Dummy procedures may not be elemental.  Elemental dummy procedure
292     // interfaces are errors when the interface is not intrinsic, and that
293     // error is caught elsewhere.  Elemental intrinsic interfaces are
294     // made non-elemental.
295     procedure->attrs.reset(Procedure::Attr::Elemental);
296     DummyProcedure result{std::move(procedure.value())};
297     CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result,
298         {
299             {semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional},
300             {semantics::Attr::POINTER, DummyProcedure::Attr::Pointer},
301         });
302     result.intent = GetIntent(symbol.attrs());
303     return result;
304   } else {
305     return std::nullopt;
306   }
307 }
308 
309 std::ostream &DummyProcedure::Dump(std::ostream &o) const {
310   attrs.Dump(o, EnumToString);
311   if (intent != common::Intent::Default) {
312     o << "INTENT(" << common::EnumToString(intent) << ')';
313   }
314   procedure.value().Dump(o);
315   return o;
316 }
317 
318 std::ostream &AlternateReturn::Dump(std::ostream &o) const { return o << '*'; }
319 
320 DummyArgument::~DummyArgument() {}
321 
322 bool DummyArgument::operator==(const DummyArgument &that) const {
323   return u == that.u;  // name and passed-object usage are not characteristics
324 }
325 
326 std::optional<DummyArgument> DummyArgument::Characterize(
327     const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
328   auto name{symbol.name().ToString()};
329   if (symbol.has<semantics::ObjectEntityDetails>()) {
330     if (auto obj{DummyDataObject::Characterize(symbol)}) {
331       return DummyArgument{std::move(name), std::move(obj.value())};
332     }
333   } else if (auto proc{DummyProcedure::Characterize(symbol, intrinsics)}) {
334     return DummyArgument{std::move(name), std::move(proc.value())};
335   }
336   return std::nullopt;
337 }
338 
339 std::optional<DummyArgument> DummyArgument::FromActual(
340     std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
341   return std::visit(
342       common::visitors{
343           [&](const BOZLiteralConstant &) {
344             return std::make_optional<DummyArgument>(std::move(name),
345                 DummyDataObject{
346                     TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
347           },
348           [](const NullPointer &) { return std::optional<DummyArgument>{}; },
349           [&](const ProcedureDesignator &designator) {
350             if (auto proc{Procedure::Characterize(
351                     designator, context.intrinsics())}) {
352               return std::make_optional<DummyArgument>(
353                   std::move(name), DummyProcedure{std::move(*proc)});
354             } else {
355               return std::optional<DummyArgument>{};
356             }
357           },
358           [&](const ProcedureRef &call) {
359             if (auto proc{
360                     Procedure::Characterize(call, context.intrinsics())}) {
361               return std::make_optional<DummyArgument>(
362                   std::move(name), DummyProcedure{std::move(*proc)});
363             } else {
364               return std::optional<DummyArgument>{};
365             }
366           },
367           [&](const auto &) {
368             if (auto type{expr.GetType()}) {
369               if (auto shape{GetShape(context, expr)}) {
370                 return std::make_optional<DummyArgument>(std::move(name),
371                     DummyDataObject{TypeAndShape{*type, std::move(*shape)}});
372               } else {
373                 return std::make_optional<DummyArgument>(
374                     std::move(name), DummyDataObject{TypeAndShape{*type}});
375               }
376             } else {
377               return std::optional<DummyArgument>{};
378             }
379           },
380       },
381       expr.u);
382 }
383 
384 bool DummyArgument::IsOptional() const {
385   return std::visit(
386       common::visitors{
387           [](const DummyDataObject &data) {
388             return data.attrs.test(DummyDataObject::Attr::Optional);
389           },
390           [](const DummyProcedure &proc) {
391             return proc.attrs.test(DummyProcedure::Attr::Optional);
392           },
393           [](const AlternateReturn &) { return false; },
394       },
395       u);
396 }
397 
398 void DummyArgument::SetOptional(bool value) {
399   std::visit(
400       common::visitors{
401           [value](DummyDataObject &data) {
402             data.attrs.set(DummyDataObject::Attr::Optional, value);
403           },
404           [value](DummyProcedure &proc) {
405             proc.attrs.set(DummyProcedure::Attr::Optional, value);
406           },
407           [](AlternateReturn &) { DIE("cannot set optional"); },
408       },
409       u);
410 }
411 
412 bool DummyArgument::CanBePassedViaImplicitInterface() const {
413   if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
414     return object->CanBePassedViaImplicitInterface();
415   } else {
416     return true;
417   }
418 }
419 
420 std::ostream &DummyArgument::Dump(std::ostream &o) const {
421   if (!name.empty()) {
422     o << name << '=';
423   }
424   if (pass) {
425     o << " PASS";
426   }
427   std::visit([&](const auto &x) { x.Dump(o); }, u);
428   return o;
429 }
430 
431 FunctionResult::FunctionResult(DynamicType t) : u{TypeAndShape{t}} {}
432 FunctionResult::FunctionResult(TypeAndShape &&t) : u{std::move(t)} {}
433 FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {}
434 FunctionResult::~FunctionResult() {}
435 
436 bool FunctionResult::operator==(const FunctionResult &that) const {
437   return attrs == that.attrs && u == that.u;
438 }
439 
440 std::optional<FunctionResult> FunctionResult::Characterize(
441     const Symbol &symbol, const IntrinsicProcTable &intrinsics) {
442   if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
443     if (auto type{TypeAndShape::Characterize(*obj)}) {
444       FunctionResult result{std::move(*type)};
445       CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
446           {
447               {semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable},
448               {semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous},
449               {semantics::Attr::POINTER, FunctionResult::Attr::Pointer},
450           });
451       return result;
452     }
453   } else if (auto maybeProc{Procedure::Characterize(symbol, intrinsics)}) {
454     FunctionResult result{std::move(*maybeProc)};
455     result.attrs.set(FunctionResult::Attr::Pointer);
456     return result;
457   }
458   return std::nullopt;
459 }
460 
461 bool FunctionResult::IsAssumedLengthCharacter() const {
462   if (const auto *ts{std::get_if<TypeAndShape>(&u)}) {
463     return ts->type().IsAssumedLengthCharacter();
464   } else {
465     return false;
466   }
467 }
468 
469 bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
470   if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) {
471     return false;  // 15.4.2.2(4)(b)
472   } else if (const auto *typeAndShape{GetTypeAndShape()}) {
473     if (typeAndShape->Rank() > 0) {
474       return false;  // 15.4.2.2(4)(a)
475     } else {
476       const DynamicType &type{typeAndShape->type()};
477       switch (type.category()) {
478       case TypeCategory::Character:
479         if (const auto *param{type.charLength()}) {
480           if (const auto &expr{param->GetExplicit()}) {
481             return IsConstantExpr(*expr);  // 15.4.2.2(4)(c)
482           }
483         }
484         return false;
485       case TypeCategory::Derived:
486         if (!type.IsPolymorphic()) {
487           const auto &spec{type.GetDerivedTypeSpec()};
488           for (const auto &pair : spec.parameters()) {
489             if (const auto &expr{pair.second.GetExplicit()}) {
490               if (!IsConstantExpr(*expr)) {
491                 return false;  // 15.4.2.2(4)(c)
492               }
493             }
494           }
495           return true;
496         }
497         return false;
498       default: return true;
499       }
500     }
501   } else {
502     return false;  // 15.4.2.2(4)(b) - procedure pointer
503   }
504 }
505 
506 std::ostream &FunctionResult::Dump(std::ostream &o) const {
507   attrs.Dump(o, EnumToString);
508   std::visit(
509       common::visitors{
510           [&](const TypeAndShape &ts) { ts.Dump(o); },
511           [&](const CopyableIndirection<Procedure> &p) {
512             p.value().Dump(o << " procedure(") << ')';
513           },
514       },
515       u);
516   return o;
517 }
518 
519 Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
520   : functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {}
521 Procedure::Procedure(DummyArguments &&args, Attrs a)
522   : dummyArguments{std::move(args)}, attrs{a} {}
523 Procedure::~Procedure() {}
524 
525 bool Procedure::operator==(const Procedure &that) const {
526   return attrs == that.attrs && functionResult == that.functionResult &&
527       dummyArguments == that.dummyArguments;
528 }
529 
530 int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
531   int argCount{static_cast<int>(dummyArguments.size())};
532   int index{0};
533   if (name) {
534     while (index < argCount && *name != dummyArguments[index].name.c_str()) {
535       ++index;
536     }
537   }
538   CHECK(index < argCount);
539   return index;
540 }
541 
542 bool Procedure::CanOverride(
543     const Procedure &that, std::optional<int> passIndex) const {
544   // A pure procedure may override an impure one (7.5.7.3(2))
545   if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) ||
546       that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) ||
547       functionResult != that.functionResult) {
548     return false;
549   }
550   int argCount{static_cast<int>(dummyArguments.size())};
551   if (argCount != static_cast<int>(that.dummyArguments.size())) {
552     return false;
553   }
554   for (int j{0}; j < argCount; ++j) {
555     if ((!passIndex || j != *passIndex) &&
556         dummyArguments[j] != that.dummyArguments[j]) {
557       return false;
558     }
559   }
560   return true;
561 }
562 
563 std::optional<Procedure> Procedure::Characterize(
564     const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
565   Procedure result;
566   CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
567       {
568           {semantics::Attr::PURE, Procedure::Attr::Pure},
569           {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
570           {semantics::Attr::BIND_C, Procedure::Attr::BindC},
571       });
572   if (result.attrs.test(Attr::Elemental) &&
573       !symbol.attrs().test(semantics::Attr::IMPURE)) {
574     result.attrs.set(Attr::Pure);  // explicitly flag pure procedures
575   }
576   return std::visit(
577       common::visitors{
578           [&](const semantics::SubprogramDetails &subp)
579               -> std::optional<Procedure> {
580             if (subp.isFunction()) {
581               if (auto fr{FunctionResult::Characterize(
582                       subp.result(), intrinsics)}) {
583                 result.functionResult = std::move(fr);
584               } else {
585                 return std::nullopt;
586               }
587             } else {
588               result.attrs.set(Attr::Subroutine);
589             }
590             for (const semantics::Symbol *arg : subp.dummyArgs()) {
591               if (!arg) {
592                 result.dummyArguments.emplace_back(AlternateReturn{});
593               } else if (auto argCharacteristics{
594                              DummyArgument::Characterize(*arg, intrinsics)}) {
595                 result.dummyArguments.emplace_back(
596                     std::move(argCharacteristics.value()));
597               } else {
598                 return std::nullopt;
599               }
600             }
601             return result;
602           },
603           [&](const semantics::ProcEntityDetails &proc)
604               -> std::optional<Procedure> {
605             if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
606               return intrinsics.IsSpecificIntrinsicFunction(
607                   symbol.name().ToString());
608             }
609             const semantics::ProcInterface &interface{proc.interface()};
610             if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
611               return Characterize(*interfaceSymbol, intrinsics);
612             } else {
613               result.attrs.set(Attr::ImplicitInterface);
614               const semantics::DeclTypeSpec *type{interface.type()};
615               if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
616                 // ignore any implicit typing
617                 result.attrs.set(Attr::Subroutine);
618               } else if (type) {
619                 if (auto resultType{DynamicType::From(*type)}) {
620                   result.functionResult = FunctionResult{*resultType};
621                 } else {
622                   return std::nullopt;
623                 }
624               } else if (symbol.test(semantics::Symbol::Flag::Function)) {
625                 return std::nullopt;
626               }
627               // The PASS name, if any, is not a characteristic.
628               return result;
629             }
630           },
631           [&](const semantics::ProcBindingDetails &binding) {
632             if (auto result{Characterize(binding.symbol(), intrinsics)}) {
633               if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
634                 auto passName{binding.passName()};
635                 for (auto &dummy : result->dummyArguments) {
636                   if (!passName || dummy.name.c_str() == *passName) {
637                     dummy.pass = true;
638                     return result;
639                   }
640                 }
641                 DIE("PASS argument missing");
642               }
643               return result;
644             } else {
645               return std::optional<Procedure>{};
646             }
647           },
648           [&](const semantics::UseDetails &use) {
649             return Characterize(use.symbol(), intrinsics);
650           },
651           [&](const semantics::HostAssocDetails &assoc) {
652             return Characterize(assoc.symbol(), intrinsics);
653           },
654           [](const auto &) { return std::optional<Procedure>{}; },
655       },
656       symbol.details());
657 }
658 
659 std::optional<Procedure> Procedure::Characterize(
660     const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) {
661   if (const auto *symbol{proc.GetSymbol()}) {
662     if (auto result{characteristics::Procedure::Characterize(
663             ResolveAssociations(*symbol), intrinsics)}) {
664       return result;
665     }
666   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
667     return intrinsic->characteristics.value();
668   }
669   return std::nullopt;
670 }
671 
672 std::optional<Procedure> Procedure::Characterize(
673     const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) {
674   if (auto callee{Characterize(ref.proc(), intrinsics)}) {
675     if (callee->functionResult) {
676       if (const Procedure *
677           proc{callee->functionResult->IsProcedurePointer()}) {
678         return {*proc};
679       }
680     }
681   }
682   return std::nullopt;
683 }
684 
685 bool Procedure::CanBeCalledViaImplicitInterface() const {
686   if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) {
687     return false;  // 15.4.2.2(5,6)
688   } else if (IsFunction() &&
689       !functionResult->CanBeReturnedViaImplicitInterface()) {
690     return false;
691   } else {
692     for (const DummyArgument &arg : dummyArguments) {
693       if (!arg.CanBePassedViaImplicitInterface()) {
694         return false;
695       }
696     }
697     return true;
698   }
699 }
700 
701 std::ostream &Procedure::Dump(std::ostream &o) const {
702   attrs.Dump(o, EnumToString);
703   if (functionResult) {
704     functionResult->Dump(o << "TYPE(") << ") FUNCTION";
705   } else {
706     o << "SUBROUTINE";
707   }
708   char sep{'('};
709   for (const auto &dummy : dummyArguments) {
710     dummy.Dump(o << sep);
711     sep = ',';
712   }
713   return o << (sep == '(' ? "()" : ")");
714 }
715 
716 // Utility class to determine if Procedures, etc. are distinguishable
717 class DistinguishUtils {
718 public:
719   // Are these procedures distinguishable for a generic name?
720   static bool Distinguishable(const Procedure &, const Procedure &);
721   // Are these procedures distinguishable for a generic operator or assignment?
722   static bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);
723 
724 private:
725   struct CountDummyProcedures {
726     CountDummyProcedures(const DummyArguments &args) {
727       for (const DummyArgument &arg : args) {
728         if (std::holds_alternative<DummyProcedure>(arg.u)) {
729           total += 1;
730           notOptional += !arg.IsOptional();
731         }
732       }
733     }
734     int total{0};
735     int notOptional{0};
736   };
737 
738   static bool Rule3Distinguishable(const Procedure &, const Procedure &);
739   static const DummyArgument *Rule1DistinguishingArg(
740       const DummyArguments &, const DummyArguments &);
741   static int FindFirstToDistinguishByPosition(
742       const DummyArguments &, const DummyArguments &);
743   static int FindLastToDistinguishByName(
744       const DummyArguments &, const DummyArguments &);
745   static int CountCompatibleWith(const DummyArgument &, const DummyArguments &);
746   static int CountNotDistinguishableFrom(
747       const DummyArgument &, const DummyArguments &);
748   static bool Distinguishable(const DummyArgument &, const DummyArgument &);
749   static bool Distinguishable(const DummyDataObject &, const DummyDataObject &);
750   static bool Distinguishable(const DummyProcedure &, const DummyProcedure &);
751   static bool Distinguishable(const FunctionResult &, const FunctionResult &);
752   static bool Distinguishable(const TypeAndShape &, const TypeAndShape &);
753   static bool IsTkrCompatible(const DummyArgument &, const DummyArgument &);
754   static bool IsTkrCompatible(const TypeAndShape &, const TypeAndShape &);
755   static const DummyArgument *GetAtEffectivePosition(
756       const DummyArguments &, int);
757   static const DummyArgument *GetPassArg(const Procedure &);
758 };
759 
760 // Simpler distinguishability rules for operators and assignment
761 bool DistinguishUtils::DistinguishableOpOrAssign(
762     const Procedure &proc1, const Procedure &proc2) {
763   auto &args1{proc1.dummyArguments};
764   auto &args2{proc2.dummyArguments};
765   if (args1.size() != args2.size()) {
766     return true;  // C1511: distinguishable based on number of arguments
767   }
768   for (std::size_t i{0}; i < args1.size(); ++i) {
769     if (Distinguishable(args1[i], args2[i])) {
770       return true;  // C1511, C1512: distinguishable based on this arg
771     }
772   }
773   return false;
774 }
775 
776 bool DistinguishUtils::Distinguishable(
777     const Procedure &proc1, const Procedure &proc2) {
778   auto &args1{proc1.dummyArguments};
779   auto &args2{proc2.dummyArguments};
780   auto count1{CountDummyProcedures(args1)};
781   auto count2{CountDummyProcedures(args2)};
782   if (count1.notOptional > count2.total || count2.notOptional > count1.total) {
783     return true;  // distinguishable based on C1514 rule 2
784   }
785   if (Rule3Distinguishable(proc1, proc2)) {
786     return true;  // distinguishable based on C1514 rule 3
787   }
788   if (Rule1DistinguishingArg(args1, args2)) {
789     return true;  // distinguishable based on C1514 rule 1
790   }
791   int pos1{FindFirstToDistinguishByPosition(args1, args2)};
792   int name1{FindLastToDistinguishByName(args1, args2)};
793   if (pos1 >= 0 && pos1 <= name1) {
794     return true;  // distinguishable based on C1514 rule 4
795   }
796   int pos2{FindFirstToDistinguishByPosition(args2, args1)};
797   int name2{FindLastToDistinguishByName(args2, args1)};
798   if (pos2 >= 0 && pos2 <= name2) {
799     return true;  // distinguishable based on C1514 rule 4
800   }
801   return false;
802 }
803 
804 // C1514 rule 3: Procedures are distinguishable if both have a passed-object
805 // dummy argument and those are distinguishable.
806 bool DistinguishUtils::Rule3Distinguishable(
807     const Procedure &proc1, const Procedure &proc2) {
808   const DummyArgument *pass1{GetPassArg(proc1)};
809   const DummyArgument *pass2{GetPassArg(proc2)};
810   return pass1 && pass2 && Distinguishable(*pass1, *pass2);
811 }
812 
813 // Find a non-passed-object dummy data object in one of the argument lists
814 // that satisfies C1514 rule 1. I.e. x such that:
815 // - m is the number of dummy data objects in one that are nonoptional,
816 //   are not passed-object, that x is TKR compatible with
817 // - n is the number of non-passed-object dummy data objects, in the other
818 //   that are not distinguishable from x
819 // - m is greater than n
820 const DummyArgument *DistinguishUtils::Rule1DistinguishingArg(
821     const DummyArguments &args1, const DummyArguments &args2) {
822   auto size1{args1.size()};
823   auto size2{args2.size()};
824   for (std::size_t i{0}; i < size1 + size2; ++i) {
825     const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]};
826     if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) {
827       if (CountCompatibleWith(x, args1) >
828               CountNotDistinguishableFrom(x, args2) ||
829           CountCompatibleWith(x, args2) >
830               CountNotDistinguishableFrom(x, args1)) {
831         return &x;
832       }
833     }
834   }
835   return nullptr;
836 }
837 
838 // Find the index of the first nonoptional non-passed-object dummy argument
839 // in args1 at an effective position such that either:
840 // - args2 has no dummy argument at that effective position
841 // - the dummy argument at that position is distinguishable from it
842 int DistinguishUtils::FindFirstToDistinguishByPosition(
843     const DummyArguments &args1, const DummyArguments &args2) {
844   int effective{0};  // position of arg1 in list, ignoring passed arg
845   for (std::size_t i{0}; i < args1.size(); ++i) {
846     const DummyArgument &arg1{args1.at(i)};
847     if (!arg1.pass && !arg1.IsOptional()) {
848       const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)};
849       if (!arg2 || Distinguishable(arg1, *arg2)) {
850         return i;
851       }
852     }
853     effective += !arg1.pass;
854   }
855   return -1;
856 }
857 
858 // Find the index of the last nonoptional non-passed-object dummy argument
859 // in args1 whose name is such that either:
860 // - args2 has no dummy argument with that name
861 // - the dummy argument with that name is distinguishable from it
862 int DistinguishUtils::FindLastToDistinguishByName(
863     const DummyArguments &args1, const DummyArguments &args2) {
864   std::map<std::string, const DummyArgument *> nameToArg;
865   for (const auto &arg2 : args2) {
866     nameToArg.emplace(arg2.name, &arg2);
867   }
868   for (int i = args1.size() - 1; i >= 0; --i) {
869     const DummyArgument &arg1{args1.at(i)};
870     if (!arg1.pass && !arg1.IsOptional()) {
871       auto it{nameToArg.find(arg1.name)};
872       if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) {
873         return i;
874       }
875     }
876   }
877   return -1;
878 }
879 
880 // Count the dummy data objects in args that are nonoptional, are not
881 // passed-object, and that x is TKR compatible with
882 int DistinguishUtils::CountCompatibleWith(
883     const DummyArgument &x, const DummyArguments &args) {
884   return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) {
885     return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y);
886   });
887 }
888 
889 // Return the number of dummy data objects in args that are not
890 // distinguishable from x and not passed-object.
891 int DistinguishUtils::CountNotDistinguishableFrom(
892     const DummyArgument &x, const DummyArguments &args) {
893   return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) {
894     return !y.pass && std::holds_alternative<DummyDataObject>(y.u) &&
895         !Distinguishable(y, x);
896   });
897 }
898 
899 bool DistinguishUtils::Distinguishable(
900     const DummyArgument &x, const DummyArgument &y) {
901   if (x.u.index() != y.u.index()) {
902     return true;  // different kind: data/proc/alt-return
903   }
904   return std::visit(
905       common::visitors{
906           [&](const DummyDataObject &z) {
907             return Distinguishable(z, std::get<DummyDataObject>(y.u));
908           },
909           [&](const DummyProcedure &z) {
910             return Distinguishable(z, std::get<DummyProcedure>(y.u));
911           },
912           [&](const AlternateReturn &) { return false; },
913       },
914       x.u);
915 }
916 
917 bool DistinguishUtils::Distinguishable(
918     const DummyDataObject &x, const DummyDataObject &y) {
919   using Attr = DummyDataObject::Attr;
920   if (Distinguishable(x.type, y.type)) {
921     return true;
922   } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
923       y.intent != common::Intent::In) {
924     return true;
925   } else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) &&
926       x.intent != common::Intent::In) {
927     return true;
928   } else {
929     return false;
930   }
931 }
932 
933 bool DistinguishUtils::Distinguishable(
934     const DummyProcedure &x, const DummyProcedure &y) {
935   const Procedure &xProc{x.procedure.value()};
936   const Procedure &yProc{y.procedure.value()};
937   if (Distinguishable(xProc, yProc)) {
938     return true;
939   } else {
940     const std::optional<FunctionResult> &xResult{xProc.functionResult};
941     const std::optional<FunctionResult> &yResult{yProc.functionResult};
942     return xResult ? !yResult || Distinguishable(*xResult, *yResult)
943                    : yResult.has_value();
944   }
945 }
946 
947 bool DistinguishUtils::Distinguishable(
948     const FunctionResult &x, const FunctionResult &y) {
949   if (x.u.index() != y.u.index()) {
950     return true;  // one is data object, one is procedure
951   }
952   return std::visit(
953       common::visitors{
954           [&](const TypeAndShape &z) {
955             return Distinguishable(z, std::get<TypeAndShape>(y.u));
956           },
957           [&](const CopyableIndirection<Procedure> &z) {
958             return Distinguishable(z.value(),
959                 std::get<CopyableIndirection<Procedure>>(y.u).value());
960           },
961       },
962       x.u);
963 }
964 
965 bool DistinguishUtils::Distinguishable(
966     const TypeAndShape &x, const TypeAndShape &y) {
967   return !IsTkrCompatible(x, y) && !IsTkrCompatible(y, x);
968 }
969 
970 // Compatibility based on type, kind, and rank
971 bool DistinguishUtils::IsTkrCompatible(
972     const DummyArgument &x, const DummyArgument &y) {
973   const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
974   const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
975   return obj1 && obj2 && IsTkrCompatible(obj1->type, obj2->type);
976 }
977 bool DistinguishUtils::IsTkrCompatible(
978     const TypeAndShape &x, const TypeAndShape &y) {
979   return x.type().IsTkCompatibleWith(y.type()) &&
980       (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
981           y.attrs().test(TypeAndShape::Attr::AssumedRank) ||
982           x.Rank() == y.Rank());
983 }
984 
985 // Return the argument at the given index, ignoring the passed arg
986 const DummyArgument *DistinguishUtils::GetAtEffectivePosition(
987     const DummyArguments &args, int index) {
988   for (const DummyArgument &arg : args) {
989     if (!arg.pass) {
990       if (index == 0) {
991         return &arg;
992       }
993       --index;
994     }
995   }
996   return nullptr;
997 }
998 
999 // Return the passed-object dummy argument of this procedure, if any
1000 const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) {
1001   for (const auto &arg : proc.dummyArguments) {
1002     if (arg.pass) {
1003       return &arg;
1004     }
1005   }
1006   return nullptr;
1007 }
1008 
1009 bool Distinguishable(const Procedure &x, const Procedure &y) {
1010   return DistinguishUtils::Distinguishable(x, y);
1011 }
1012 
1013 bool DistinguishableOpOrAssign(const Procedure &x, const Procedure &y) {
1014   return DistinguishUtils::DistinguishableOpOrAssign(x, y);
1015 }
1016 
1017 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument)
1018 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
1019 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
1020 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
1021 }
1022 
1023 template class Fortran::common::Indirection<
1024     Fortran::evaluate::characteristics::Procedure, true>;
1025