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