xref: /llvm-project/flang/lib/Evaluate/characteristics.cpp (revision 934b27a9daf6cff8cb32d6e49eaf6ff8f69c7727) 
1 //===-- lib/Evaluate/characteristics.cpp ----------------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8 
9 #include "flang/Evaluate/characteristics.h"
10 #include "flang/Common/indirection.h"
11 #include "flang/Evaluate/check-expression.h"
12 #include "flang/Evaluate/fold.h"
13 #include "flang/Evaluate/intrinsics.h"
14 #include "flang/Evaluate/tools.h"
15 #include "flang/Evaluate/type.h"
16 #include "flang/Parser/message.h"
17 #include "flang/Semantics/scope.h"
18 #include "flang/Semantics/symbol.h"
19 #include "llvm/Support/raw_ostream.h"
20 #include <initializer_list>
21 
22 using namespace Fortran::parser::literals;
23 
24 namespace Fortran::evaluate::characteristics {
25 
26 // Copy attributes from a symbol to dst based on the mapping in pairs.
27 template <typename A, typename B>
28 static void CopyAttrs(const semantics::Symbol &src, A &dst,
29     const std::initializer_list<std::pair<semantics::Attr, B>> &pairs) {
30   for (const auto &pair : pairs) {
31     if (src.attrs().test(pair.first)) {
32       dst.attrs.set(pair.second);
33     }
34   }
35 }
36 
37 // Shapes of function results and dummy arguments have to have
38 // the same rank, the same deferred dimensions, and the same
39 // values for explicit dimensions when constant.
40 bool ShapesAreCompatible(const Shape &x, const Shape &y) {
41   if (x.size() != y.size()) {
42     return false;
43   }
44   auto yIter{y.begin()};
45   for (const auto &xDim : x) {
46     const auto &yDim{*yIter++};
47     if (xDim) {
48       if (!yDim || ToInt64(*xDim) != ToInt64(*yDim)) {
49         return false;
50       }
51     } else if (yDim) {
52       return false;
53     }
54   }
55   return true;
56 }
57 
58 bool TypeAndShape::operator==(const TypeAndShape &that) const {
59   return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) &&
60       attrs_ == that.attrs_ && corank_ == that.corank_;
61 }
62 
63 std::optional<TypeAndShape> TypeAndShape::Characterize(
64     const semantics::Symbol &symbol, FoldingContext &context) {
65   return std::visit(
66       common::visitors{
67           [&](const semantics::ObjectEntityDetails &object) {
68             auto result{Characterize(object)};
69             if (result &&
70                 result->type().category() == TypeCategory::Character) {
71               if (auto len{DataRef{symbol}.LEN()}) {
72                 result->set_LEN(Fold(context, std::move(*len)));
73               }
74             }
75             return result;
76           },
77           [&](const semantics::ProcEntityDetails &proc) {
78             const semantics::ProcInterface &interface{proc.interface()};
79             if (interface.type()) {
80               return Characterize(*interface.type());
81             } else if (interface.symbol()) {
82               return Characterize(*interface.symbol(), context);
83             } else {
84               return std::optional<TypeAndShape>{};
85             }
86           },
87           [&](const semantics::UseDetails &use) {
88             return Characterize(use.symbol(), context);
89           },
90           [&](const semantics::HostAssocDetails &assoc) {
91             return Characterize(assoc.symbol(), context);
92           },
93           [&](const semantics::AssocEntityDetails &assoc) {
94             return Characterize(assoc, context);
95           },
96           [](const auto &) { return std::optional<TypeAndShape>{}; },
97       },
98       symbol.details());
99 }
100 
101 std::optional<TypeAndShape> TypeAndShape::Characterize(
102     const semantics::ObjectEntityDetails &object) {
103   if (auto type{DynamicType::From(object.type())}) {
104     TypeAndShape result{std::move(*type)};
105     result.AcquireShape(object);
106     return result;
107   } else {
108     return std::nullopt;
109   }
110 }
111 
112 std::optional<TypeAndShape> TypeAndShape::Characterize(
113     const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
114   if (auto type{DynamicType::From(assoc.type())}) {
115     if (auto shape{GetShape(context, assoc.expr())}) {
116       TypeAndShape result{std::move(*type), std::move(*shape)};
117       if (type->category() == TypeCategory::Character) {
118         if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc.expr())}) {
119           if (auto len{chExpr->LEN()}) {
120             result.set_LEN(Fold(context, std::move(*len)));
121           }
122         }
123       }
124       return std::move(result);
125     }
126   }
127   return std::nullopt;
128 }
129 
130 std::optional<TypeAndShape> TypeAndShape::Characterize(
131     const semantics::DeclTypeSpec &spec) {
132   if (auto type{DynamicType::From(spec)}) {
133     return TypeAndShape{std::move(*type)};
134   } else {
135     return std::nullopt;
136   }
137 }
138 
139 std::optional<TypeAndShape> TypeAndShape::Characterize(
140     const ActualArgument &arg, FoldingContext &context) {
141   return Characterize(arg.UnwrapExpr(), context);
142 }
143 
144 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
145     const TypeAndShape &that, const char *thisIs, const char *thatIs,
146     bool isElemental) const {
147   if (!type_.IsTkCompatibleWith(that.type_)) {
148     const auto &len{that.LEN()};
149     messages.Say(
150         "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
151         thatIs, that.type_.AsFortran(len ? len->AsFortran() : ""), thisIs,
152         type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""));
153     return false;
154   }
155   return isElemental ||
156       CheckConformance(messages, shape_, that.shape_, thisIs, thatIs);
157 }
158 
159 std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(
160     FoldingContext *foldingContext) const {
161   if (type_.category() == TypeCategory::Character && LEN_) {
162     Expr<SubscriptInteger> result{
163         common::Clone(*LEN_) * Expr<SubscriptInteger>{type_.kind()}};
164     if (foldingContext) {
165       result = Fold(*foldingContext, std::move(result));
166     }
167     return result;
168   } else {
169     return type_.MeasureSizeInBytes(foldingContext);
170   }
171 }
172 
173 void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
174   CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank));
175   corank_ = object.coshape().Rank();
176   if (object.IsAssumedRank()) {
177     attrs_.set(Attr::AssumedRank);
178     return;
179   }
180   if (object.IsAssumedShape()) {
181     attrs_.set(Attr::AssumedShape);
182   }
183   if (object.IsAssumedSize()) {
184     attrs_.set(Attr::AssumedSize);
185   }
186   if (object.IsDeferredShape()) {
187     attrs_.set(Attr::DeferredShape);
188   }
189   if (object.IsCoarray()) {
190     attrs_.set(Attr::Coarray);
191   }
192   for (const semantics::ShapeSpec &dim : object.shape()) {
193     if (dim.ubound().GetExplicit()) {
194       Expr<SubscriptInteger> extent{*dim.ubound().GetExplicit()};
195       if (auto lbound{dim.lbound().GetExplicit()}) {
196         extent =
197             std::move(extent) + Expr<SubscriptInteger>{1} - std::move(*lbound);
198       }
199       shape_.emplace_back(std::move(extent));
200     } else {
201       shape_.push_back(std::nullopt);
202     }
203   }
204 }
205 
206 void TypeAndShape::AcquireLEN() {
207   if (type_.category() == TypeCategory::Character) {
208     if (const auto *param{type_.charLength()}) {
209       if (const auto &intExpr{param->GetExplicit()}) {
210         LEN_ = ConvertToType<SubscriptInteger>(common::Clone(*intExpr));
211       }
212     }
213   }
214 }
215 
216 llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
217   o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
218   attrs_.Dump(o, EnumToString);
219   if (!shape_.empty()) {
220     o << " dimension";
221     char sep{'('};
222     for (const auto &expr : shape_) {
223       o << sep;
224       sep = ',';
225       if (expr) {
226         expr->AsFortran(o);
227       } else {
228         o << ':';
229       }
230     }
231     o << ')';
232   }
233   return o;
234 }
235 
236 bool DummyDataObject::operator==(const DummyDataObject &that) const {
237   return type == that.type && attrs == that.attrs && intent == that.intent &&
238       coshape == that.coshape;
239 }
240 
241 static common::Intent GetIntent(const semantics::Attrs &attrs) {
242   if (attrs.test(semantics::Attr::INTENT_IN)) {
243     return common::Intent::In;
244   } else if (attrs.test(semantics::Attr::INTENT_OUT)) {
245     return common::Intent::Out;
246   } else if (attrs.test(semantics::Attr::INTENT_INOUT)) {
247     return common::Intent::InOut;
248   } else {
249     return common::Intent::Default;
250   }
251 }
252 
253 std::optional<DummyDataObject> DummyDataObject::Characterize(
254     const semantics::Symbol &symbol) {
255   if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
256     if (auto type{TypeAndShape::Characterize(*obj)}) {
257       std::optional<DummyDataObject> result{std::move(*type)};
258       using semantics::Attr;
259       CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
260           {
261               {Attr::OPTIONAL, DummyDataObject::Attr::Optional},
262               {Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable},
263               {Attr::ASYNCHRONOUS, DummyDataObject::Attr::Asynchronous},
264               {Attr::CONTIGUOUS, DummyDataObject::Attr::Contiguous},
265               {Attr::VALUE, DummyDataObject::Attr::Value},
266               {Attr::VOLATILE, DummyDataObject::Attr::Volatile},
267               {Attr::POINTER, DummyDataObject::Attr::Pointer},
268               {Attr::TARGET, DummyDataObject::Attr::Target},
269           });
270       result->intent = GetIntent(symbol.attrs());
271       return result;
272     }
273   }
274   return std::nullopt;
275 }
276 
277 bool DummyDataObject::CanBePassedViaImplicitInterface() const {
278   if ((attrs &
279           Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional,
280               Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile})
281           .any()) {
282     return false; // 15.4.2.2(3)(a)
283   } else if ((type.attrs() &
284                  TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape,
285                      TypeAndShape::Attr::AssumedRank,
286                      TypeAndShape::Attr::Coarray})
287                  .any()) {
288     return false; // 15.4.2.2(3)(b-d)
289   } else if (type.type().IsPolymorphic()) {
290     return false; // 15.4.2.2(3)(f)
291   } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) {
292     return derived->parameters().empty(); // 15.4.2.2(3)(e)
293   } else {
294     return true;
295   }
296 }
297 
298 llvm::raw_ostream &DummyDataObject::Dump(llvm::raw_ostream &o) const {
299   attrs.Dump(o, EnumToString);
300   if (intent != common::Intent::Default) {
301     o << "INTENT(" << common::EnumToString(intent) << ')';
302   }
303   type.Dump(o);
304   if (!coshape.empty()) {
305     char sep{'['};
306     for (const auto &expr : coshape) {
307       expr.AsFortran(o << sep);
308       sep = ',';
309     }
310   }
311   return o;
312 }
313 
314 DummyProcedure::DummyProcedure(Procedure &&p)
315     : procedure{new Procedure{std::move(p)}} {}
316 
317 bool DummyProcedure::operator==(const DummyProcedure &that) const {
318   return attrs == that.attrs && intent == that.intent &&
319       procedure.value() == that.procedure.value();
320 }
321 
322 std::optional<DummyProcedure> DummyProcedure::Characterize(
323     const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
324   if (auto procedure{Procedure::Characterize(symbol, intrinsics)}) {
325     // Dummy procedures may not be elemental.  Elemental dummy procedure
326     // interfaces are errors when the interface is not intrinsic, and that
327     // error is caught elsewhere.  Elemental intrinsic interfaces are
328     // made non-elemental.
329     procedure->attrs.reset(Procedure::Attr::Elemental);
330     DummyProcedure result{std::move(procedure.value())};
331     CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result,
332         {
333             {semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional},
334             {semantics::Attr::POINTER, DummyProcedure::Attr::Pointer},
335         });
336     result.intent = GetIntent(symbol.attrs());
337     return result;
338   } else {
339     return std::nullopt;
340   }
341 }
342 
343 llvm::raw_ostream &DummyProcedure::Dump(llvm::raw_ostream &o) const {
344   attrs.Dump(o, EnumToString);
345   if (intent != common::Intent::Default) {
346     o << "INTENT(" << common::EnumToString(intent) << ')';
347   }
348   procedure.value().Dump(o);
349   return o;
350 }
351 
352 llvm::raw_ostream &AlternateReturn::Dump(llvm::raw_ostream &o) const {
353   return o << '*';
354 }
355 
356 DummyArgument::~DummyArgument() {}
357 
358 bool DummyArgument::operator==(const DummyArgument &that) const {
359   return u == that.u; // name and passed-object usage are not characteristics
360 }
361 
362 std::optional<DummyArgument> DummyArgument::Characterize(
363     const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
364   auto name{symbol.name().ToString()};
365   if (symbol.has<semantics::ObjectEntityDetails>()) {
366     if (auto obj{DummyDataObject::Characterize(symbol)}) {
367       return DummyArgument{std::move(name), std::move(obj.value())};
368     }
369   } else if (auto proc{DummyProcedure::Characterize(symbol, intrinsics)}) {
370     return DummyArgument{std::move(name), std::move(proc.value())};
371   }
372   return std::nullopt;
373 }
374 
375 std::optional<DummyArgument> DummyArgument::FromActual(
376     std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
377   return std::visit(
378       common::visitors{
379           [&](const BOZLiteralConstant &) {
380             return std::make_optional<DummyArgument>(std::move(name),
381                 DummyDataObject{
382                     TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
383           },
384           [&](const NullPointer &) {
385             return std::make_optional<DummyArgument>(std::move(name),
386                 DummyDataObject{
387                     TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
388           },
389           [&](const ProcedureDesignator &designator) {
390             if (auto proc{Procedure::Characterize(
391                     designator, context.intrinsics())}) {
392               return std::make_optional<DummyArgument>(
393                   std::move(name), DummyProcedure{std::move(*proc)});
394             } else {
395               return std::optional<DummyArgument>{};
396             }
397           },
398           [&](const ProcedureRef &call) {
399             if (auto proc{
400                     Procedure::Characterize(call, context.intrinsics())}) {
401               return std::make_optional<DummyArgument>(
402                   std::move(name), DummyProcedure{std::move(*proc)});
403             } else {
404               return std::optional<DummyArgument>{};
405             }
406           },
407           [&](const auto &) {
408             if (auto type{TypeAndShape::Characterize(expr, context)}) {
409               return std::make_optional<DummyArgument>(
410                   std::move(name), DummyDataObject{std::move(*type)});
411             } else {
412               return std::optional<DummyArgument>{};
413             }
414           },
415       },
416       expr.u);
417 }
418 
419 bool DummyArgument::IsOptional() const {
420   return std::visit(
421       common::visitors{
422           [](const DummyDataObject &data) {
423             return data.attrs.test(DummyDataObject::Attr::Optional);
424           },
425           [](const DummyProcedure &proc) {
426             return proc.attrs.test(DummyProcedure::Attr::Optional);
427           },
428           [](const AlternateReturn &) { return false; },
429       },
430       u);
431 }
432 
433 void DummyArgument::SetOptional(bool value) {
434   std::visit(common::visitors{
435                  [value](DummyDataObject &data) {
436                    data.attrs.set(DummyDataObject::Attr::Optional, value);
437                  },
438                  [value](DummyProcedure &proc) {
439                    proc.attrs.set(DummyProcedure::Attr::Optional, value);
440                  },
441                  [](AlternateReturn &) { DIE("cannot set optional"); },
442              },
443       u);
444 }
445 
446 void DummyArgument::SetIntent(common::Intent intent) {
447   std::visit(common::visitors{
448                  [intent](DummyDataObject &data) { data.intent = intent; },
449                  [intent](DummyProcedure &proc) { proc.intent = intent; },
450                  [](AlternateReturn &) { DIE("cannot set intent"); },
451              },
452       u);
453 }
454 
455 common::Intent DummyArgument::GetIntent() const {
456   return std::visit(common::visitors{
457                         [](const DummyDataObject &data) { return data.intent; },
458                         [](const DummyProcedure &proc) { return proc.intent; },
459                         [](const AlternateReturn &) -> common::Intent {
460                           DIE("Alternate return have no intent");
461                         },
462                     },
463       u);
464 }
465 
466 bool DummyArgument::CanBePassedViaImplicitInterface() const {
467   if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
468     return object->CanBePassedViaImplicitInterface();
469   } else {
470     return true;
471   }
472 }
473 
474 bool DummyArgument::IsTypelessIntrinsicDummy() const {
475   const auto *argObj{std::get_if<characteristics::DummyDataObject>(&u)};
476   return argObj && argObj->type.type().IsTypelessIntrinsicArgument();
477 }
478 
479 llvm::raw_ostream &DummyArgument::Dump(llvm::raw_ostream &o) const {
480   if (!name.empty()) {
481     o << name << '=';
482   }
483   if (pass) {
484     o << " PASS";
485   }
486   std::visit([&](const auto &x) { x.Dump(o); }, u);
487   return o;
488 }
489 
490 FunctionResult::FunctionResult(DynamicType t) : u{TypeAndShape{t}} {}
491 FunctionResult::FunctionResult(TypeAndShape &&t) : u{std::move(t)} {}
492 FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {}
493 FunctionResult::~FunctionResult() {}
494 
495 bool FunctionResult::operator==(const FunctionResult &that) const {
496   return attrs == that.attrs && u == that.u;
497 }
498 
499 std::optional<FunctionResult> FunctionResult::Characterize(
500     const Symbol &symbol, const IntrinsicProcTable &intrinsics) {
501   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
502     if (auto type{TypeAndShape::Characterize(*object)}) {
503       FunctionResult result{std::move(*type)};
504       CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
505           {
506               {semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable},
507               {semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous},
508               {semantics::Attr::POINTER, FunctionResult::Attr::Pointer},
509           });
510       return result;
511     }
512   } else if (auto maybeProc{Procedure::Characterize(symbol, intrinsics)}) {
513     FunctionResult result{std::move(*maybeProc)};
514     result.attrs.set(FunctionResult::Attr::Pointer);
515     return result;
516   }
517   return std::nullopt;
518 }
519 
520 bool FunctionResult::IsAssumedLengthCharacter() const {
521   if (const auto *ts{std::get_if<TypeAndShape>(&u)}) {
522     return ts->type().IsAssumedLengthCharacter();
523   } else {
524     return false;
525   }
526 }
527 
528 bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
529   if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) {
530     return false; // 15.4.2.2(4)(b)
531   } else if (const auto *typeAndShape{GetTypeAndShape()}) {
532     if (typeAndShape->Rank() > 0) {
533       return false; // 15.4.2.2(4)(a)
534     } else {
535       const DynamicType &type{typeAndShape->type()};
536       switch (type.category()) {
537       case TypeCategory::Character:
538         if (const auto *param{type.charLength()}) {
539           if (const auto &expr{param->GetExplicit()}) {
540             return IsConstantExpr(*expr); // 15.4.2.2(4)(c)
541           } else if (param->isAssumed()) {
542             return true;
543           }
544         }
545         return false;
546       case TypeCategory::Derived:
547         if (!type.IsPolymorphic()) {
548           const auto &spec{type.GetDerivedTypeSpec()};
549           for (const auto &pair : spec.parameters()) {
550             if (const auto &expr{pair.second.GetExplicit()}) {
551               if (!IsConstantExpr(*expr)) {
552                 return false; // 15.4.2.2(4)(c)
553               }
554             }
555           }
556           return true;
557         }
558         return false;
559       default:
560         return true;
561       }
562     }
563   } else {
564     return false; // 15.4.2.2(4)(b) - procedure pointer
565   }
566 }
567 
568 llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
569   attrs.Dump(o, EnumToString);
570   std::visit(common::visitors{
571                  [&](const TypeAndShape &ts) { ts.Dump(o); },
572                  [&](const CopyableIndirection<Procedure> &p) {
573                    p.value().Dump(o << " procedure(") << ')';
574                  },
575              },
576       u);
577   return o;
578 }
579 
580 Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
581     : functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {
582 }
583 Procedure::Procedure(DummyArguments &&args, Attrs a)
584     : dummyArguments{std::move(args)}, attrs{a} {}
585 Procedure::~Procedure() {}
586 
587 bool Procedure::operator==(const Procedure &that) const {
588   return attrs == that.attrs && functionResult == that.functionResult &&
589       dummyArguments == that.dummyArguments;
590 }
591 
592 int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
593   int argCount{static_cast<int>(dummyArguments.size())};
594   int index{0};
595   if (name) {
596     while (index < argCount && *name != dummyArguments[index].name.c_str()) {
597       ++index;
598     }
599   }
600   CHECK(index < argCount);
601   return index;
602 }
603 
604 bool Procedure::CanOverride(
605     const Procedure &that, std::optional<int> passIndex) const {
606   // A pure procedure may override an impure one (7.5.7.3(2))
607   if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) ||
608       that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) ||
609       functionResult != that.functionResult) {
610     return false;
611   }
612   int argCount{static_cast<int>(dummyArguments.size())};
613   if (argCount != static_cast<int>(that.dummyArguments.size())) {
614     return false;
615   }
616   for (int j{0}; j < argCount; ++j) {
617     if ((!passIndex || j != *passIndex) &&
618         dummyArguments[j] != that.dummyArguments[j]) {
619       return false;
620     }
621   }
622   return true;
623 }
624 
625 std::optional<Procedure> Procedure::Characterize(
626     const semantics::Symbol &original, const IntrinsicProcTable &intrinsics) {
627   Procedure result;
628   const auto &symbol{ResolveAssociations(original)};
629   CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
630       {
631           {semantics::Attr::PURE, Procedure::Attr::Pure},
632           {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
633           {semantics::Attr::BIND_C, Procedure::Attr::BindC},
634       });
635   if (result.attrs.test(Attr::Elemental) &&
636       !symbol.attrs().test(semantics::Attr::IMPURE)) {
637     result.attrs.set(Attr::Pure); // explicitly flag pure procedures
638   }
639   return std::visit(
640       common::visitors{
641           [&](const semantics::SubprogramDetails &subp)
642               -> std::optional<Procedure> {
643             if (subp.isFunction()) {
644               if (auto fr{FunctionResult::Characterize(
645                       subp.result(), intrinsics)}) {
646                 result.functionResult = std::move(fr);
647               } else {
648                 return std::nullopt;
649               }
650             } else {
651               result.attrs.set(Attr::Subroutine);
652             }
653             for (const semantics::Symbol *arg : subp.dummyArgs()) {
654               if (!arg) {
655                 result.dummyArguments.emplace_back(AlternateReturn{});
656               } else if (auto argCharacteristics{
657                              DummyArgument::Characterize(*arg, intrinsics)}) {
658                 result.dummyArguments.emplace_back(
659                     std::move(argCharacteristics.value()));
660               } else {
661                 return std::nullopt;
662               }
663             }
664             return result;
665           },
666           [&](const semantics::ProcEntityDetails &proc)
667               -> std::optional<Procedure> {
668             if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
669               return intrinsics.IsSpecificIntrinsicFunction(
670                   symbol.name().ToString());
671             }
672             const semantics::ProcInterface &interface{proc.interface()};
673             if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
674               return Characterize(*interfaceSymbol, intrinsics);
675             } else {
676               result.attrs.set(Attr::ImplicitInterface);
677               const semantics::DeclTypeSpec *type{interface.type()};
678               if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
679                 // ignore any implicit typing
680                 result.attrs.set(Attr::Subroutine);
681               } else if (type) {
682                 if (auto resultType{DynamicType::From(*type)}) {
683                   result.functionResult = FunctionResult{*resultType};
684                 } else {
685                   return std::nullopt;
686                 }
687               } else if (symbol.test(semantics::Symbol::Flag::Function)) {
688                 return std::nullopt;
689               }
690               // The PASS name, if any, is not a characteristic.
691               return result;
692             }
693           },
694           [&](const semantics::ProcBindingDetails &binding) {
695             if (auto result{Characterize(binding.symbol(), intrinsics)}) {
696               if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
697                 auto passName{binding.passName()};
698                 for (auto &dummy : result->dummyArguments) {
699                   if (!passName || dummy.name.c_str() == *passName) {
700                     dummy.pass = true;
701                     return result;
702                   }
703                 }
704                 DIE("PASS argument missing");
705               }
706               return result;
707             } else {
708               return std::optional<Procedure>{};
709             }
710           },
711           [&](const semantics::UseDetails &use) {
712             return Characterize(use.symbol(), intrinsics);
713           },
714           [&](const semantics::HostAssocDetails &assoc) {
715             return Characterize(assoc.symbol(), intrinsics);
716           },
717           [](const auto &) { return std::optional<Procedure>{}; },
718       },
719       symbol.details());
720 }
721 
722 std::optional<Procedure> Procedure::Characterize(
723     const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) {
724   if (const auto *symbol{proc.GetSymbol()}) {
725     if (auto result{characteristics::Procedure::Characterize(
726             ResolveAssociations(*symbol), intrinsics)}) {
727       return result;
728     }
729   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
730     return intrinsic->characteristics.value();
731   }
732   return std::nullopt;
733 }
734 
735 std::optional<Procedure> Procedure::Characterize(
736     const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) {
737   if (auto callee{Characterize(ref.proc(), intrinsics)}) {
738     if (callee->functionResult) {
739       if (const Procedure *
740           proc{callee->functionResult->IsProcedurePointer()}) {
741         return {*proc};
742       }
743     }
744   }
745   return std::nullopt;
746 }
747 
748 bool Procedure::CanBeCalledViaImplicitInterface() const {
749   if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) {
750     return false; // 15.4.2.2(5,6)
751   } else if (IsFunction() &&
752       !functionResult->CanBeReturnedViaImplicitInterface()) {
753     return false;
754   } else {
755     for (const DummyArgument &arg : dummyArguments) {
756       if (!arg.CanBePassedViaImplicitInterface()) {
757         return false;
758       }
759     }
760     return true;
761   }
762 }
763 
764 llvm::raw_ostream &Procedure::Dump(llvm::raw_ostream &o) const {
765   attrs.Dump(o, EnumToString);
766   if (functionResult) {
767     functionResult->Dump(o << "TYPE(") << ") FUNCTION";
768   } else {
769     o << "SUBROUTINE";
770   }
771   char sep{'('};
772   for (const auto &dummy : dummyArguments) {
773     dummy.Dump(o << sep);
774     sep = ',';
775   }
776   return o << (sep == '(' ? "()" : ")");
777 }
778 
779 // Utility class to determine if Procedures, etc. are distinguishable
780 class DistinguishUtils {
781 public:
782   // Are these procedures distinguishable for a generic name?
783   static bool Distinguishable(const Procedure &, const Procedure &);
784   // Are these procedures distinguishable for a generic operator or assignment?
785   static bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);
786 
787 private:
788   struct CountDummyProcedures {
789     CountDummyProcedures(const DummyArguments &args) {
790       for (const DummyArgument &arg : args) {
791         if (std::holds_alternative<DummyProcedure>(arg.u)) {
792           total += 1;
793           notOptional += !arg.IsOptional();
794         }
795       }
796     }
797     int total{0};
798     int notOptional{0};
799   };
800 
801   static bool Rule3Distinguishable(const Procedure &, const Procedure &);
802   static const DummyArgument *Rule1DistinguishingArg(
803       const DummyArguments &, const DummyArguments &);
804   static int FindFirstToDistinguishByPosition(
805       const DummyArguments &, const DummyArguments &);
806   static int FindLastToDistinguishByName(
807       const DummyArguments &, const DummyArguments &);
808   static int CountCompatibleWith(const DummyArgument &, const DummyArguments &);
809   static int CountNotDistinguishableFrom(
810       const DummyArgument &, const DummyArguments &);
811   static bool Distinguishable(const DummyArgument &, const DummyArgument &);
812   static bool Distinguishable(const DummyDataObject &, const DummyDataObject &);
813   static bool Distinguishable(const DummyProcedure &, const DummyProcedure &);
814   static bool Distinguishable(const FunctionResult &, const FunctionResult &);
815   static bool Distinguishable(const TypeAndShape &, const TypeAndShape &);
816   static bool IsTkrCompatible(const DummyArgument &, const DummyArgument &);
817   static bool IsTkrCompatible(const TypeAndShape &, const TypeAndShape &);
818   static const DummyArgument *GetAtEffectivePosition(
819       const DummyArguments &, int);
820   static const DummyArgument *GetPassArg(const Procedure &);
821 };
822 
823 // Simpler distinguishability rules for operators and assignment
824 bool DistinguishUtils::DistinguishableOpOrAssign(
825     const Procedure &proc1, const Procedure &proc2) {
826   auto &args1{proc1.dummyArguments};
827   auto &args2{proc2.dummyArguments};
828   if (args1.size() != args2.size()) {
829     return true; // C1511: distinguishable based on number of arguments
830   }
831   for (std::size_t i{0}; i < args1.size(); ++i) {
832     if (Distinguishable(args1[i], args2[i])) {
833       return true; // C1511, C1512: distinguishable based on this arg
834     }
835   }
836   return false;
837 }
838 
839 bool DistinguishUtils::Distinguishable(
840     const Procedure &proc1, const Procedure &proc2) {
841   auto &args1{proc1.dummyArguments};
842   auto &args2{proc2.dummyArguments};
843   auto count1{CountDummyProcedures(args1)};
844   auto count2{CountDummyProcedures(args2)};
845   if (count1.notOptional > count2.total || count2.notOptional > count1.total) {
846     return true; // distinguishable based on C1514 rule 2
847   }
848   if (Rule3Distinguishable(proc1, proc2)) {
849     return true; // distinguishable based on C1514 rule 3
850   }
851   if (Rule1DistinguishingArg(args1, args2)) {
852     return true; // distinguishable based on C1514 rule 1
853   }
854   int pos1{FindFirstToDistinguishByPosition(args1, args2)};
855   int name1{FindLastToDistinguishByName(args1, args2)};
856   if (pos1 >= 0 && pos1 <= name1) {
857     return true; // distinguishable based on C1514 rule 4
858   }
859   int pos2{FindFirstToDistinguishByPosition(args2, args1)};
860   int name2{FindLastToDistinguishByName(args2, args1)};
861   if (pos2 >= 0 && pos2 <= name2) {
862     return true; // distinguishable based on C1514 rule 4
863   }
864   return false;
865 }
866 
867 // C1514 rule 3: Procedures are distinguishable if both have a passed-object
868 // dummy argument and those are distinguishable.
869 bool DistinguishUtils::Rule3Distinguishable(
870     const Procedure &proc1, const Procedure &proc2) {
871   const DummyArgument *pass1{GetPassArg(proc1)};
872   const DummyArgument *pass2{GetPassArg(proc2)};
873   return pass1 && pass2 && Distinguishable(*pass1, *pass2);
874 }
875 
876 // Find a non-passed-object dummy data object in one of the argument lists
877 // that satisfies C1514 rule 1. I.e. x such that:
878 // - m is the number of dummy data objects in one that are nonoptional,
879 //   are not passed-object, that x is TKR compatible with
880 // - n is the number of non-passed-object dummy data objects, in the other
881 //   that are not distinguishable from x
882 // - m is greater than n
883 const DummyArgument *DistinguishUtils::Rule1DistinguishingArg(
884     const DummyArguments &args1, const DummyArguments &args2) {
885   auto size1{args1.size()};
886   auto size2{args2.size()};
887   for (std::size_t i{0}; i < size1 + size2; ++i) {
888     const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]};
889     if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) {
890       if (CountCompatibleWith(x, args1) >
891               CountNotDistinguishableFrom(x, args2) ||
892           CountCompatibleWith(x, args2) >
893               CountNotDistinguishableFrom(x, args1)) {
894         return &x;
895       }
896     }
897   }
898   return nullptr;
899 }
900 
901 // Find the index of the first nonoptional non-passed-object dummy argument
902 // in args1 at an effective position such that either:
903 // - args2 has no dummy argument at that effective position
904 // - the dummy argument at that position is distinguishable from it
905 int DistinguishUtils::FindFirstToDistinguishByPosition(
906     const DummyArguments &args1, const DummyArguments &args2) {
907   int effective{0}; // position of arg1 in list, ignoring passed arg
908   for (std::size_t i{0}; i < args1.size(); ++i) {
909     const DummyArgument &arg1{args1.at(i)};
910     if (!arg1.pass && !arg1.IsOptional()) {
911       const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)};
912       if (!arg2 || Distinguishable(arg1, *arg2)) {
913         return i;
914       }
915     }
916     effective += !arg1.pass;
917   }
918   return -1;
919 }
920 
921 // Find the index of the last nonoptional non-passed-object dummy argument
922 // in args1 whose name is such that either:
923 // - args2 has no dummy argument with that name
924 // - the dummy argument with that name is distinguishable from it
925 int DistinguishUtils::FindLastToDistinguishByName(
926     const DummyArguments &args1, const DummyArguments &args2) {
927   std::map<std::string, const DummyArgument *> nameToArg;
928   for (const auto &arg2 : args2) {
929     nameToArg.emplace(arg2.name, &arg2);
930   }
931   for (int i = args1.size() - 1; i >= 0; --i) {
932     const DummyArgument &arg1{args1.at(i)};
933     if (!arg1.pass && !arg1.IsOptional()) {
934       auto it{nameToArg.find(arg1.name)};
935       if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) {
936         return i;
937       }
938     }
939   }
940   return -1;
941 }
942 
943 // Count the dummy data objects in args that are nonoptional, are not
944 // passed-object, and that x is TKR compatible with
945 int DistinguishUtils::CountCompatibleWith(
946     const DummyArgument &x, const DummyArguments &args) {
947   return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) {
948     return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y);
949   });
950 }
951 
952 // Return the number of dummy data objects in args that are not
953 // distinguishable from x and not passed-object.
954 int DistinguishUtils::CountNotDistinguishableFrom(
955     const DummyArgument &x, const DummyArguments &args) {
956   return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) {
957     return !y.pass && std::holds_alternative<DummyDataObject>(y.u) &&
958         !Distinguishable(y, x);
959   });
960 }
961 
962 bool DistinguishUtils::Distinguishable(
963     const DummyArgument &x, const DummyArgument &y) {
964   if (x.u.index() != y.u.index()) {
965     return true; // different kind: data/proc/alt-return
966   }
967   return std::visit(
968       common::visitors{
969           [&](const DummyDataObject &z) {
970             return Distinguishable(z, std::get<DummyDataObject>(y.u));
971           },
972           [&](const DummyProcedure &z) {
973             return Distinguishable(z, std::get<DummyProcedure>(y.u));
974           },
975           [&](const AlternateReturn &) { return false; },
976       },
977       x.u);
978 }
979 
980 bool DistinguishUtils::Distinguishable(
981     const DummyDataObject &x, const DummyDataObject &y) {
982   using Attr = DummyDataObject::Attr;
983   if (Distinguishable(x.type, y.type)) {
984     return true;
985   } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
986       y.intent != common::Intent::In) {
987     return true;
988   } else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) &&
989       x.intent != common::Intent::In) {
990     return true;
991   } else {
992     return false;
993   }
994 }
995 
996 bool DistinguishUtils::Distinguishable(
997     const DummyProcedure &x, const DummyProcedure &y) {
998   const Procedure &xProc{x.procedure.value()};
999   const Procedure &yProc{y.procedure.value()};
1000   if (Distinguishable(xProc, yProc)) {
1001     return true;
1002   } else {
1003     const std::optional<FunctionResult> &xResult{xProc.functionResult};
1004     const std::optional<FunctionResult> &yResult{yProc.functionResult};
1005     return xResult ? !yResult || Distinguishable(*xResult, *yResult)
1006                    : yResult.has_value();
1007   }
1008 }
1009 
1010 bool DistinguishUtils::Distinguishable(
1011     const FunctionResult &x, const FunctionResult &y) {
1012   if (x.u.index() != y.u.index()) {
1013     return true; // one is data object, one is procedure
1014   }
1015   return std::visit(
1016       common::visitors{
1017           [&](const TypeAndShape &z) {
1018             return Distinguishable(z, std::get<TypeAndShape>(y.u));
1019           },
1020           [&](const CopyableIndirection<Procedure> &z) {
1021             return Distinguishable(z.value(),
1022                 std::get<CopyableIndirection<Procedure>>(y.u).value());
1023           },
1024       },
1025       x.u);
1026 }
1027 
1028 bool DistinguishUtils::Distinguishable(
1029     const TypeAndShape &x, const TypeAndShape &y) {
1030   return !IsTkrCompatible(x, y) && !IsTkrCompatible(y, x);
1031 }
1032 
1033 // Compatibility based on type, kind, and rank
1034 bool DistinguishUtils::IsTkrCompatible(
1035     const DummyArgument &x, const DummyArgument &y) {
1036   const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
1037   const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
1038   return obj1 && obj2 && IsTkrCompatible(obj1->type, obj2->type);
1039 }
1040 bool DistinguishUtils::IsTkrCompatible(
1041     const TypeAndShape &x, const TypeAndShape &y) {
1042   return x.type().IsTkCompatibleWith(y.type()) &&
1043       (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1044           y.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1045           x.Rank() == y.Rank());
1046 }
1047 
1048 // Return the argument at the given index, ignoring the passed arg
1049 const DummyArgument *DistinguishUtils::GetAtEffectivePosition(
1050     const DummyArguments &args, int index) {
1051   for (const DummyArgument &arg : args) {
1052     if (!arg.pass) {
1053       if (index == 0) {
1054         return &arg;
1055       }
1056       --index;
1057     }
1058   }
1059   return nullptr;
1060 }
1061 
1062 // Return the passed-object dummy argument of this procedure, if any
1063 const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) {
1064   for (const auto &arg : proc.dummyArguments) {
1065     if (arg.pass) {
1066       return &arg;
1067     }
1068   }
1069   return nullptr;
1070 }
1071 
1072 bool Distinguishable(const Procedure &x, const Procedure &y) {
1073   return DistinguishUtils::Distinguishable(x, y);
1074 }
1075 
1076 bool DistinguishableOpOrAssign(const Procedure &x, const Procedure &y) {
1077   return DistinguishUtils::DistinguishableOpOrAssign(x, y);
1078 }
1079 
1080 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument)
1081 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
1082 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
1083 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
1084 } // namespace Fortran::evaluate::characteristics
1085 
1086 template class Fortran::common::Indirection<
1087     Fortran::evaluate::characteristics::Procedure, true>;
1088