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