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