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