xref: /llvm-project/flang/lib/Evaluate/characteristics.cpp (revision fad31d60329b4573a27aaf10cfe3174407d75c3a) 
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           }
489         }
490         return false;
491       case TypeCategory::Derived:
492         if (!type.IsPolymorphic()) {
493           const auto &spec{type.GetDerivedTypeSpec()};
494           for (const auto &pair : spec.parameters()) {
495             if (const auto &expr{pair.second.GetExplicit()}) {
496               if (!IsConstantExpr(*expr)) {
497                 return false; // 15.4.2.2(4)(c)
498               }
499             }
500           }
501           return true;
502         }
503         return false;
504       default:
505         return true;
506       }
507     }
508   } else {
509     return false; // 15.4.2.2(4)(b) - procedure pointer
510   }
511 }
512 
513 llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
514   attrs.Dump(o, EnumToString);
515   std::visit(common::visitors{
516                  [&](const TypeAndShape &ts) { ts.Dump(o); },
517                  [&](const CopyableIndirection<Procedure> &p) {
518                    p.value().Dump(o << " procedure(") << ')';
519                  },
520              },
521       u);
522   return o;
523 }
524 
525 Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
526     : functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {
527 }
528 Procedure::Procedure(DummyArguments &&args, Attrs a)
529     : dummyArguments{std::move(args)}, attrs{a} {}
530 Procedure::~Procedure() {}
531 
532 bool Procedure::operator==(const Procedure &that) const {
533   return attrs == that.attrs && functionResult == that.functionResult &&
534       dummyArguments == that.dummyArguments;
535 }
536 
537 int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
538   int argCount{static_cast<int>(dummyArguments.size())};
539   int index{0};
540   if (name) {
541     while (index < argCount && *name != dummyArguments[index].name.c_str()) {
542       ++index;
543     }
544   }
545   CHECK(index < argCount);
546   return index;
547 }
548 
549 bool Procedure::CanOverride(
550     const Procedure &that, std::optional<int> passIndex) const {
551   // A pure procedure may override an impure one (7.5.7.3(2))
552   if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) ||
553       that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) ||
554       functionResult != that.functionResult) {
555     return false;
556   }
557   int argCount{static_cast<int>(dummyArguments.size())};
558   if (argCount != static_cast<int>(that.dummyArguments.size())) {
559     return false;
560   }
561   for (int j{0}; j < argCount; ++j) {
562     if ((!passIndex || j != *passIndex) &&
563         dummyArguments[j] != that.dummyArguments[j]) {
564       return false;
565     }
566   }
567   return true;
568 }
569 
570 std::optional<Procedure> Procedure::Characterize(
571     const semantics::Symbol &original, const IntrinsicProcTable &intrinsics) {
572   Procedure result;
573   const auto &symbol{ResolveAssociations(original)};
574   CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
575       {
576           {semantics::Attr::PURE, Procedure::Attr::Pure},
577           {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
578           {semantics::Attr::BIND_C, Procedure::Attr::BindC},
579       });
580   if (result.attrs.test(Attr::Elemental) &&
581       !symbol.attrs().test(semantics::Attr::IMPURE)) {
582     result.attrs.set(Attr::Pure); // explicitly flag pure procedures
583   }
584   return std::visit(
585       common::visitors{
586           [&](const semantics::SubprogramDetails &subp)
587               -> std::optional<Procedure> {
588             if (subp.isFunction()) {
589               if (auto fr{FunctionResult::Characterize(
590                       subp.result(), intrinsics)}) {
591                 result.functionResult = std::move(fr);
592               } else {
593                 return std::nullopt;
594               }
595             } else {
596               result.attrs.set(Attr::Subroutine);
597             }
598             for (const semantics::Symbol *arg : subp.dummyArgs()) {
599               if (!arg) {
600                 result.dummyArguments.emplace_back(AlternateReturn{});
601               } else if (auto argCharacteristics{
602                              DummyArgument::Characterize(*arg, intrinsics)}) {
603                 result.dummyArguments.emplace_back(
604                     std::move(argCharacteristics.value()));
605               } else {
606                 return std::nullopt;
607               }
608             }
609             return result;
610           },
611           [&](const semantics::ProcEntityDetails &proc)
612               -> std::optional<Procedure> {
613             if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
614               return intrinsics.IsSpecificIntrinsicFunction(
615                   symbol.name().ToString());
616             }
617             const semantics::ProcInterface &interface{proc.interface()};
618             if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
619               return Characterize(*interfaceSymbol, intrinsics);
620             } else {
621               result.attrs.set(Attr::ImplicitInterface);
622               const semantics::DeclTypeSpec *type{interface.type()};
623               if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
624                 // ignore any implicit typing
625                 result.attrs.set(Attr::Subroutine);
626               } else if (type) {
627                 if (auto resultType{DynamicType::From(*type)}) {
628                   result.functionResult = FunctionResult{*resultType};
629                 } else {
630                   return std::nullopt;
631                 }
632               } else if (symbol.test(semantics::Symbol::Flag::Function)) {
633                 return std::nullopt;
634               }
635               // The PASS name, if any, is not a characteristic.
636               return result;
637             }
638           },
639           [&](const semantics::ProcBindingDetails &binding) {
640             if (auto result{Characterize(binding.symbol(), intrinsics)}) {
641               if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
642                 auto passName{binding.passName()};
643                 for (auto &dummy : result->dummyArguments) {
644                   if (!passName || dummy.name.c_str() == *passName) {
645                     dummy.pass = true;
646                     return result;
647                   }
648                 }
649                 DIE("PASS argument missing");
650               }
651               return result;
652             } else {
653               return std::optional<Procedure>{};
654             }
655           },
656           [&](const semantics::UseDetails &use) {
657             return Characterize(use.symbol(), intrinsics);
658           },
659           [&](const semantics::HostAssocDetails &assoc) {
660             return Characterize(assoc.symbol(), intrinsics);
661           },
662           [](const auto &) { return std::optional<Procedure>{}; },
663       },
664       symbol.details());
665 }
666 
667 std::optional<Procedure> Procedure::Characterize(
668     const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) {
669   if (const auto *symbol{proc.GetSymbol()}) {
670     if (auto result{characteristics::Procedure::Characterize(
671             ResolveAssociations(*symbol), intrinsics)}) {
672       return result;
673     }
674   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
675     return intrinsic->characteristics.value();
676   }
677   return std::nullopt;
678 }
679 
680 std::optional<Procedure> Procedure::Characterize(
681     const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) {
682   if (auto callee{Characterize(ref.proc(), intrinsics)}) {
683     if (callee->functionResult) {
684       if (const Procedure *
685           proc{callee->functionResult->IsProcedurePointer()}) {
686         return {*proc};
687       }
688     }
689   }
690   return std::nullopt;
691 }
692 
693 bool Procedure::CanBeCalledViaImplicitInterface() const {
694   if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) {
695     return false; // 15.4.2.2(5,6)
696   } else if (IsFunction() &&
697       !functionResult->CanBeReturnedViaImplicitInterface()) {
698     return false;
699   } else {
700     for (const DummyArgument &arg : dummyArguments) {
701       if (!arg.CanBePassedViaImplicitInterface()) {
702         return false;
703       }
704     }
705     return true;
706   }
707 }
708 
709 llvm::raw_ostream &Procedure::Dump(llvm::raw_ostream &o) const {
710   attrs.Dump(o, EnumToString);
711   if (functionResult) {
712     functionResult->Dump(o << "TYPE(") << ") FUNCTION";
713   } else {
714     o << "SUBROUTINE";
715   }
716   char sep{'('};
717   for (const auto &dummy : dummyArguments) {
718     dummy.Dump(o << sep);
719     sep = ',';
720   }
721   return o << (sep == '(' ? "()" : ")");
722 }
723 
724 // Utility class to determine if Procedures, etc. are distinguishable
725 class DistinguishUtils {
726 public:
727   // Are these procedures distinguishable for a generic name?
728   static bool Distinguishable(const Procedure &, const Procedure &);
729   // Are these procedures distinguishable for a generic operator or assignment?
730   static bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);
731 
732 private:
733   struct CountDummyProcedures {
734     CountDummyProcedures(const DummyArguments &args) {
735       for (const DummyArgument &arg : args) {
736         if (std::holds_alternative<DummyProcedure>(arg.u)) {
737           total += 1;
738           notOptional += !arg.IsOptional();
739         }
740       }
741     }
742     int total{0};
743     int notOptional{0};
744   };
745 
746   static bool Rule3Distinguishable(const Procedure &, const Procedure &);
747   static const DummyArgument *Rule1DistinguishingArg(
748       const DummyArguments &, const DummyArguments &);
749   static int FindFirstToDistinguishByPosition(
750       const DummyArguments &, const DummyArguments &);
751   static int FindLastToDistinguishByName(
752       const DummyArguments &, const DummyArguments &);
753   static int CountCompatibleWith(const DummyArgument &, const DummyArguments &);
754   static int CountNotDistinguishableFrom(
755       const DummyArgument &, const DummyArguments &);
756   static bool Distinguishable(const DummyArgument &, const DummyArgument &);
757   static bool Distinguishable(const DummyDataObject &, const DummyDataObject &);
758   static bool Distinguishable(const DummyProcedure &, const DummyProcedure &);
759   static bool Distinguishable(const FunctionResult &, const FunctionResult &);
760   static bool Distinguishable(const TypeAndShape &, const TypeAndShape &);
761   static bool IsTkrCompatible(const DummyArgument &, const DummyArgument &);
762   static bool IsTkrCompatible(const TypeAndShape &, const TypeAndShape &);
763   static const DummyArgument *GetAtEffectivePosition(
764       const DummyArguments &, int);
765   static const DummyArgument *GetPassArg(const Procedure &);
766 };
767 
768 // Simpler distinguishability rules for operators and assignment
769 bool DistinguishUtils::DistinguishableOpOrAssign(
770     const Procedure &proc1, const Procedure &proc2) {
771   auto &args1{proc1.dummyArguments};
772   auto &args2{proc2.dummyArguments};
773   if (args1.size() != args2.size()) {
774     return true; // C1511: distinguishable based on number of arguments
775   }
776   for (std::size_t i{0}; i < args1.size(); ++i) {
777     if (Distinguishable(args1[i], args2[i])) {
778       return true; // C1511, C1512: distinguishable based on this arg
779     }
780   }
781   return false;
782 }
783 
784 bool DistinguishUtils::Distinguishable(
785     const Procedure &proc1, const Procedure &proc2) {
786   auto &args1{proc1.dummyArguments};
787   auto &args2{proc2.dummyArguments};
788   auto count1{CountDummyProcedures(args1)};
789   auto count2{CountDummyProcedures(args2)};
790   if (count1.notOptional > count2.total || count2.notOptional > count1.total) {
791     return true; // distinguishable based on C1514 rule 2
792   }
793   if (Rule3Distinguishable(proc1, proc2)) {
794     return true; // distinguishable based on C1514 rule 3
795   }
796   if (Rule1DistinguishingArg(args1, args2)) {
797     return true; // distinguishable based on C1514 rule 1
798   }
799   int pos1{FindFirstToDistinguishByPosition(args1, args2)};
800   int name1{FindLastToDistinguishByName(args1, args2)};
801   if (pos1 >= 0 && pos1 <= name1) {
802     return true; // distinguishable based on C1514 rule 4
803   }
804   int pos2{FindFirstToDistinguishByPosition(args2, args1)};
805   int name2{FindLastToDistinguishByName(args2, args1)};
806   if (pos2 >= 0 && pos2 <= name2) {
807     return true; // distinguishable based on C1514 rule 4
808   }
809   return false;
810 }
811 
812 // C1514 rule 3: Procedures are distinguishable if both have a passed-object
813 // dummy argument and those are distinguishable.
814 bool DistinguishUtils::Rule3Distinguishable(
815     const Procedure &proc1, const Procedure &proc2) {
816   const DummyArgument *pass1{GetPassArg(proc1)};
817   const DummyArgument *pass2{GetPassArg(proc2)};
818   return pass1 && pass2 && Distinguishable(*pass1, *pass2);
819 }
820 
821 // Find a non-passed-object dummy data object in one of the argument lists
822 // that satisfies C1514 rule 1. I.e. x such that:
823 // - m is the number of dummy data objects in one that are nonoptional,
824 //   are not passed-object, that x is TKR compatible with
825 // - n is the number of non-passed-object dummy data objects, in the other
826 //   that are not distinguishable from x
827 // - m is greater than n
828 const DummyArgument *DistinguishUtils::Rule1DistinguishingArg(
829     const DummyArguments &args1, const DummyArguments &args2) {
830   auto size1{args1.size()};
831   auto size2{args2.size()};
832   for (std::size_t i{0}; i < size1 + size2; ++i) {
833     const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]};
834     if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) {
835       if (CountCompatibleWith(x, args1) >
836               CountNotDistinguishableFrom(x, args2) ||
837           CountCompatibleWith(x, args2) >
838               CountNotDistinguishableFrom(x, args1)) {
839         return &x;
840       }
841     }
842   }
843   return nullptr;
844 }
845 
846 // Find the index of the first nonoptional non-passed-object dummy argument
847 // in args1 at an effective position such that either:
848 // - args2 has no dummy argument at that effective position
849 // - the dummy argument at that position is distinguishable from it
850 int DistinguishUtils::FindFirstToDistinguishByPosition(
851     const DummyArguments &args1, const DummyArguments &args2) {
852   int effective{0}; // position of arg1 in list, ignoring passed arg
853   for (std::size_t i{0}; i < args1.size(); ++i) {
854     const DummyArgument &arg1{args1.at(i)};
855     if (!arg1.pass && !arg1.IsOptional()) {
856       const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)};
857       if (!arg2 || Distinguishable(arg1, *arg2)) {
858         return i;
859       }
860     }
861     effective += !arg1.pass;
862   }
863   return -1;
864 }
865 
866 // Find the index of the last nonoptional non-passed-object dummy argument
867 // in args1 whose name is such that either:
868 // - args2 has no dummy argument with that name
869 // - the dummy argument with that name is distinguishable from it
870 int DistinguishUtils::FindLastToDistinguishByName(
871     const DummyArguments &args1, const DummyArguments &args2) {
872   std::map<std::string, const DummyArgument *> nameToArg;
873   for (const auto &arg2 : args2) {
874     nameToArg.emplace(arg2.name, &arg2);
875   }
876   for (int i = args1.size() - 1; i >= 0; --i) {
877     const DummyArgument &arg1{args1.at(i)};
878     if (!arg1.pass && !arg1.IsOptional()) {
879       auto it{nameToArg.find(arg1.name)};
880       if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) {
881         return i;
882       }
883     }
884   }
885   return -1;
886 }
887 
888 // Count the dummy data objects in args that are nonoptional, are not
889 // passed-object, and that x is TKR compatible with
890 int DistinguishUtils::CountCompatibleWith(
891     const DummyArgument &x, const DummyArguments &args) {
892   return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) {
893     return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y);
894   });
895 }
896 
897 // Return the number of dummy data objects in args that are not
898 // distinguishable from x and not passed-object.
899 int DistinguishUtils::CountNotDistinguishableFrom(
900     const DummyArgument &x, const DummyArguments &args) {
901   return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) {
902     return !y.pass && std::holds_alternative<DummyDataObject>(y.u) &&
903         !Distinguishable(y, x);
904   });
905 }
906 
907 bool DistinguishUtils::Distinguishable(
908     const DummyArgument &x, const DummyArgument &y) {
909   if (x.u.index() != y.u.index()) {
910     return true; // different kind: data/proc/alt-return
911   }
912   return std::visit(
913       common::visitors{
914           [&](const DummyDataObject &z) {
915             return Distinguishable(z, std::get<DummyDataObject>(y.u));
916           },
917           [&](const DummyProcedure &z) {
918             return Distinguishable(z, std::get<DummyProcedure>(y.u));
919           },
920           [&](const AlternateReturn &) { return false; },
921       },
922       x.u);
923 }
924 
925 bool DistinguishUtils::Distinguishable(
926     const DummyDataObject &x, const DummyDataObject &y) {
927   using Attr = DummyDataObject::Attr;
928   if (Distinguishable(x.type, y.type)) {
929     return true;
930   } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
931       y.intent != common::Intent::In) {
932     return true;
933   } else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) &&
934       x.intent != common::Intent::In) {
935     return true;
936   } else {
937     return false;
938   }
939 }
940 
941 bool DistinguishUtils::Distinguishable(
942     const DummyProcedure &x, const DummyProcedure &y) {
943   const Procedure &xProc{x.procedure.value()};
944   const Procedure &yProc{y.procedure.value()};
945   if (Distinguishable(xProc, yProc)) {
946     return true;
947   } else {
948     const std::optional<FunctionResult> &xResult{xProc.functionResult};
949     const std::optional<FunctionResult> &yResult{yProc.functionResult};
950     return xResult ? !yResult || Distinguishable(*xResult, *yResult)
951                    : yResult.has_value();
952   }
953 }
954 
955 bool DistinguishUtils::Distinguishable(
956     const FunctionResult &x, const FunctionResult &y) {
957   if (x.u.index() != y.u.index()) {
958     return true; // one is data object, one is procedure
959   }
960   return std::visit(
961       common::visitors{
962           [&](const TypeAndShape &z) {
963             return Distinguishable(z, std::get<TypeAndShape>(y.u));
964           },
965           [&](const CopyableIndirection<Procedure> &z) {
966             return Distinguishable(z.value(),
967                 std::get<CopyableIndirection<Procedure>>(y.u).value());
968           },
969       },
970       x.u);
971 }
972 
973 bool DistinguishUtils::Distinguishable(
974     const TypeAndShape &x, const TypeAndShape &y) {
975   return !IsTkrCompatible(x, y) && !IsTkrCompatible(y, x);
976 }
977 
978 // Compatibility based on type, kind, and rank
979 bool DistinguishUtils::IsTkrCompatible(
980     const DummyArgument &x, const DummyArgument &y) {
981   const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
982   const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
983   return obj1 && obj2 && IsTkrCompatible(obj1->type, obj2->type);
984 }
985 bool DistinguishUtils::IsTkrCompatible(
986     const TypeAndShape &x, const TypeAndShape &y) {
987   return x.type().IsTkCompatibleWith(y.type()) &&
988       (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
989           y.attrs().test(TypeAndShape::Attr::AssumedRank) ||
990           x.Rank() == y.Rank());
991 }
992 
993 // Return the argument at the given index, ignoring the passed arg
994 const DummyArgument *DistinguishUtils::GetAtEffectivePosition(
995     const DummyArguments &args, int index) {
996   for (const DummyArgument &arg : args) {
997     if (!arg.pass) {
998       if (index == 0) {
999         return &arg;
1000       }
1001       --index;
1002     }
1003   }
1004   return nullptr;
1005 }
1006 
1007 // Return the passed-object dummy argument of this procedure, if any
1008 const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) {
1009   for (const auto &arg : proc.dummyArguments) {
1010     if (arg.pass) {
1011       return &arg;
1012     }
1013   }
1014   return nullptr;
1015 }
1016 
1017 bool Distinguishable(const Procedure &x, const Procedure &y) {
1018   return DistinguishUtils::Distinguishable(x, y);
1019 }
1020 
1021 bool DistinguishableOpOrAssign(const Procedure &x, const Procedure &y) {
1022   return DistinguishUtils::DistinguishableOpOrAssign(x, y);
1023 }
1024 
1025 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument)
1026 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
1027 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
1028 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
1029 } // namespace Fortran::evaluate::characteristics
1030 
1031 template class Fortran::common::Indirection<
1032     Fortran::evaluate::characteristics::Procedure, true>;
1033