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