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