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