1 //===-- lib/Semantics/resolve-names-utils.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 "resolve-names-utils.h"
10 #include "flang/Common/Fortran-features.h"
11 #include "flang/Common/idioms.h"
12 #include "flang/Common/indirection.h"
13 #include "flang/Evaluate/fold.h"
14 #include "flang/Evaluate/tools.h"
15 #include "flang/Evaluate/type.h"
16 #include "flang/Parser/char-block.h"
17 #include "flang/Parser/parse-tree.h"
18 #include "flang/Semantics/expression.h"
19 #include "flang/Semantics/semantics.h"
20 #include "flang/Semantics/tools.h"
21 #include <initializer_list>
22 #include <variant>
23 
24 namespace Fortran::semantics {
25 
26 using common::LanguageFeature;
27 using common::LogicalOperator;
28 using common::NumericOperator;
29 using common::RelationalOperator;
30 using IntrinsicOperator = parser::DefinedOperator::IntrinsicOperator;
31 
32 static GenericKind MapIntrinsicOperator(IntrinsicOperator);
33 
34 Symbol *Resolve(const parser::Name &name, Symbol *symbol) {
35   if (symbol && !name.symbol) {
36     name.symbol = symbol;
37   }
38   return symbol;
39 }
40 Symbol &Resolve(const parser::Name &name, Symbol &symbol) {
41   return *Resolve(name, &symbol);
42 }
43 
44 parser::MessageFixedText WithIsFatal(
45     const parser::MessageFixedText &msg, bool isFatal) {
46   return parser::MessageFixedText{
47       msg.text().begin(), msg.text().size(), isFatal};
48 }
49 
50 bool IsIntrinsicOperator(
51     const SemanticsContext &context, const SourceName &name) {
52   std::string str{name.ToString()};
53   for (int i{0}; i != common::LogicalOperator_enumSize; ++i) {
54     auto names{context.languageFeatures().GetNames(LogicalOperator{i})};
55     if (std::find(names.begin(), names.end(), str) != names.end()) {
56       return true;
57     }
58   }
59   for (int i{0}; i != common::RelationalOperator_enumSize; ++i) {
60     auto names{context.languageFeatures().GetNames(RelationalOperator{i})};
61     if (std::find(names.begin(), names.end(), str) != names.end()) {
62       return true;
63     }
64   }
65   return false;
66 }
67 
68 bool IsLogicalConstant(
69     const SemanticsContext &context, const SourceName &name) {
70   std::string str{name.ToString()};
71   return str == ".true." || str == ".false." ||
72       (context.IsEnabled(LanguageFeature::LogicalAbbreviations) &&
73           (str == ".t" || str == ".f."));
74 }
75 
76 // The operators <, <=, >, >=, ==, and /= always have the same interpretations
77 // as the operators .LT., .LE., .GT., .GE., .EQ., and .NE., respectively.
78 std::forward_list<std::string> GenericSpecInfo::GetAllNames(
79     SemanticsContext &context) const {
80   auto getNames{[&](auto opr) {
81     std::forward_list<std::string> result;
82     for (const char *name : context.languageFeatures().GetNames(opr)) {
83       result.emplace_front("operator("s + name + ')');
84     }
85     return result;
86   }};
87   return std::visit(
88       common::visitors{[&](const LogicalOperator &x) { return getNames(x); },
89           [&](const RelationalOperator &x) { return getNames(x); },
90           [&](const auto &) -> std::forward_list<std::string> {
91             return {symbolName_.value().ToString()};
92           }},
93       kind_.u);
94 }
95 
96 Symbol *GenericSpecInfo::FindInScope(
97     SemanticsContext &context, const Scope &scope) const {
98   for (const auto &name : GetAllNames(context)) {
99     auto iter{scope.find(SourceName{name})};
100     if (iter != scope.end()) {
101       return &*iter->second;
102     }
103   }
104   return nullptr;
105 }
106 
107 void GenericSpecInfo::Resolve(Symbol *symbol) const {
108   if (symbol) {
109     if (auto *details{symbol->detailsIf<GenericDetails>()}) {
110       details->set_kind(kind_);
111     }
112     if (parseName_) {
113       semantics::Resolve(*parseName_, symbol);
114     }
115   }
116 }
117 
118 void GenericSpecInfo::Analyze(const parser::DefinedOpName &name) {
119   kind_ = GenericKind::OtherKind::DefinedOp;
120   parseName_ = &name.v;
121   symbolName_ = name.v.source;
122 }
123 
124 void GenericSpecInfo::Analyze(const parser::GenericSpec &x) {
125   symbolName_ = x.source;
126   kind_ = std::visit(
127       common::visitors{
128           [&](const parser::Name &y) -> GenericKind {
129             parseName_ = &y;
130             symbolName_ = y.source;
131             return GenericKind::OtherKind::Name;
132           },
133           [&](const parser::DefinedOperator &y) {
134             return std::visit(
135                 common::visitors{
136                     [&](const parser::DefinedOpName &z) -> GenericKind {
137                       Analyze(z);
138                       return GenericKind::OtherKind::DefinedOp;
139                     },
140                     [&](const IntrinsicOperator &z) {
141                       return MapIntrinsicOperator(z);
142                     },
143                 },
144                 y.u);
145           },
146           [&](const parser::GenericSpec::Assignment &) -> GenericKind {
147             return GenericKind::OtherKind::Assignment;
148           },
149           [&](const parser::GenericSpec::ReadFormatted &) -> GenericKind {
150             return GenericKind::DefinedIo::ReadFormatted;
151           },
152           [&](const parser::GenericSpec::ReadUnformatted &) -> GenericKind {
153             return GenericKind::DefinedIo::ReadUnformatted;
154           },
155           [&](const parser::GenericSpec::WriteFormatted &) -> GenericKind {
156             return GenericKind::DefinedIo::WriteFormatted;
157           },
158           [&](const parser::GenericSpec::WriteUnformatted &) -> GenericKind {
159             return GenericKind::DefinedIo::WriteUnformatted;
160           },
161       },
162       x.u);
163 }
164 
165 // parser::DefinedOperator::IntrinsicOperator -> GenericKind
166 static GenericKind MapIntrinsicOperator(IntrinsicOperator op) {
167   switch (op) {
168     SWITCH_COVERS_ALL_CASES
169   case IntrinsicOperator::Concat:
170     return GenericKind::OtherKind::Concat;
171   case IntrinsicOperator::Power:
172     return NumericOperator::Power;
173   case IntrinsicOperator::Multiply:
174     return NumericOperator::Multiply;
175   case IntrinsicOperator::Divide:
176     return NumericOperator::Divide;
177   case IntrinsicOperator::Add:
178     return NumericOperator::Add;
179   case IntrinsicOperator::Subtract:
180     return NumericOperator::Subtract;
181   case IntrinsicOperator::AND:
182     return LogicalOperator::And;
183   case IntrinsicOperator::OR:
184     return LogicalOperator::Or;
185   case IntrinsicOperator::EQV:
186     return LogicalOperator::Eqv;
187   case IntrinsicOperator::NEQV:
188     return LogicalOperator::Neqv;
189   case IntrinsicOperator::NOT:
190     return LogicalOperator::Not;
191   case IntrinsicOperator::LT:
192     return RelationalOperator::LT;
193   case IntrinsicOperator::LE:
194     return RelationalOperator::LE;
195   case IntrinsicOperator::EQ:
196     return RelationalOperator::EQ;
197   case IntrinsicOperator::NE:
198     return RelationalOperator::NE;
199   case IntrinsicOperator::GE:
200     return RelationalOperator::GE;
201   case IntrinsicOperator::GT:
202     return RelationalOperator::GT;
203   }
204 }
205 
206 class ArraySpecAnalyzer {
207 public:
208   ArraySpecAnalyzer(SemanticsContext &context) : context_{context} {}
209   ArraySpec Analyze(const parser::ArraySpec &);
210   ArraySpec Analyze(const parser::ComponentArraySpec &);
211   ArraySpec Analyze(const parser::CoarraySpec &);
212 
213 private:
214   SemanticsContext &context_;
215   ArraySpec arraySpec_;
216 
217   template <typename T> void Analyze(const std::list<T> &list) {
218     for (const auto &elem : list) {
219       Analyze(elem);
220     }
221   }
222   void Analyze(const parser::AssumedShapeSpec &);
223   void Analyze(const parser::ExplicitShapeSpec &);
224   void Analyze(const parser::AssumedImpliedSpec &);
225   void Analyze(const parser::DeferredShapeSpecList &);
226   void Analyze(const parser::AssumedRankSpec &);
227   void MakeExplicit(const std::optional<parser::SpecificationExpr> &,
228       const parser::SpecificationExpr &);
229   void MakeImplied(const std::optional<parser::SpecificationExpr> &);
230   void MakeDeferred(int);
231   Bound GetBound(const std::optional<parser::SpecificationExpr> &);
232   Bound GetBound(const parser::SpecificationExpr &);
233 };
234 
235 ArraySpec AnalyzeArraySpec(
236     SemanticsContext &context, const parser::ArraySpec &arraySpec) {
237   return ArraySpecAnalyzer{context}.Analyze(arraySpec);
238 }
239 ArraySpec AnalyzeArraySpec(
240     SemanticsContext &context, const parser::ComponentArraySpec &arraySpec) {
241   return ArraySpecAnalyzer{context}.Analyze(arraySpec);
242 }
243 ArraySpec AnalyzeCoarraySpec(
244     SemanticsContext &context, const parser::CoarraySpec &coarraySpec) {
245   return ArraySpecAnalyzer{context}.Analyze(coarraySpec);
246 }
247 
248 ArraySpec ArraySpecAnalyzer::Analyze(const parser::ComponentArraySpec &x) {
249   std::visit([this](const auto &y) { Analyze(y); }, x.u);
250   CHECK(!arraySpec_.empty());
251   return arraySpec_;
252 }
253 ArraySpec ArraySpecAnalyzer::Analyze(const parser::ArraySpec &x) {
254   std::visit(common::visitors{
255                  [&](const parser::AssumedSizeSpec &y) {
256                    Analyze(std::get<std::list<parser::ExplicitShapeSpec>>(y.t));
257                    Analyze(std::get<parser::AssumedImpliedSpec>(y.t));
258                  },
259                  [&](const parser::ImpliedShapeSpec &y) { Analyze(y.v); },
260                  [&](const auto &y) { Analyze(y); },
261              },
262       x.u);
263   CHECK(!arraySpec_.empty());
264   return arraySpec_;
265 }
266 ArraySpec ArraySpecAnalyzer::Analyze(const parser::CoarraySpec &x) {
267   std::visit(
268       common::visitors{
269           [&](const parser::DeferredCoshapeSpecList &y) { MakeDeferred(y.v); },
270           [&](const parser::ExplicitCoshapeSpec &y) {
271             Analyze(std::get<std::list<parser::ExplicitShapeSpec>>(y.t));
272             MakeImplied(
273                 std::get<std::optional<parser::SpecificationExpr>>(y.t));
274           },
275       },
276       x.u);
277   CHECK(!arraySpec_.empty());
278   return arraySpec_;
279 }
280 
281 void ArraySpecAnalyzer::Analyze(const parser::AssumedShapeSpec &x) {
282   arraySpec_.push_back(ShapeSpec::MakeAssumed(GetBound(x.v)));
283 }
284 void ArraySpecAnalyzer::Analyze(const parser::ExplicitShapeSpec &x) {
285   MakeExplicit(std::get<std::optional<parser::SpecificationExpr>>(x.t),
286       std::get<parser::SpecificationExpr>(x.t));
287 }
288 void ArraySpecAnalyzer::Analyze(const parser::AssumedImpliedSpec &x) {
289   MakeImplied(x.v);
290 }
291 void ArraySpecAnalyzer::Analyze(const parser::DeferredShapeSpecList &x) {
292   MakeDeferred(x.v);
293 }
294 void ArraySpecAnalyzer::Analyze(const parser::AssumedRankSpec &) {
295   arraySpec_.push_back(ShapeSpec::MakeAssumedRank());
296 }
297 
298 void ArraySpecAnalyzer::MakeExplicit(
299     const std::optional<parser::SpecificationExpr> &lb,
300     const parser::SpecificationExpr &ub) {
301   arraySpec_.push_back(ShapeSpec::MakeExplicit(GetBound(lb), GetBound(ub)));
302 }
303 void ArraySpecAnalyzer::MakeImplied(
304     const std::optional<parser::SpecificationExpr> &lb) {
305   arraySpec_.push_back(ShapeSpec::MakeImplied(GetBound(lb)));
306 }
307 void ArraySpecAnalyzer::MakeDeferred(int n) {
308   for (int i = 0; i < n; ++i) {
309     arraySpec_.push_back(ShapeSpec::MakeDeferred());
310   }
311 }
312 
313 Bound ArraySpecAnalyzer::GetBound(
314     const std::optional<parser::SpecificationExpr> &x) {
315   return x ? GetBound(*x) : Bound{1};
316 }
317 Bound ArraySpecAnalyzer::GetBound(const parser::SpecificationExpr &x) {
318   MaybeSubscriptIntExpr expr;
319   if (MaybeExpr maybeExpr{AnalyzeExpr(context_, x.v)}) {
320     if (auto *intExpr{evaluate::UnwrapExpr<SomeIntExpr>(*maybeExpr)}) {
321       expr = evaluate::Fold(context_.foldingContext(),
322           evaluate::ConvertToType<evaluate::SubscriptInteger>(
323               std::move(*intExpr)));
324     }
325   }
326   return Bound{std::move(expr)};
327 }
328 
329 // If SAVE is set on src, set it on all members of dst
330 static void PropagateSaveAttr(
331     const EquivalenceObject &src, EquivalenceSet &dst) {
332   if (src.symbol.attrs().test(Attr::SAVE)) {
333     for (auto &obj : dst) {
334       obj.symbol.attrs().set(Attr::SAVE);
335     }
336   }
337 }
338 static void PropagateSaveAttr(const EquivalenceSet &src, EquivalenceSet &dst) {
339   if (!src.empty()) {
340     PropagateSaveAttr(src.front(), dst);
341   }
342 }
343 
344 void EquivalenceSets::AddToSet(const parser::Designator &designator) {
345   if (CheckDesignator(designator)) {
346     Symbol &symbol{*currObject_.symbol};
347     if (!currSet_.empty()) {
348       // check this symbol against first of set for compatibility
349       Symbol &first{currSet_.front().symbol};
350       CheckCanEquivalence(designator.source, first, symbol) &&
351           CheckCanEquivalence(designator.source, symbol, first);
352     }
353     auto subscripts{currObject_.subscripts};
354     if (subscripts.empty() && symbol.IsObjectArray()) {
355       // record a whole array as its first element
356       for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) {
357         auto &lbound{spec.lbound().GetExplicit().value()};
358         subscripts.push_back(evaluate::ToInt64(lbound).value());
359       }
360     }
361     auto substringStart{currObject_.substringStart};
362     currSet_.emplace_back(
363         symbol, subscripts, substringStart, designator.source);
364     PropagateSaveAttr(currSet_.back(), currSet_);
365   }
366   currObject_ = {};
367 }
368 
369 void EquivalenceSets::FinishSet(const parser::CharBlock &source) {
370   std::set<std::size_t> existing; // indices of sets intersecting this one
371   for (auto &obj : currSet_) {
372     auto it{objectToSet_.find(obj)};
373     if (it != objectToSet_.end()) {
374       existing.insert(it->second); // symbol already in this set
375     }
376   }
377   if (existing.empty()) {
378     sets_.push_back({}); // create a new equivalence set
379     MergeInto(source, currSet_, sets_.size() - 1);
380   } else {
381     auto it{existing.begin()};
382     std::size_t dstIndex{*it};
383     MergeInto(source, currSet_, dstIndex);
384     while (++it != existing.end()) {
385       MergeInto(source, sets_[*it], dstIndex);
386     }
387   }
388   currSet_.clear();
389 }
390 
391 // Report an error if sym1 and sym2 cannot be in the same equivalence set.
392 bool EquivalenceSets::CheckCanEquivalence(
393     const parser::CharBlock &source, const Symbol &sym1, const Symbol &sym2) {
394   std::optional<parser::MessageFixedText> msg;
395   const DeclTypeSpec *type1{sym1.GetType()};
396   const DeclTypeSpec *type2{sym2.GetType()};
397   bool isNum1{IsNumericSequenceType(type1)};
398   bool isNum2{IsNumericSequenceType(type2)};
399   bool isChar1{IsCharacterSequenceType(type1)};
400   bool isChar2{IsCharacterSequenceType(type2)};
401   if (sym1.attrs().test(Attr::PROTECTED) &&
402       !sym2.attrs().test(Attr::PROTECTED)) { // C8114
403     msg = "Equivalence set cannot contain '%s'"
404           " with PROTECTED attribute and '%s' without"_err_en_US;
405   } else if (isNum1) {
406     if (isChar2) {
407       if (context_.ShouldWarn(
408               LanguageFeature::EquivalenceNumericWithCharacter)) {
409         msg = "Equivalence set contains '%s' that is numeric sequence "
410               "type and '%s' that is character"_en_US;
411       }
412     } else if (!isNum2) { // C8110
413       msg = "Equivalence set cannot contain '%s'"
414             " that is numeric sequence type and '%s' that is not"_err_en_US;
415     }
416   } else if (isChar1) {
417     if (isNum2) {
418       if (context_.ShouldWarn(
419               LanguageFeature::EquivalenceNumericWithCharacter)) {
420         msg = "Equivalence set contains '%s' that is character sequence "
421               "type and '%s' that is numeric"_en_US;
422       }
423     } else if (!isChar2) { // C8111
424       msg = "Equivalence set cannot contain '%s'"
425             " that is character sequence type and '%s' that is not"_err_en_US;
426     }
427   } else if (!isNum2 && !isChar2 && *type1 != *type2) { // C8112, C8113
428     msg = "Equivalence set cannot contain '%s' and '%s' with different types"
429           " that are neither numeric nor character sequence types"_err_en_US;
430   }
431   if (msg) {
432     context_.Say(source, std::move(*msg), sym1.name(), sym2.name());
433     return false;
434   }
435   return true;
436 }
437 
438 // Move objects from src to sets_[dstIndex]
439 void EquivalenceSets::MergeInto(const parser::CharBlock &source,
440     EquivalenceSet &src, std::size_t dstIndex) {
441   EquivalenceSet &dst{sets_[dstIndex]};
442   PropagateSaveAttr(dst, src);
443   for (const auto &obj : src) {
444     dst.push_back(obj);
445     objectToSet_[obj] = dstIndex;
446   }
447   PropagateSaveAttr(src, dst);
448   src.clear();
449 }
450 
451 // If set has an object with this symbol, return it.
452 const EquivalenceObject *EquivalenceSets::Find(
453     const EquivalenceSet &set, const Symbol &symbol) {
454   for (const auto &obj : set) {
455     if (obj.symbol == symbol) {
456       return &obj;
457     }
458   }
459   return nullptr;
460 }
461 
462 bool EquivalenceSets::CheckDesignator(const parser::Designator &designator) {
463   return std::visit(
464       common::visitors{
465           [&](const parser::DataRef &x) {
466             return CheckDataRef(designator.source, x);
467           },
468           [&](const parser::Substring &x) {
469             const auto &dataRef{std::get<parser::DataRef>(x.t)};
470             const auto &range{std::get<parser::SubstringRange>(x.t)};
471             bool ok{CheckDataRef(designator.source, dataRef)};
472             if (const auto &lb{std::get<0>(range.t)}) {
473               ok &= CheckSubstringBound(lb->thing.thing.value(), true);
474             } else {
475               currObject_.substringStart = 1;
476             }
477             if (const auto &ub{std::get<1>(range.t)}) {
478               ok &= CheckSubstringBound(ub->thing.thing.value(), false);
479             }
480             return ok;
481           },
482       },
483       designator.u);
484 }
485 
486 bool EquivalenceSets::CheckDataRef(
487     const parser::CharBlock &source, const parser::DataRef &x) {
488   return std::visit(
489       common::visitors{
490           [&](const parser::Name &name) { return CheckObject(name); },
491           [&](const common::Indirection<parser::StructureComponent> &) {
492             context_.Say(source, // C8107
493                 "Derived type component '%s' is not allowed in an equivalence set"_err_en_US,
494                 source);
495             return false;
496           },
497           [&](const common::Indirection<parser::ArrayElement> &elem) {
498             bool ok{CheckDataRef(source, elem.value().base)};
499             for (const auto &subscript : elem.value().subscripts) {
500               ok &= std::visit(
501                   common::visitors{
502                       [&](const parser::SubscriptTriplet &) {
503                         context_.Say(source, // C924, R872
504                             "Array section '%s' is not allowed in an equivalence set"_err_en_US,
505                             source);
506                         return false;
507                       },
508                       [&](const parser::IntExpr &y) {
509                         return CheckArrayBound(y.thing.value());
510                       },
511                   },
512                   subscript.u);
513             }
514             return ok;
515           },
516           [&](const common::Indirection<parser::CoindexedNamedObject> &) {
517             context_.Say(source, // C924 (R872)
518                 "Coindexed object '%s' is not allowed in an equivalence set"_err_en_US,
519                 source);
520             return false;
521           },
522       },
523       x.u);
524 }
525 
526 static bool InCommonWithBind(const Symbol &symbol) {
527   if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
528     const Symbol *commonBlock{details->commonBlock()};
529     return commonBlock && commonBlock->attrs().test(Attr::BIND_C);
530   } else {
531     return false;
532   }
533 }
534 
535 // If symbol can't be in equivalence set report error and return false;
536 bool EquivalenceSets::CheckObject(const parser::Name &name) {
537   if (!name.symbol) {
538     return false; // an error has already occurred
539   }
540   currObject_.symbol = name.symbol;
541   parser::MessageFixedText msg{"", 0};
542   const Symbol &symbol{*name.symbol};
543   if (symbol.owner().IsDerivedType()) { // C8107
544     msg = "Derived type component '%s'"
545           " is not allowed in an equivalence set"_err_en_US;
546   } else if (IsDummy(symbol)) { // C8106
547     msg = "Dummy argument '%s' is not allowed in an equivalence set"_err_en_US;
548   } else if (symbol.IsFuncResult()) { // C8106
549     msg = "Function result '%s' is not allow in an equivalence set"_err_en_US;
550   } else if (IsPointer(symbol)) { // C8106
551     msg = "Pointer '%s' is not allowed in an equivalence set"_err_en_US;
552   } else if (IsAllocatable(symbol)) { // C8106
553     msg = "Allocatable variable '%s'"
554           " is not allowed in an equivalence set"_err_en_US;
555   } else if (symbol.Corank() > 0) { // C8106
556     msg = "Coarray '%s' is not allowed in an equivalence set"_err_en_US;
557   } else if (symbol.has<UseDetails>()) { // C8115
558     msg = "Use-associated variable '%s'"
559           " is not allowed in an equivalence set"_err_en_US;
560   } else if (symbol.attrs().test(Attr::BIND_C)) { // C8106
561     msg = "Variable '%s' with BIND attribute"
562           " is not allowed in an equivalence set"_err_en_US;
563   } else if (symbol.attrs().test(Attr::TARGET)) { // C8108
564     msg = "Variable '%s' with TARGET attribute"
565           " is not allowed in an equivalence set"_err_en_US;
566   } else if (IsNamedConstant(symbol)) { // C8106
567     msg = "Named constant '%s' is not allowed in an equivalence set"_err_en_US;
568   } else if (InCommonWithBind(symbol)) { // C8106
569     msg = "Variable '%s' in common block with BIND attribute"
570           " is not allowed in an equivalence set"_err_en_US;
571   } else if (const auto *type{symbol.GetType()}) {
572     if (const auto *derived{type->AsDerived()}) {
573       if (const auto *comp{FindUltimateComponent(
574               *derived, IsAllocatableOrPointer)}) { // C8106
575         msg = IsPointer(*comp)
576             ? "Derived type object '%s' with pointer ultimate component"
577               " is not allowed in an equivalence set"_err_en_US
578             : "Derived type object '%s' with allocatable ultimate component"
579               " is not allowed in an equivalence set"_err_en_US;
580       } else if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {
581         msg = "Nonsequence derived type object '%s'"
582               " is not allowed in an equivalence set"_err_en_US;
583       }
584     } else if (IsAutomaticObject(symbol)) {
585       msg = "Automatic object '%s'"
586             " is not allowed in an equivalence set"_err_en_US;
587     }
588   }
589   if (!msg.text().empty()) {
590     context_.Say(name.source, std::move(msg), name.source);
591     return false;
592   }
593   return true;
594 }
595 
596 bool EquivalenceSets::CheckArrayBound(const parser::Expr &bound) {
597   MaybeExpr expr{
598       evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};
599   if (!expr) {
600     return false;
601   }
602   if (expr->Rank() > 0) {
603     context_.Say(bound.source, // C924, R872
604         "Array with vector subscript '%s' is not allowed in an equivalence set"_err_en_US,
605         bound.source);
606     return false;
607   }
608   auto subscript{evaluate::ToInt64(*expr)};
609   if (!subscript) {
610     context_.Say(bound.source, // C8109
611         "Array with nonconstant subscript '%s' is not allowed in an equivalence set"_err_en_US,
612         bound.source);
613     return false;
614   }
615   currObject_.subscripts.push_back(*subscript);
616   return true;
617 }
618 
619 bool EquivalenceSets::CheckSubstringBound(
620     const parser::Expr &bound, bool isStart) {
621   MaybeExpr expr{
622       evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};
623   if (!expr) {
624     return false;
625   }
626   auto subscript{evaluate::ToInt64(*expr)};
627   if (!subscript) {
628     context_.Say(bound.source, // C8109
629         "Substring with nonconstant bound '%s' is not allowed in an equivalence set"_err_en_US,
630         bound.source);
631     return false;
632   }
633   if (!isStart) {
634     auto start{currObject_.substringStart};
635     if (*subscript < (start ? *start : 1)) {
636       context_.Say(bound.source, // C8116
637           "Substring with zero length is not allowed in an equivalence set"_err_en_US);
638       return false;
639     }
640   } else if (*subscript != 1) {
641     currObject_.substringStart = *subscript;
642   }
643   return true;
644 }
645 
646 bool EquivalenceSets::IsCharacterSequenceType(const DeclTypeSpec *type) {
647   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
648     auto kind{evaluate::ToInt64(type.kind())};
649     return type.category() == TypeCategory::Character && kind &&
650         kind.value() == context_.GetDefaultKind(TypeCategory::Character);
651   });
652 }
653 
654 // Numeric or logical type of default kind or DOUBLE PRECISION or DOUBLE COMPLEX
655 bool EquivalenceSets::IsDefaultKindNumericType(const IntrinsicTypeSpec &type) {
656   if (auto kind{evaluate::ToInt64(type.kind())}) {
657     auto category{type.category()};
658     auto defaultKind{context_.GetDefaultKind(category)};
659     switch (category) {
660     case TypeCategory::Integer:
661     case TypeCategory::Logical:
662       return *kind == defaultKind;
663     case TypeCategory::Real:
664     case TypeCategory::Complex:
665       return *kind == defaultKind || *kind == context_.doublePrecisionKind();
666     default:
667       return false;
668     }
669   }
670   return false;
671 }
672 
673 bool EquivalenceSets::IsNumericSequenceType(const DeclTypeSpec *type) {
674   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
675     return IsDefaultKindNumericType(type);
676   });
677 }
678 
679 // Is type an intrinsic type that satisfies predicate or a sequence type
680 // whose components do.
681 bool EquivalenceSets::IsSequenceType(const DeclTypeSpec *type,
682     std::function<bool(const IntrinsicTypeSpec &)> predicate) {
683   if (!type) {
684     return false;
685   } else if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) {
686     return predicate(*intrinsic);
687   } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
688     for (const auto &pair : *derived->typeSymbol().scope()) {
689       const Symbol &component{*pair.second};
690       if (IsAllocatableOrPointer(component) ||
691           !IsSequenceType(component.GetType(), predicate)) {
692         return false;
693       }
694     }
695     return true;
696   } else {
697     return false;
698   }
699 }
700 
701 } // namespace Fortran::semantics
702