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