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