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