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