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