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