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