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