xref: /llvm-project/flang/lib/Evaluate/characteristics.cpp (revision 5718a4256be0b357a6493a875f57ce4ff0f76459) 
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 "flang/Semantics/tools.h"
20 #include "llvm/Support/raw_ostream.h"
21 #include <initializer_list>
22 
23 using namespace Fortran::parser::literals;
24 
25 namespace Fortran::evaluate::characteristics {
26 
27 // Copy attributes from a symbol to dst based on the mapping in pairs.
28 template <typename A, typename B>
29 static void CopyAttrs(const semantics::Symbol &src, A &dst,
30     const std::initializer_list<std::pair<semantics::Attr, B>> &pairs) {
31   for (const auto &pair : pairs) {
32     if (src.attrs().test(pair.first)) {
33       dst.attrs.set(pair.second);
34     }
35   }
36 }
37 
38 // Shapes of function results and dummy arguments have to have
39 // the same rank, the same deferred dimensions, and the same
40 // values for explicit dimensions when constant.
41 bool ShapesAreCompatible(const Shape &x, const Shape &y) {
42   if (x.size() != y.size()) {
43     return false;
44   }
45   auto yIter{y.begin()};
46   for (const auto &xDim : x) {
47     const auto &yDim{*yIter++};
48     if (xDim) {
49       if (!yDim || ToInt64(*xDim) != ToInt64(*yDim)) {
50         return false;
51       }
52     } else if (yDim) {
53       return false;
54     }
55   }
56   return true;
57 }
58 
59 bool TypeAndShape::operator==(const TypeAndShape &that) const {
60   return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) &&
61       attrs_ == that.attrs_ && corank_ == that.corank_;
62 }
63 
64 TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) {
65   LEN_ = Fold(context, std::move(LEN_));
66   if (LEN_) {
67     if (auto n{ToInt64(*LEN_)}) {
68       type_ = DynamicType{type_.kind(), *n};
69     }
70   }
71   shape_ = Fold(context, std::move(shape_));
72   return *this;
73 }
74 
75 std::optional<TypeAndShape> TypeAndShape::Characterize(
76     const semantics::Symbol &symbol, FoldingContext &context) {
77   const auto &ultimate{symbol.GetUltimate()};
78   return common::visit(
79       common::visitors{
80           [&](const semantics::ProcEntityDetails &proc) {
81             if (proc.procInterface()) {
82               return Characterize(*proc.procInterface(), context);
83             } else if (proc.type()) {
84               return Characterize(*proc.type(), context);
85             } else {
86               return std::optional<TypeAndShape>{};
87             }
88           },
89           [&](const semantics::AssocEntityDetails &assoc) {
90             return Characterize(assoc, context);
91           },
92           [&](const semantics::ProcBindingDetails &binding) {
93             return Characterize(binding.symbol(), context);
94           },
95           [&](const auto &x) -> std::optional<TypeAndShape> {
96             using Ty = std::decay_t<decltype(x)>;
97             if constexpr (std::is_same_v<Ty, semantics::EntityDetails> ||
98                 std::is_same_v<Ty, semantics::ObjectEntityDetails> ||
99                 std::is_same_v<Ty, semantics::TypeParamDetails>) {
100               if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
101                 if (auto dyType{DynamicType::From(*type)}) {
102                   TypeAndShape result{
103                       std::move(*dyType), GetShape(context, ultimate)};
104                   result.AcquireAttrs(ultimate);
105                   result.AcquireLEN(ultimate);
106                   return std::move(result.Rewrite(context));
107                 }
108               }
109             }
110             return std::nullopt;
111           },
112       },
113       // GetUltimate() used here, not ResolveAssociations(), because
114       // we need the type/rank of an associate entity from TYPE IS,
115       // CLASS IS, or RANK statement.
116       ultimate.details());
117 }
118 
119 std::optional<TypeAndShape> TypeAndShape::Characterize(
120     const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
121   std::optional<TypeAndShape> result;
122   if (auto type{DynamicType::From(assoc.type())}) {
123     if (auto rank{assoc.rank()}) {
124       if (*rank >= 0 && *rank <= common::maxRank) {
125         result = TypeAndShape{std::move(*type), Shape(*rank)};
126       }
127     } else if (auto shape{GetShape(context, assoc.expr())}) {
128       result = TypeAndShape{std::move(*type), std::move(*shape)};
129     }
130     if (result && type->category() == TypeCategory::Character) {
131       if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc.expr())}) {
132         if (auto len{chExpr->LEN()}) {
133           result->set_LEN(std::move(*len));
134         }
135       }
136     }
137   }
138   return Fold(context, std::move(result));
139 }
140 
141 std::optional<TypeAndShape> TypeAndShape::Characterize(
142     const semantics::DeclTypeSpec &spec, FoldingContext &context) {
143   if (auto type{DynamicType::From(spec)}) {
144     return Fold(context, TypeAndShape{std::move(*type)});
145   } else {
146     return std::nullopt;
147   }
148 }
149 
150 std::optional<TypeAndShape> TypeAndShape::Characterize(
151     const ActualArgument &arg, FoldingContext &context) {
152   if (const auto *expr{arg.UnwrapExpr()}) {
153     return Characterize(*expr, context);
154   } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
155     return Characterize(*assumed, context);
156   } else {
157     return std::nullopt;
158   }
159 }
160 
161 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
162     const TypeAndShape &that, const char *thisIs, const char *thatIs,
163     bool omitShapeConformanceCheck,
164     enum CheckConformanceFlags::Flags flags) const {
165   if (!type_.IsTkCompatibleWith(that.type_)) {
166     messages.Say(
167         "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
168         thatIs, that.AsFortran(), thisIs, AsFortran());
169     return false;
170   }
171   return omitShapeConformanceCheck ||
172       CheckConformance(messages, shape_, that.shape_, flags, thisIs, thatIs)
173           .value_or(true /*fail only when nonconformance is known now*/);
174 }
175 
176 std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureElementSizeInBytes(
177     FoldingContext &foldingContext, bool align) const {
178   if (LEN_) {
179     CHECK(type_.category() == TypeCategory::Character);
180     return Fold(foldingContext,
181         Expr<SubscriptInteger>{
182             foldingContext.targetCharacteristics().GetByteSize(
183                 type_.category(), type_.kind())} *
184             Expr<SubscriptInteger>{*LEN_});
185   }
186   if (auto elementBytes{type_.MeasureSizeInBytes(foldingContext, align)}) {
187     return Fold(foldingContext, std::move(*elementBytes));
188   }
189   return std::nullopt;
190 }
191 
192 std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(
193     FoldingContext &foldingContext) const {
194   if (auto elements{GetSize(Shape{shape_})}) {
195     // Sizes of arrays (even with single elements) are multiples of
196     // their alignments.
197     if (auto elementBytes{
198             MeasureElementSizeInBytes(foldingContext, GetRank(shape_) > 0)}) {
199       return Fold(
200           foldingContext, std::move(*elements) * std::move(*elementBytes));
201     }
202   }
203   return std::nullopt;
204 }
205 
206 void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) {
207   if (IsAssumedShape(symbol)) {
208     attrs_.set(Attr::AssumedShape);
209   }
210   if (IsDeferredShape(symbol)) {
211     attrs_.set(Attr::DeferredShape);
212   }
213   if (const auto *object{
214           symbol.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) {
215     corank_ = object->coshape().Rank();
216     if (object->IsAssumedRank()) {
217       attrs_.set(Attr::AssumedRank);
218     }
219     if (object->IsAssumedSize()) {
220       attrs_.set(Attr::AssumedSize);
221     }
222     if (object->IsCoarray()) {
223       attrs_.set(Attr::Coarray);
224     }
225   }
226 }
227 
228 void TypeAndShape::AcquireLEN() {
229   if (auto len{type_.GetCharLength()}) {
230     LEN_ = std::move(len);
231   }
232 }
233 
234 void TypeAndShape::AcquireLEN(const semantics::Symbol &symbol) {
235   if (type_.category() == TypeCategory::Character) {
236     if (auto len{DataRef{symbol}.LEN()}) {
237       LEN_ = std::move(*len);
238     }
239   }
240 }
241 
242 std::string TypeAndShape::AsFortran() const {
243   return type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
244 }
245 
246 llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
247   o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
248   attrs_.Dump(o, EnumToString);
249   if (!shape_.empty()) {
250     o << " dimension";
251     char sep{'('};
252     for (const auto &expr : shape_) {
253       o << sep;
254       sep = ',';
255       if (expr) {
256         expr->AsFortran(o);
257       } else {
258         o << ':';
259       }
260     }
261     o << ')';
262   }
263   return o;
264 }
265 
266 bool DummyDataObject::operator==(const DummyDataObject &that) const {
267   return type == that.type && attrs == that.attrs && intent == that.intent &&
268       coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
269   ;
270 }
271 
272 static bool AreCompatibleDummyDataObjectShapes(const Shape &x, const Shape &y) {
273   int n{GetRank(x)};
274   if (n != GetRank(y)) {
275     return false;
276   }
277   auto xIter{x.begin()};
278   auto yIter{y.begin()};
279   for (; n-- > 0; ++xIter, ++yIter) {
280     if (auto xVal{ToInt64(*xIter)}) {
281       if (auto yVal{ToInt64(*yIter)}) {
282         if (*xVal != *yVal) {
283           return false;
284         }
285       }
286     }
287   }
288   return true;
289 }
290 
291 bool DummyDataObject::IsCompatibleWith(
292     const DummyDataObject &actual, std::string *whyNot) const {
293   if (!AreCompatibleDummyDataObjectShapes(type.shape(), actual.type.shape())) {
294     if (whyNot) {
295       *whyNot = "incompatible dummy data object shapes";
296     }
297     return false;
298   }
299   if (!type.type().IsTkLenCompatibleWith(actual.type.type())) {
300     if (whyNot) {
301       *whyNot = "incompatible dummy data object types: "s +
302           type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
303     }
304     return false;
305   }
306   if (type.type().IsPolymorphic() != actual.type.type().IsPolymorphic()) {
307     if (whyNot) {
308       *whyNot = "incompatible dummy data object polymorphism: "s +
309           type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
310     }
311     return false;
312   }
313   if (type.type().category() == TypeCategory::Character) {
314     if (actual.type.type().IsAssumedLengthCharacter() !=
315         type.type().IsAssumedLengthCharacter()) {
316       if (whyNot) {
317         *whyNot = "assumed-length character vs explicit-length character";
318       }
319       return false;
320     }
321     if (!type.type().IsAssumedLengthCharacter() && type.LEN() &&
322         actual.type.LEN()) {
323       auto len{ToInt64(*type.LEN())};
324       auto actualLen{ToInt64(*actual.type.LEN())};
325       if (len.has_value() != actualLen.has_value()) {
326         if (whyNot) {
327           *whyNot = "constant-length vs non-constant-length character dummy "
328                     "arguments";
329         }
330         return false;
331       } else if (len && *len != *actualLen) {
332         if (whyNot) {
333           *whyNot = "character dummy arguments with distinct lengths";
334         }
335         return false;
336       }
337     }
338   }
339   if (!IdenticalSignificantAttrs(attrs, actual.attrs) ||
340       type.attrs() != actual.type.attrs()) {
341     if (whyNot) {
342       *whyNot = "incompatible dummy data object attributes";
343     }
344     return false;
345   }
346   if (intent != actual.intent) {
347     if (whyNot) {
348       *whyNot = "incompatible dummy data object intents";
349     }
350     return false;
351   }
352   if (coshape != actual.coshape) {
353     if (whyNot) {
354       *whyNot = "incompatible dummy data object coshapes";
355     }
356     return false;
357   }
358   if (ignoreTKR != actual.ignoreTKR) {
359     if (whyNot) {
360       *whyNot = "incompatible !DIR$ IGNORE_TKR directives";
361     }
362   }
363   if (!attrs.test(Attr::Value) &&
364       !common::AreCompatibleCUDADataAttrs(
365           cudaDataAttr, actual.cudaDataAttr, ignoreTKR)) {
366     if (whyNot) {
367       *whyNot = "incompatible CUDA data attributes";
368     }
369   }
370   return true;
371 }
372 
373 static common::Intent GetIntent(const semantics::Attrs &attrs) {
374   if (attrs.test(semantics::Attr::INTENT_IN)) {
375     return common::Intent::In;
376   } else if (attrs.test(semantics::Attr::INTENT_OUT)) {
377     return common::Intent::Out;
378   } else if (attrs.test(semantics::Attr::INTENT_INOUT)) {
379     return common::Intent::InOut;
380   } else {
381     return common::Intent::Default;
382   }
383 }
384 
385 std::optional<DummyDataObject> DummyDataObject::Characterize(
386     const semantics::Symbol &symbol, FoldingContext &context) {
387   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
388       object || symbol.has<semantics::EntityDetails>()) {
389     if (auto type{TypeAndShape::Characterize(symbol, context)}) {
390       std::optional<DummyDataObject> result{std::move(*type)};
391       using semantics::Attr;
392       CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
393           {
394               {Attr::OPTIONAL, DummyDataObject::Attr::Optional},
395               {Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable},
396               {Attr::ASYNCHRONOUS, DummyDataObject::Attr::Asynchronous},
397               {Attr::CONTIGUOUS, DummyDataObject::Attr::Contiguous},
398               {Attr::VALUE, DummyDataObject::Attr::Value},
399               {Attr::VOLATILE, DummyDataObject::Attr::Volatile},
400               {Attr::POINTER, DummyDataObject::Attr::Pointer},
401               {Attr::TARGET, DummyDataObject::Attr::Target},
402           });
403       result->intent = GetIntent(symbol.attrs());
404       result->ignoreTKR = GetIgnoreTKR(symbol);
405       if (object) {
406         result->cudaDataAttr = object->cudaDataAttr();
407         if (!result->cudaDataAttr &&
408             !result->attrs.test(DummyDataObject::Attr::Value) &&
409             semantics::IsCUDADeviceContext(&symbol.owner())) {
410           result->cudaDataAttr = common::CUDADataAttr::Device;
411         }
412       }
413       return result;
414     }
415   }
416   return std::nullopt;
417 }
418 
419 bool DummyDataObject::CanBePassedViaImplicitInterface() const {
420   if ((attrs &
421           Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional,
422               Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile})
423           .any()) {
424     return false; // 15.4.2.2(3)(a)
425   } else if ((type.attrs() &
426                  TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape,
427                      TypeAndShape::Attr::AssumedRank,
428                      TypeAndShape::Attr::Coarray})
429                  .any()) {
430     return false; // 15.4.2.2(3)(b-d)
431   } else if (type.type().IsPolymorphic()) {
432     return false; // 15.4.2.2(3)(f)
433   } else if (cudaDataAttr) {
434     return false;
435   } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) {
436     return derived->parameters().empty(); // 15.4.2.2(3)(e)
437   } else {
438     return true;
439   }
440 }
441 
442 llvm::raw_ostream &DummyDataObject::Dump(llvm::raw_ostream &o) const {
443   attrs.Dump(o, EnumToString);
444   if (intent != common::Intent::Default) {
445     o << "INTENT(" << common::EnumToString(intent) << ')';
446   }
447   type.Dump(o);
448   if (!coshape.empty()) {
449     char sep{'['};
450     for (const auto &expr : coshape) {
451       expr.AsFortran(o << sep);
452       sep = ',';
453     }
454   }
455   if (cudaDataAttr) {
456     o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr);
457   }
458   if (!ignoreTKR.empty()) {
459     ignoreTKR.Dump(o << ' ', common::EnumToString);
460   }
461   return o;
462 }
463 
464 DummyProcedure::DummyProcedure(Procedure &&p)
465     : procedure{new Procedure{std::move(p)}} {}
466 
467 bool DummyProcedure::operator==(const DummyProcedure &that) const {
468   return attrs == that.attrs && intent == that.intent &&
469       procedure.value() == that.procedure.value();
470 }
471 
472 bool DummyProcedure::IsCompatibleWith(
473     const DummyProcedure &actual, std::string *whyNot) const {
474   if (attrs != actual.attrs) {
475     if (whyNot) {
476       *whyNot = "incompatible dummy procedure attributes";
477     }
478     return false;
479   }
480   if (intent != actual.intent) {
481     if (whyNot) {
482       *whyNot = "incompatible dummy procedure intents";
483     }
484     return false;
485   }
486   if (!procedure.value().IsCompatibleWith(actual.procedure.value(), whyNot)) {
487     if (whyNot) {
488       *whyNot = "incompatible dummy procedure interfaces: "s + *whyNot;
489     }
490     return false;
491   }
492   return true;
493 }
494 
495 bool DummyProcedure::CanBePassedViaImplicitInterface() const {
496   if ((attrs & Attrs{Attr::Optional, Attr::Pointer}).any()) {
497     return false; // 15.4.2.2(3)(a)
498   }
499   return true;
500 }
501 
502 static std::string GetSeenProcs(
503     const semantics::UnorderedSymbolSet &seenProcs) {
504   // Sort the symbols so that they appear in the same order on all platforms
505   auto ordered{semantics::OrderBySourcePosition(seenProcs)};
506   std::string result;
507   llvm::interleave(
508       ordered,
509       [&](const SymbolRef p) { result += '\'' + p->name().ToString() + '\''; },
510       [&]() { result += ", "; });
511   return result;
512 }
513 
514 // These functions with arguments of type UnorderedSymbolSet are used with
515 // mutually recursive calls when characterizing a Procedure, a DummyArgument,
516 // or a DummyProcedure to detect circularly defined procedures as required by
517 // 15.4.3.6, paragraph 2.
518 static std::optional<DummyArgument> CharacterizeDummyArgument(
519     const semantics::Symbol &symbol, FoldingContext &context,
520     semantics::UnorderedSymbolSet seenProcs);
521 static std::optional<FunctionResult> CharacterizeFunctionResult(
522     const semantics::Symbol &symbol, FoldingContext &context,
523     semantics::UnorderedSymbolSet seenProcs);
524 
525 static std::optional<Procedure> CharacterizeProcedure(
526     const semantics::Symbol &original, FoldingContext &context,
527     semantics::UnorderedSymbolSet seenProcs) {
528   Procedure result;
529   const auto &symbol{ResolveAssociations(original)};
530   if (seenProcs.find(symbol) != seenProcs.end()) {
531     std::string procsList{GetSeenProcs(seenProcs)};
532     context.messages().Say(symbol.name(),
533         "Procedure '%s' is recursively defined.  Procedures in the cycle:"
534         " %s"_err_en_US,
535         symbol.name(), procsList);
536     return std::nullopt;
537   }
538   seenProcs.insert(symbol);
539   if (IsElementalProcedure(symbol)) {
540     result.attrs.set(Procedure::Attr::Elemental);
541   }
542   CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
543       {
544           {semantics::Attr::BIND_C, Procedure::Attr::BindC},
545       });
546   if (IsPureProcedure(symbol) || // works for ENTRY too
547       (!symbol.attrs().test(semantics::Attr::IMPURE) &&
548           result.attrs.test(Procedure::Attr::Elemental))) {
549     result.attrs.set(Procedure::Attr::Pure);
550   }
551   return common::visit(
552       common::visitors{
553           [&](const semantics::SubprogramDetails &subp)
554               -> std::optional<Procedure> {
555             if (subp.isFunction()) {
556               if (auto fr{CharacterizeFunctionResult(
557                       subp.result(), context, seenProcs)}) {
558                 result.functionResult = std::move(fr);
559               } else {
560                 return std::nullopt;
561               }
562             } else {
563               result.attrs.set(Procedure::Attr::Subroutine);
564             }
565             for (const semantics::Symbol *arg : subp.dummyArgs()) {
566               if (!arg) {
567                 if (subp.isFunction()) {
568                   return std::nullopt;
569                 } else {
570                   result.dummyArguments.emplace_back(AlternateReturn{});
571                 }
572               } else if (auto argCharacteristics{CharacterizeDummyArgument(
573                              *arg, context, seenProcs)}) {
574                 result.dummyArguments.emplace_back(
575                     std::move(argCharacteristics.value()));
576               } else {
577                 return std::nullopt;
578               }
579             }
580             result.cudaSubprogramAttrs = subp.cudaSubprogramAttrs();
581             return result;
582           },
583           [&](const semantics::ProcEntityDetails &proc)
584               -> std::optional<Procedure> {
585             if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
586               // Fails when the intrinsic is not a specific intrinsic function
587               // from F'2018 table 16.2.  In order to handle forward references,
588               // attempts to use impermissible intrinsic procedures as the
589               // interfaces of procedure pointers are caught and flagged in
590               // declaration checking in Semantics.
591               auto intrinsic{context.intrinsics().IsSpecificIntrinsicFunction(
592                   symbol.name().ToString())};
593               if (intrinsic && intrinsic->isRestrictedSpecific) {
594                 intrinsic.reset(); // Exclude intrinsics from table 16.3.
595               }
596               return intrinsic;
597             }
598             if (const semantics::Symbol *
599                 interfaceSymbol{proc.procInterface()}) {
600               auto interface {
601                 CharacterizeProcedure(*interfaceSymbol, context, seenProcs)
602               };
603               if (interface && IsPointer(symbol)) {
604                 interface->attrs.reset(Procedure::Attr::Elemental);
605               }
606               return interface;
607             } else {
608               result.attrs.set(Procedure::Attr::ImplicitInterface);
609               const semantics::DeclTypeSpec *type{proc.type()};
610               if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
611                 // ignore any implicit typing
612                 result.attrs.set(Procedure::Attr::Subroutine);
613                 if (proc.isCUDAKernel()) {
614                   result.cudaSubprogramAttrs =
615                       common::CUDASubprogramAttrs::Global;
616                 }
617               } else if (type) {
618                 if (auto resultType{DynamicType::From(*type)}) {
619                   result.functionResult = FunctionResult{*resultType};
620                 } else {
621                   return std::nullopt;
622                 }
623               } else if (symbol.test(semantics::Symbol::Flag::Function)) {
624                 return std::nullopt;
625               }
626               // The PASS name, if any, is not a characteristic.
627               return result;
628             }
629           },
630           [&](const semantics::ProcBindingDetails &binding) {
631             if (auto result{CharacterizeProcedure(
632                     binding.symbol(), context, seenProcs)}) {
633               if (binding.symbol().attrs().test(semantics::Attr::INTRINSIC)) {
634                 result->attrs.reset(Procedure::Attr::Elemental);
635               }
636               if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
637                 auto passName{binding.passName()};
638                 for (auto &dummy : result->dummyArguments) {
639                   if (!passName || dummy.name.c_str() == *passName) {
640                     dummy.pass = true;
641                     break;
642                   }
643                 }
644               }
645               return result;
646             } else {
647               return std::optional<Procedure>{};
648             }
649           },
650           [&](const semantics::UseDetails &use) {
651             return CharacterizeProcedure(use.symbol(), context, seenProcs);
652           },
653           [](const semantics::UseErrorDetails &) {
654             // Ambiguous use-association will be handled later during symbol
655             // checks, ignore UseErrorDetails here without actual symbol usage.
656             return std::optional<Procedure>{};
657           },
658           [&](const semantics::HostAssocDetails &assoc) {
659             return CharacterizeProcedure(assoc.symbol(), context, seenProcs);
660           },
661           [&](const semantics::GenericDetails &generic) {
662             if (const semantics::Symbol * specific{generic.specific()}) {
663               return CharacterizeProcedure(*specific, context, seenProcs);
664             } else {
665               return std::optional<Procedure>{};
666             }
667           },
668           [&](const semantics::EntityDetails &) {
669             context.messages().Say(
670                 "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
671                 symbol.name());
672             return std::optional<Procedure>{};
673           },
674           [&](const semantics::SubprogramNameDetails &) {
675             context.messages().Say(
676                 "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
677                 symbol.name());
678             return std::optional<Procedure>{};
679           },
680           [&](const auto &) {
681             context.messages().Say(
682                 "'%s' is not a procedure"_err_en_US, symbol.name());
683             return std::optional<Procedure>{};
684           },
685       },
686       symbol.details());
687 }
688 
689 static std::optional<DummyProcedure> CharacterizeDummyProcedure(
690     const semantics::Symbol &symbol, FoldingContext &context,
691     semantics::UnorderedSymbolSet seenProcs) {
692   if (auto procedure{CharacterizeProcedure(symbol, context, seenProcs)}) {
693     // Dummy procedures may not be elemental.  Elemental dummy procedure
694     // interfaces are errors when the interface is not intrinsic, and that
695     // error is caught elsewhere.  Elemental intrinsic interfaces are
696     // made non-elemental.
697     procedure->attrs.reset(Procedure::Attr::Elemental);
698     DummyProcedure result{std::move(procedure.value())};
699     CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result,
700         {
701             {semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional},
702             {semantics::Attr::POINTER, DummyProcedure::Attr::Pointer},
703         });
704     result.intent = GetIntent(symbol.attrs());
705     return result;
706   } else {
707     return std::nullopt;
708   }
709 }
710 
711 llvm::raw_ostream &DummyProcedure::Dump(llvm::raw_ostream &o) const {
712   attrs.Dump(o, EnumToString);
713   if (intent != common::Intent::Default) {
714     o << "INTENT(" << common::EnumToString(intent) << ')';
715   }
716   procedure.value().Dump(o);
717   return o;
718 }
719 
720 llvm::raw_ostream &AlternateReturn::Dump(llvm::raw_ostream &o) const {
721   return o << '*';
722 }
723 
724 DummyArgument::~DummyArgument() {}
725 
726 bool DummyArgument::operator==(const DummyArgument &that) const {
727   return u == that.u; // name and passed-object usage are not characteristics
728 }
729 
730 bool DummyArgument::IsCompatibleWith(
731     const DummyArgument &actual, std::string *whyNot) const {
732   if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
733     if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) {
734       return ifaceData->IsCompatibleWith(*actualData, whyNot);
735     }
736     if (whyNot) {
737       *whyNot = "one dummy argument is an object, the other is not";
738     }
739   } else if (const auto *ifaceProc{std::get_if<DummyProcedure>(&u)}) {
740     if (const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)}) {
741       return ifaceProc->IsCompatibleWith(*actualProc, whyNot);
742     }
743     if (whyNot) {
744       *whyNot = "one dummy argument is a procedure, the other is not";
745     }
746   } else {
747     CHECK(std::holds_alternative<AlternateReturn>(u));
748     if (std::holds_alternative<AlternateReturn>(actual.u)) {
749       return true;
750     }
751     if (whyNot) {
752       *whyNot = "one dummy argument is an alternate return, the other is not";
753     }
754   }
755   return false;
756 }
757 
758 static std::optional<DummyArgument> CharacterizeDummyArgument(
759     const semantics::Symbol &symbol, FoldingContext &context,
760     semantics::UnorderedSymbolSet seenProcs) {
761   auto name{symbol.name().ToString()};
762   if (symbol.has<semantics::ObjectEntityDetails>() ||
763       symbol.has<semantics::EntityDetails>()) {
764     if (auto obj{DummyDataObject::Characterize(symbol, context)}) {
765       return DummyArgument{std::move(name), std::move(obj.value())};
766     }
767   } else if (auto proc{
768                  CharacterizeDummyProcedure(symbol, context, seenProcs)}) {
769     return DummyArgument{std::move(name), std::move(proc.value())};
770   }
771   return std::nullopt;
772 }
773 
774 std::optional<DummyArgument> DummyArgument::FromActual(
775     std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
776   return common::visit(
777       common::visitors{
778           [&](const BOZLiteralConstant &) {
779             DummyDataObject obj{
780                 TypeAndShape{DynamicType::TypelessIntrinsicArgument()}};
781             obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
782             return std::make_optional<DummyArgument>(
783                 std::move(name), std::move(obj));
784           },
785           [&](const NullPointer &) {
786             DummyDataObject obj{
787                 TypeAndShape{DynamicType::TypelessIntrinsicArgument()}};
788             obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
789             return std::make_optional<DummyArgument>(
790                 std::move(name), std::move(obj));
791           },
792           [&](const ProcedureDesignator &designator) {
793             if (auto proc{Procedure::Characterize(designator, context)}) {
794               return std::make_optional<DummyArgument>(
795                   std::move(name), DummyProcedure{std::move(*proc)});
796             } else {
797               return std::optional<DummyArgument>{};
798             }
799           },
800           [&](const ProcedureRef &call) {
801             if (auto proc{Procedure::Characterize(call, context)}) {
802               return std::make_optional<DummyArgument>(
803                   std::move(name), DummyProcedure{std::move(*proc)});
804             } else {
805               return std::optional<DummyArgument>{};
806             }
807           },
808           [&](const auto &) {
809             if (auto type{TypeAndShape::Characterize(expr, context)}) {
810               DummyDataObject obj{std::move(*type)};
811               obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
812               return std::make_optional<DummyArgument>(
813                   std::move(name), std::move(obj));
814             } else {
815               return std::optional<DummyArgument>{};
816             }
817           },
818       },
819       expr.u);
820 }
821 
822 std::optional<DummyArgument> DummyArgument::FromActual(
823     std::string &&name, const ActualArgument &arg, FoldingContext &context) {
824   if (const auto *expr{arg.UnwrapExpr()}) {
825     return FromActual(std::move(name), *expr, context);
826   } else if (arg.GetAssumedTypeDummy()) {
827     return std::nullopt;
828   } else {
829     return DummyArgument{AlternateReturn{}};
830   }
831 }
832 
833 bool DummyArgument::IsOptional() const {
834   return common::visit(
835       common::visitors{
836           [](const DummyDataObject &data) {
837             return data.attrs.test(DummyDataObject::Attr::Optional);
838           },
839           [](const DummyProcedure &proc) {
840             return proc.attrs.test(DummyProcedure::Attr::Optional);
841           },
842           [](const AlternateReturn &) { return false; },
843       },
844       u);
845 }
846 
847 void DummyArgument::SetOptional(bool value) {
848   common::visit(common::visitors{
849                     [value](DummyDataObject &data) {
850                       data.attrs.set(DummyDataObject::Attr::Optional, value);
851                     },
852                     [value](DummyProcedure &proc) {
853                       proc.attrs.set(DummyProcedure::Attr::Optional, value);
854                     },
855                     [](AlternateReturn &) { DIE("cannot set optional"); },
856                 },
857       u);
858 }
859 
860 void DummyArgument::SetIntent(common::Intent intent) {
861   common::visit(common::visitors{
862                     [intent](DummyDataObject &data) { data.intent = intent; },
863                     [intent](DummyProcedure &proc) { proc.intent = intent; },
864                     [](AlternateReturn &) { DIE("cannot set intent"); },
865                 },
866       u);
867 }
868 
869 common::Intent DummyArgument::GetIntent() const {
870   return common::visit(
871       common::visitors{
872           [](const DummyDataObject &data) { return data.intent; },
873           [](const DummyProcedure &proc) { return proc.intent; },
874           [](const AlternateReturn &) -> common::Intent {
875             DIE("Alternate returns have no intent");
876           },
877       },
878       u);
879 }
880 
881 bool DummyArgument::CanBePassedViaImplicitInterface() const {
882   if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
883     return object->CanBePassedViaImplicitInterface();
884   } else if (const auto *proc{std::get_if<DummyProcedure>(&u)}) {
885     return proc->CanBePassedViaImplicitInterface();
886   } else {
887     return true;
888   }
889 }
890 
891 bool DummyArgument::IsTypelessIntrinsicDummy() const {
892   const auto *argObj{std::get_if<characteristics::DummyDataObject>(&u)};
893   return argObj && argObj->type.type().IsTypelessIntrinsicArgument();
894 }
895 
896 llvm::raw_ostream &DummyArgument::Dump(llvm::raw_ostream &o) const {
897   if (!name.empty()) {
898     o << name << '=';
899   }
900   if (pass) {
901     o << " PASS";
902   }
903   common::visit([&](const auto &x) { x.Dump(o); }, u);
904   return o;
905 }
906 
907 FunctionResult::FunctionResult(DynamicType t) : u{TypeAndShape{t}} {}
908 FunctionResult::FunctionResult(TypeAndShape &&t) : u{std::move(t)} {}
909 FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {}
910 FunctionResult::~FunctionResult() {}
911 
912 bool FunctionResult::operator==(const FunctionResult &that) const {
913   return attrs == that.attrs && cudaDataAttr == that.cudaDataAttr &&
914       u == that.u;
915 }
916 
917 static std::optional<FunctionResult> CharacterizeFunctionResult(
918     const semantics::Symbol &symbol, FoldingContext &context,
919     semantics::UnorderedSymbolSet seenProcs) {
920   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
921     if (auto type{TypeAndShape::Characterize(symbol, context)}) {
922       FunctionResult result{std::move(*type)};
923       CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
924           {
925               {semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable},
926               {semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous},
927               {semantics::Attr::POINTER, FunctionResult::Attr::Pointer},
928           });
929       result.cudaDataAttr = object->cudaDataAttr();
930       return result;
931     }
932   } else if (auto maybeProc{
933                  CharacterizeProcedure(symbol, context, seenProcs)}) {
934     FunctionResult result{std::move(*maybeProc)};
935     result.attrs.set(FunctionResult::Attr::Pointer);
936     return result;
937   }
938   return std::nullopt;
939 }
940 
941 std::optional<FunctionResult> FunctionResult::Characterize(
942     const Symbol &symbol, FoldingContext &context) {
943   semantics::UnorderedSymbolSet seenProcs;
944   return CharacterizeFunctionResult(symbol, context, seenProcs);
945 }
946 
947 bool FunctionResult::IsAssumedLengthCharacter() const {
948   if (const auto *ts{std::get_if<TypeAndShape>(&u)}) {
949     return ts->type().IsAssumedLengthCharacter();
950   } else {
951     return false;
952   }
953 }
954 
955 bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
956   if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) {
957     return false; // 15.4.2.2(4)(b)
958   } else if (cudaDataAttr) {
959     return false;
960   } else if (const auto *typeAndShape{GetTypeAndShape()}) {
961     if (typeAndShape->Rank() > 0) {
962       return false; // 15.4.2.2(4)(a)
963     } else {
964       const DynamicType &type{typeAndShape->type()};
965       switch (type.category()) {
966       case TypeCategory::Character:
967         if (type.knownLength()) {
968           return true;
969         } else if (const auto *param{type.charLengthParamValue()}) {
970           if (const auto &expr{param->GetExplicit()}) {
971             return IsConstantExpr(*expr); // 15.4.2.2(4)(c)
972           } else if (param->isAssumed()) {
973             return true;
974           }
975         }
976         return false;
977       case TypeCategory::Derived:
978         if (!type.IsPolymorphic()) {
979           const auto &spec{type.GetDerivedTypeSpec()};
980           for (const auto &pair : spec.parameters()) {
981             if (const auto &expr{pair.second.GetExplicit()}) {
982               if (!IsConstantExpr(*expr)) {
983                 return false; // 15.4.2.2(4)(c)
984               }
985             }
986           }
987           return true;
988         }
989         return false;
990       default:
991         return true;
992       }
993     }
994   } else {
995     return false; // 15.4.2.2(4)(b) - procedure pointer
996   }
997 }
998 
999 static bool AreCompatibleFunctionResultShapes(const Shape &x, const Shape &y) {
1000   int rank{GetRank(x)};
1001   if (GetRank(y) != rank) {
1002     return false;
1003   }
1004   for (int j{0}; j < rank; ++j) {
1005     if (auto xDim{ToInt64(x[j])}) {
1006       if (auto yDim{ToInt64(y[j])}) {
1007         if (*xDim != *yDim) {
1008           return false;
1009         }
1010       }
1011     }
1012   }
1013   return true;
1014 }
1015 
1016 bool FunctionResult::IsCompatibleWith(
1017     const FunctionResult &actual, std::string *whyNot) const {
1018   Attrs actualAttrs{actual.attrs};
1019   if (!attrs.test(Attr::Contiguous)) {
1020     actualAttrs.reset(Attr::Contiguous);
1021   }
1022   if (attrs != actualAttrs) {
1023     if (whyNot) {
1024       *whyNot = "function results have incompatible attributes";
1025     }
1026   } else if (cudaDataAttr != actual.cudaDataAttr) {
1027     if (whyNot) {
1028       *whyNot = "function results have incompatible CUDA data attributes";
1029     }
1030   } else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
1031     if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
1032       if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) {
1033         if (whyNot) {
1034           *whyNot = "function results have distinct ranks";
1035         }
1036       } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
1037           !AreCompatibleFunctionResultShapes(
1038               ifaceTypeShape->shape(), actualTypeShape->shape())) {
1039         if (whyNot) {
1040           *whyNot = "function results have distinct constant extents";
1041         }
1042       } else if (ifaceTypeShape->type() != actualTypeShape->type()) {
1043         if (ifaceTypeShape->type().category() ==
1044             actualTypeShape->type().category()) {
1045           if (ifaceTypeShape->type().category() == TypeCategory::Character) {
1046             if (ifaceTypeShape->type().kind() ==
1047                 actualTypeShape->type().kind()) {
1048               auto ifaceLen{ifaceTypeShape->type().knownLength()};
1049               auto actualLen{actualTypeShape->type().knownLength()};
1050               if (!ifaceLen || !actualLen || *ifaceLen == *actualLen) {
1051                 return true;
1052               }
1053             }
1054           } else if (ifaceTypeShape->type().category() ==
1055               TypeCategory::Derived) {
1056             if (ifaceTypeShape->type().IsPolymorphic() ==
1057                     actualTypeShape->type().IsPolymorphic() &&
1058                 !ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
1059                 !actualTypeShape->type().IsUnlimitedPolymorphic() &&
1060                 AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
1061                     actualTypeShape->type().GetDerivedTypeSpec())) {
1062               return true;
1063             }
1064           }
1065         }
1066         if (whyNot) {
1067           *whyNot = "function results have distinct types: "s +
1068               ifaceTypeShape->type().AsFortran() + " vs "s +
1069               actualTypeShape->type().AsFortran();
1070         }
1071       } else {
1072         return true;
1073       }
1074     } else {
1075       if (whyNot) {
1076         *whyNot = "function result type and shape are not known";
1077       }
1078     }
1079   } else {
1080     const auto *ifaceProc{std::get_if<CopyableIndirection<Procedure>>(&u)};
1081     CHECK(ifaceProc != nullptr);
1082     if (const auto *actualProc{
1083             std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) {
1084       if (ifaceProc->value().IsCompatibleWith(actualProc->value(), whyNot)) {
1085         return true;
1086       }
1087       if (whyNot) {
1088         *whyNot =
1089             "function results are incompatible procedure pointers: "s + *whyNot;
1090       }
1091     } else {
1092       if (whyNot) {
1093         *whyNot =
1094             "one function result is a procedure pointer, the other is not";
1095       }
1096     }
1097   }
1098   return false;
1099 }
1100 
1101 llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
1102   attrs.Dump(o, EnumToString);
1103   common::visit(common::visitors{
1104                     [&](const TypeAndShape &ts) { ts.Dump(o); },
1105                     [&](const CopyableIndirection<Procedure> &p) {
1106                       p.value().Dump(o << " procedure(") << ')';
1107                     },
1108                 },
1109       u);
1110   if (cudaDataAttr) {
1111     o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr);
1112   }
1113   return o;
1114 }
1115 
1116 Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
1117     : functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {
1118 }
1119 Procedure::Procedure(DummyArguments &&args, Attrs a)
1120     : dummyArguments{std::move(args)}, attrs{a} {}
1121 Procedure::~Procedure() {}
1122 
1123 bool Procedure::operator==(const Procedure &that) const {
1124   return attrs == that.attrs && functionResult == that.functionResult &&
1125       dummyArguments == that.dummyArguments &&
1126       cudaSubprogramAttrs == that.cudaSubprogramAttrs;
1127 }
1128 
1129 bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
1130     const SpecificIntrinsic *specificIntrinsic) const {
1131   // 15.5.2.9(1): if dummy is not pure, actual need not be.
1132   // Ditto with elemental.
1133   Attrs actualAttrs{actual.attrs};
1134   if (!attrs.test(Attr::Pure)) {
1135     actualAttrs.reset(Attr::Pure);
1136   }
1137   if (!attrs.test(Attr::Elemental) && specificIntrinsic) {
1138     actualAttrs.reset(Attr::Elemental);
1139   }
1140   Attrs differences{attrs ^ actualAttrs};
1141   differences.reset(Attr::Subroutine); // dealt with specifically later
1142   if (!differences.empty()) {
1143     if (whyNot) {
1144       auto sep{": "s};
1145       *whyNot = "incompatible procedure attributes";
1146       differences.IterateOverMembers([&](Attr x) {
1147         *whyNot += sep + std::string{EnumToString(x)};
1148         sep = ", ";
1149       });
1150     }
1151   } else if ((IsFunction() && actual.IsSubroutine()) ||
1152       (IsSubroutine() && actual.IsFunction())) {
1153     if (whyNot) {
1154       *whyNot =
1155           "incompatible procedures: one is a function, the other a subroutine";
1156     }
1157   } else if (functionResult && actual.functionResult &&
1158       !functionResult->IsCompatibleWith(*actual.functionResult, whyNot)) {
1159   } else if (cudaSubprogramAttrs != actual.cudaSubprogramAttrs) {
1160     if (whyNot) {
1161       *whyNot = "incompatible CUDA subprogram attributes";
1162     }
1163   } else if (dummyArguments.size() != actual.dummyArguments.size()) {
1164     if (whyNot) {
1165       *whyNot = "distinct numbers of dummy arguments";
1166     }
1167   } else {
1168     for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
1169       // Subtlety: the dummy/actual distinction must be reversed for this
1170       // compatibility test in order to correctly check extended vs.
1171       // base types.  Example:
1172       //   subroutine s1(base); subroutine s2(extended)
1173       //   procedure(s1), pointer :: p
1174       //   p => s2 ! an error, s2 is more restricted, can't handle "base"
1175       if (!actual.dummyArguments[j].IsCompatibleWith(
1176               dummyArguments[j], whyNot)) {
1177         if (whyNot) {
1178           *whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
1179               ": "s + *whyNot;
1180         }
1181         return false;
1182       }
1183     }
1184     return true;
1185   }
1186   return false;
1187 }
1188 
1189 int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
1190   int argCount{static_cast<int>(dummyArguments.size())};
1191   int index{0};
1192   if (name) {
1193     while (index < argCount && *name != dummyArguments[index].name.c_str()) {
1194       ++index;
1195     }
1196   }
1197   CHECK(index < argCount);
1198   return index;
1199 }
1200 
1201 bool Procedure::CanOverride(
1202     const Procedure &that, std::optional<int> passIndex) const {
1203   // A pure procedure may override an impure one (7.5.7.3(2))
1204   if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) ||
1205       that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) ||
1206       functionResult != that.functionResult) {
1207     return false;
1208   }
1209   int argCount{static_cast<int>(dummyArguments.size())};
1210   if (argCount != static_cast<int>(that.dummyArguments.size())) {
1211     return false;
1212   }
1213   for (int j{0}; j < argCount; ++j) {
1214     if (passIndex && j == *passIndex) {
1215       if (!that.dummyArguments[j].IsCompatibleWith(dummyArguments[j])) {
1216         return false;
1217       }
1218     } else if (dummyArguments[j] != that.dummyArguments[j]) {
1219       return false;
1220     }
1221   }
1222   return true;
1223 }
1224 
1225 std::optional<Procedure> Procedure::Characterize(
1226     const semantics::Symbol &original, FoldingContext &context) {
1227   semantics::UnorderedSymbolSet seenProcs;
1228   return CharacterizeProcedure(original, context, seenProcs);
1229 }
1230 
1231 std::optional<Procedure> Procedure::Characterize(
1232     const ProcedureDesignator &proc, FoldingContext &context) {
1233   if (const auto *symbol{proc.GetSymbol()}) {
1234     if (auto result{
1235             characteristics::Procedure::Characterize(*symbol, context)}) {
1236       return result;
1237     }
1238   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
1239     return intrinsic->characteristics.value();
1240   }
1241   return std::nullopt;
1242 }
1243 
1244 std::optional<Procedure> Procedure::Characterize(
1245     const ProcedureRef &ref, FoldingContext &context) {
1246   if (auto callee{Characterize(ref.proc(), context)}) {
1247     if (callee->functionResult) {
1248       if (const Procedure *
1249           proc{callee->functionResult->IsProcedurePointer()}) {
1250         return {*proc};
1251       }
1252     }
1253   }
1254   return std::nullopt;
1255 }
1256 
1257 std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
1258     const ActualArguments &args, FoldingContext &context) {
1259   auto callee{Characterize(proc, context)};
1260   if (callee) {
1261     if (callee->dummyArguments.empty() &&
1262         callee->attrs.test(Procedure::Attr::ImplicitInterface)) {
1263       int j{0};
1264       for (const auto &arg : args) {
1265         ++j;
1266         if (arg) {
1267           if (auto dummy{DummyArgument::FromActual(
1268                   "x"s + std::to_string(j), *arg, context)}) {
1269             callee->dummyArguments.emplace_back(std::move(*dummy));
1270             continue;
1271           }
1272         }
1273         callee.reset();
1274         break;
1275       }
1276     }
1277   }
1278   return callee;
1279 }
1280 
1281 bool Procedure::CanBeCalledViaImplicitInterface() const {
1282   // TODO: Pass back information on why we return false
1283   if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) {
1284     return false; // 15.4.2.2(5,6)
1285   } else if (cudaSubprogramAttrs &&
1286       *cudaSubprogramAttrs != common::CUDASubprogramAttrs::Host &&
1287       *cudaSubprogramAttrs != common::CUDASubprogramAttrs::Global) {
1288     return false;
1289   } else if (IsFunction() &&
1290       !functionResult->CanBeReturnedViaImplicitInterface()) {
1291     return false;
1292   } else {
1293     for (const DummyArgument &arg : dummyArguments) {
1294       if (!arg.CanBePassedViaImplicitInterface()) {
1295         return false;
1296       }
1297     }
1298     return true;
1299   }
1300 }
1301 
1302 llvm::raw_ostream &Procedure::Dump(llvm::raw_ostream &o) const {
1303   attrs.Dump(o, EnumToString);
1304   if (functionResult) {
1305     functionResult->Dump(o << "TYPE(") << ") FUNCTION";
1306   } else if (attrs.test(Attr::Subroutine)) {
1307     o << "SUBROUTINE";
1308   } else {
1309     o << "EXTERNAL";
1310   }
1311   char sep{'('};
1312   for (const auto &dummy : dummyArguments) {
1313     dummy.Dump(o << sep);
1314     sep = ',';
1315   }
1316   o << (sep == '(' ? "()" : ")");
1317   if (cudaSubprogramAttrs) {
1318     o << " cudaSubprogramAttrs: " << common::EnumToString(*cudaSubprogramAttrs);
1319   }
1320   return o;
1321 }
1322 
1323 // Utility class to determine if Procedures, etc. are distinguishable
1324 class DistinguishUtils {
1325 public:
1326   explicit DistinguishUtils(const common::LanguageFeatureControl &features)
1327       : features_{features} {}
1328 
1329   // Are these procedures distinguishable for a generic name?
1330   bool Distinguishable(const Procedure &, const Procedure &) const;
1331   // Are these procedures distinguishable for a generic operator or assignment?
1332   bool DistinguishableOpOrAssign(const Procedure &, const Procedure &) const;
1333 
1334 private:
1335   struct CountDummyProcedures {
1336     CountDummyProcedures(const DummyArguments &args) {
1337       for (const DummyArgument &arg : args) {
1338         if (std::holds_alternative<DummyProcedure>(arg.u)) {
1339           total += 1;
1340           notOptional += !arg.IsOptional();
1341         }
1342       }
1343     }
1344     int total{0};
1345     int notOptional{0};
1346   };
1347 
1348   bool Rule3Distinguishable(const Procedure &, const Procedure &) const;
1349   const DummyArgument *Rule1DistinguishingArg(
1350       const DummyArguments &, const DummyArguments &) const;
1351   int FindFirstToDistinguishByPosition(
1352       const DummyArguments &, const DummyArguments &) const;
1353   int FindLastToDistinguishByName(
1354       const DummyArguments &, const DummyArguments &) const;
1355   int CountCompatibleWith(const DummyArgument &, const DummyArguments &) const;
1356   int CountNotDistinguishableFrom(
1357       const DummyArgument &, const DummyArguments &) const;
1358   bool Distinguishable(const DummyArgument &, const DummyArgument &) const;
1359   bool Distinguishable(const DummyDataObject &, const DummyDataObject &) const;
1360   bool Distinguishable(const DummyProcedure &, const DummyProcedure &) const;
1361   bool Distinguishable(const FunctionResult &, const FunctionResult &) const;
1362   bool Distinguishable(
1363       const TypeAndShape &, const TypeAndShape &, common::IgnoreTKRSet) const;
1364   bool IsTkrCompatible(const DummyArgument &, const DummyArgument &) const;
1365   bool IsTkCompatible(const DummyDataObject &, const DummyDataObject &) const;
1366   const DummyArgument *GetAtEffectivePosition(
1367       const DummyArguments &, int) const;
1368   const DummyArgument *GetPassArg(const Procedure &) const;
1369 
1370   const common::LanguageFeatureControl &features_;
1371 };
1372 
1373 // Simpler distinguishability rules for operators and assignment
1374 bool DistinguishUtils::DistinguishableOpOrAssign(
1375     const Procedure &proc1, const Procedure &proc2) const {
1376   if ((proc1.IsFunction() && proc2.IsSubroutine()) ||
1377       (proc1.IsSubroutine() && proc2.IsFunction())) {
1378     return true;
1379   }
1380   auto &args1{proc1.dummyArguments};
1381   auto &args2{proc2.dummyArguments};
1382   if (args1.size() != args2.size()) {
1383     return true; // C1511: distinguishable based on number of arguments
1384   }
1385   for (std::size_t i{0}; i < args1.size(); ++i) {
1386     if (Distinguishable(args1[i], args2[i])) {
1387       return true; // C1511, C1512: distinguishable based on this arg
1388     }
1389   }
1390   return false;
1391 }
1392 
1393 bool DistinguishUtils::Distinguishable(
1394     const Procedure &proc1, const Procedure &proc2) const {
1395   if ((proc1.IsFunction() && proc2.IsSubroutine()) ||
1396       (proc1.IsSubroutine() && proc2.IsFunction())) {
1397     return true;
1398   }
1399   auto &args1{proc1.dummyArguments};
1400   auto &args2{proc2.dummyArguments};
1401   auto count1{CountDummyProcedures(args1)};
1402   auto count2{CountDummyProcedures(args2)};
1403   if (count1.notOptional > count2.total || count2.notOptional > count1.total) {
1404     return true; // distinguishable based on C1514 rule 2
1405   }
1406   if (Rule3Distinguishable(proc1, proc2)) {
1407     return true; // distinguishable based on C1514 rule 3
1408   }
1409   if (Rule1DistinguishingArg(args1, args2)) {
1410     return true; // distinguishable based on C1514 rule 1
1411   }
1412   int pos1{FindFirstToDistinguishByPosition(args1, args2)};
1413   int name1{FindLastToDistinguishByName(args1, args2)};
1414   if (pos1 >= 0 && pos1 <= name1) {
1415     return true; // distinguishable based on C1514 rule 4
1416   }
1417   int pos2{FindFirstToDistinguishByPosition(args2, args1)};
1418   int name2{FindLastToDistinguishByName(args2, args1)};
1419   if (pos2 >= 0 && pos2 <= name2) {
1420     return true; // distinguishable based on C1514 rule 4
1421   }
1422   if (proc1.cudaSubprogramAttrs != proc2.cudaSubprogramAttrs) {
1423     return true;
1424   }
1425   return false;
1426 }
1427 
1428 // C1514 rule 3: Procedures are distinguishable if both have a passed-object
1429 // dummy argument and those are distinguishable.
1430 bool DistinguishUtils::Rule3Distinguishable(
1431     const Procedure &proc1, const Procedure &proc2) const {
1432   const DummyArgument *pass1{GetPassArg(proc1)};
1433   const DummyArgument *pass2{GetPassArg(proc2)};
1434   return pass1 && pass2 && Distinguishable(*pass1, *pass2);
1435 }
1436 
1437 // Find a non-passed-object dummy data object in one of the argument lists
1438 // that satisfies C1514 rule 1. I.e. x such that:
1439 // - m is the number of dummy data objects in one that are nonoptional,
1440 //   are not passed-object, that x is TKR compatible with
1441 // - n is the number of non-passed-object dummy data objects, in the other
1442 //   that are not distinguishable from x
1443 // - m is greater than n
1444 const DummyArgument *DistinguishUtils::Rule1DistinguishingArg(
1445     const DummyArguments &args1, const DummyArguments &args2) const {
1446   auto size1{args1.size()};
1447   auto size2{args2.size()};
1448   for (std::size_t i{0}; i < size1 + size2; ++i) {
1449     const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]};
1450     if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) {
1451       if (CountCompatibleWith(x, args1) >
1452               CountNotDistinguishableFrom(x, args2) ||
1453           CountCompatibleWith(x, args2) >
1454               CountNotDistinguishableFrom(x, args1)) {
1455         return &x;
1456       }
1457     }
1458   }
1459   return nullptr;
1460 }
1461 
1462 // Find the index of the first nonoptional non-passed-object dummy argument
1463 // in args1 at an effective position such that either:
1464 // - args2 has no dummy argument at that effective position
1465 // - the dummy argument at that position is distinguishable from it
1466 int DistinguishUtils::FindFirstToDistinguishByPosition(
1467     const DummyArguments &args1, const DummyArguments &args2) const {
1468   int effective{0}; // position of arg1 in list, ignoring passed arg
1469   for (std::size_t i{0}; i < args1.size(); ++i) {
1470     const DummyArgument &arg1{args1.at(i)};
1471     if (!arg1.pass && !arg1.IsOptional()) {
1472       const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)};
1473       if (!arg2 || Distinguishable(arg1, *arg2)) {
1474         return i;
1475       }
1476     }
1477     effective += !arg1.pass;
1478   }
1479   return -1;
1480 }
1481 
1482 // Find the index of the last nonoptional non-passed-object dummy argument
1483 // in args1 whose name is such that either:
1484 // - args2 has no dummy argument with that name
1485 // - the dummy argument with that name is distinguishable from it
1486 int DistinguishUtils::FindLastToDistinguishByName(
1487     const DummyArguments &args1, const DummyArguments &args2) const {
1488   std::map<std::string, const DummyArgument *> nameToArg;
1489   for (const auto &arg2 : args2) {
1490     nameToArg.emplace(arg2.name, &arg2);
1491   }
1492   for (int i = args1.size() - 1; i >= 0; --i) {
1493     const DummyArgument &arg1{args1.at(i)};
1494     if (!arg1.pass && !arg1.IsOptional()) {
1495       auto it{nameToArg.find(arg1.name)};
1496       if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) {
1497         return i;
1498       }
1499     }
1500   }
1501   return -1;
1502 }
1503 
1504 // Count the dummy data objects in args that are nonoptional, are not
1505 // passed-object, and that x is TKR compatible with
1506 int DistinguishUtils::CountCompatibleWith(
1507     const DummyArgument &x, const DummyArguments &args) const {
1508   return llvm::count_if(args, [&](const DummyArgument &y) {
1509     return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y);
1510   });
1511 }
1512 
1513 // Return the number of dummy data objects in args that are not
1514 // distinguishable from x and not passed-object.
1515 int DistinguishUtils::CountNotDistinguishableFrom(
1516     const DummyArgument &x, const DummyArguments &args) const {
1517   return llvm::count_if(args, [&](const DummyArgument &y) {
1518     return !y.pass && std::holds_alternative<DummyDataObject>(y.u) &&
1519         !Distinguishable(y, x);
1520   });
1521 }
1522 
1523 bool DistinguishUtils::Distinguishable(
1524     const DummyArgument &x, const DummyArgument &y) const {
1525   if (x.u.index() != y.u.index()) {
1526     return true; // different kind: data/proc/alt-return
1527   }
1528   return common::visit(
1529       common::visitors{
1530           [&](const DummyDataObject &z) {
1531             return Distinguishable(z, std::get<DummyDataObject>(y.u));
1532           },
1533           [&](const DummyProcedure &z) {
1534             return Distinguishable(z, std::get<DummyProcedure>(y.u));
1535           },
1536           [&](const AlternateReturn &) { return false; },
1537       },
1538       x.u);
1539 }
1540 
1541 bool DistinguishUtils::Distinguishable(
1542     const DummyDataObject &x, const DummyDataObject &y) const {
1543   using Attr = DummyDataObject::Attr;
1544   if (Distinguishable(x.type, y.type, x.ignoreTKR | y.ignoreTKR)) {
1545     return true;
1546   } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
1547       y.intent != common::Intent::In) {
1548     return true;
1549   } else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) &&
1550       x.intent != common::Intent::In) {
1551     return true;
1552   } else if (!common::AreCompatibleCUDADataAttrs(
1553                  x.cudaDataAttr, y.cudaDataAttr, x.ignoreTKR | y.ignoreTKR)) {
1554     return true;
1555   } else if (features_.IsEnabled(
1556                  common::LanguageFeature::DistinguishableSpecifics) &&
1557       (x.attrs.test(Attr::Allocatable) || x.attrs.test(Attr::Pointer)) &&
1558       (y.attrs.test(Attr::Allocatable) || y.attrs.test(Attr::Pointer)) &&
1559       (x.type.type().IsUnlimitedPolymorphic() !=
1560               y.type.type().IsUnlimitedPolymorphic() ||
1561           x.type.type().IsPolymorphic() != y.type.type().IsPolymorphic())) {
1562     // Extension: Per 15.5.2.5(2), an allocatable/pointer dummy and its
1563     // corresponding actual argument must both or neither be polymorphic,
1564     // and must both or neither be unlimited polymorphic.  So when exactly
1565     // one of two dummy arguments is polymorphic or unlimited polymorphic,
1566     // any actual argument that is admissible to one of them cannot also match
1567     // the other one.
1568     return true;
1569   } else {
1570     return false;
1571   }
1572 }
1573 
1574 bool DistinguishUtils::Distinguishable(
1575     const DummyProcedure &x, const DummyProcedure &y) const {
1576   const Procedure &xProc{x.procedure.value()};
1577   const Procedure &yProc{y.procedure.value()};
1578   if (Distinguishable(xProc, yProc)) {
1579     return true;
1580   } else {
1581     const std::optional<FunctionResult> &xResult{xProc.functionResult};
1582     const std::optional<FunctionResult> &yResult{yProc.functionResult};
1583     return xResult ? !yResult || Distinguishable(*xResult, *yResult)
1584                    : yResult.has_value();
1585   }
1586 }
1587 
1588 bool DistinguishUtils::Distinguishable(
1589     const FunctionResult &x, const FunctionResult &y) const {
1590   if (x.u.index() != y.u.index()) {
1591     return true; // one is data object, one is procedure
1592   }
1593   if (x.cudaDataAttr != y.cudaDataAttr) {
1594     return true;
1595   }
1596   return common::visit(
1597       common::visitors{
1598           [&](const TypeAndShape &z) {
1599             return Distinguishable(
1600                 z, std::get<TypeAndShape>(y.u), common::IgnoreTKRSet{});
1601           },
1602           [&](const CopyableIndirection<Procedure> &z) {
1603             return Distinguishable(z.value(),
1604                 std::get<CopyableIndirection<Procedure>>(y.u).value());
1605           },
1606       },
1607       x.u);
1608 }
1609 
1610 bool DistinguishUtils::Distinguishable(const TypeAndShape &x,
1611     const TypeAndShape &y, common::IgnoreTKRSet ignoreTKR) const {
1612   if (!x.type().IsTkCompatibleWith(y.type(), ignoreTKR) &&
1613       !y.type().IsTkCompatibleWith(x.type(), ignoreTKR)) {
1614     return true;
1615   }
1616   if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
1617   } else if (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1618       y.attrs().test(TypeAndShape::Attr::AssumedRank)) {
1619   } else if (x.Rank() != y.Rank()) {
1620     return true;
1621   }
1622   return false;
1623 }
1624 
1625 // Compatibility based on type, kind, and rank
1626 
1627 bool DistinguishUtils::IsTkrCompatible(
1628     const DummyArgument &x, const DummyArgument &y) const {
1629   const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
1630   const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
1631   return obj1 && obj2 && IsTkCompatible(*obj1, *obj2) &&
1632       (obj1->type.Rank() == obj2->type.Rank() ||
1633           obj1->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1634           obj2->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1635           obj1->ignoreTKR.test(common::IgnoreTKR::Rank) ||
1636           obj2->ignoreTKR.test(common::IgnoreTKR::Rank));
1637 }
1638 
1639 bool DistinguishUtils::IsTkCompatible(
1640     const DummyDataObject &x, const DummyDataObject &y) const {
1641   return x.type.type().IsTkCompatibleWith(
1642       y.type.type(), x.ignoreTKR | y.ignoreTKR);
1643 }
1644 
1645 // Return the argument at the given index, ignoring the passed arg
1646 const DummyArgument *DistinguishUtils::GetAtEffectivePosition(
1647     const DummyArguments &args, int index) const {
1648   for (const DummyArgument &arg : args) {
1649     if (!arg.pass) {
1650       if (index == 0) {
1651         return &arg;
1652       }
1653       --index;
1654     }
1655   }
1656   return nullptr;
1657 }
1658 
1659 // Return the passed-object dummy argument of this procedure, if any
1660 const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) const {
1661   for (const auto &arg : proc.dummyArguments) {
1662     if (arg.pass) {
1663       return &arg;
1664     }
1665   }
1666   return nullptr;
1667 }
1668 
1669 bool Distinguishable(const common::LanguageFeatureControl &features,
1670     const Procedure &x, const Procedure &y) {
1671   return DistinguishUtils{features}.Distinguishable(x, y);
1672 }
1673 
1674 bool DistinguishableOpOrAssign(const common::LanguageFeatureControl &features,
1675     const Procedure &x, const Procedure &y) {
1676   return DistinguishUtils{features}.DistinguishableOpOrAssign(x, y);
1677 }
1678 
1679 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument)
1680 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
1681 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
1682 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
1683 } // namespace Fortran::evaluate::characteristics
1684 
1685 template class Fortran::common::Indirection<
1686     Fortran::evaluate::characteristics::Procedure, true>;
1687