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