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