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