xref: /llvm-project/flang/lib/Semantics/resolve-names-utils.cpp (revision 11d07d9ef618497b825badee8b4f06a48575606b) 
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/traverse.h"
17 #include "flang/Evaluate/type.h"
18 #include "flang/Parser/char-block.h"
19 #include "flang/Parser/parse-tree.h"
20 #include "flang/Semantics/expression.h"
21 #include "flang/Semantics/semantics.h"
22 #include "flang/Semantics/tools.h"
23 #include <initializer_list>
24 #include <variant>
25 
26 namespace Fortran::semantics {
27 
28 using common::LanguageFeature;
29 using common::LogicalOperator;
30 using common::NumericOperator;
31 using common::RelationalOperator;
32 using IntrinsicOperator = parser::DefinedOperator::IntrinsicOperator;
33 
34 static constexpr const char *operatorPrefix{"operator("};
35 
36 static GenericKind MapIntrinsicOperator(IntrinsicOperator);
37 
38 Symbol *Resolve(const parser::Name &name, Symbol *symbol) {
39   if (symbol && !name.symbol) {
40     name.symbol = symbol;
41   }
42   return symbol;
43 }
44 Symbol &Resolve(const parser::Name &name, Symbol &symbol) {
45   return *Resolve(name, &symbol);
46 }
47 
48 parser::MessageFixedText WithSeverity(
49     const parser::MessageFixedText &msg, parser::Severity severity) {
50   return parser::MessageFixedText{
51       msg.text().begin(), msg.text().size(), severity};
52 }
53 
54 bool IsIntrinsicOperator(
55     const SemanticsContext &context, const SourceName &name) {
56   std::string str{name.ToString()};
57   for (int i{0}; i != common::LogicalOperator_enumSize; ++i) {
58     auto names{context.languageFeatures().GetNames(LogicalOperator{i})};
59     if (llvm::is_contained(names, str)) {
60       return true;
61     }
62   }
63   for (int i{0}; i != common::RelationalOperator_enumSize; ++i) {
64     auto names{context.languageFeatures().GetNames(RelationalOperator{i})};
65     if (llvm::is_contained(names, str)) {
66       return true;
67     }
68   }
69   return false;
70 }
71 
72 template <typename E>
73 std::forward_list<std::string> GetOperatorNames(
74     const SemanticsContext &context, E opr) {
75   std::forward_list<std::string> result;
76   for (const char *name : context.languageFeatures().GetNames(opr)) {
77     result.emplace_front(std::string{operatorPrefix} + name + ')');
78   }
79   return result;
80 }
81 
82 std::forward_list<std::string> GetAllNames(
83     const SemanticsContext &context, const SourceName &name) {
84   std::string str{name.ToString()};
85   if (!name.empty() && name.end()[-1] == ')' &&
86       name.ToString().rfind(std::string{operatorPrefix}, 0) == 0) {
87     for (int i{0}; i != common::LogicalOperator_enumSize; ++i) {
88       auto names{GetOperatorNames(context, LogicalOperator{i})};
89       if (llvm::is_contained(names, str)) {
90         return names;
91       }
92     }
93     for (int i{0}; i != common::RelationalOperator_enumSize; ++i) {
94       auto names{GetOperatorNames(context, RelationalOperator{i})};
95       if (llvm::is_contained(names, str)) {
96         return names;
97       }
98     }
99   }
100   return {str};
101 }
102 
103 bool IsLogicalConstant(
104     const SemanticsContext &context, const SourceName &name) {
105   std::string str{name.ToString()};
106   return str == ".true." || str == ".false." ||
107       (context.IsEnabled(LanguageFeature::LogicalAbbreviations) &&
108           (str == ".t" || str == ".f."));
109 }
110 
111 void GenericSpecInfo::Resolve(Symbol *symbol) const {
112   if (symbol) {
113     if (auto *details{symbol->detailsIf<GenericDetails>()}) {
114       details->set_kind(kind_);
115     }
116     if (parseName_) {
117       semantics::Resolve(*parseName_, symbol);
118     }
119   }
120 }
121 
122 void GenericSpecInfo::Analyze(const parser::DefinedOpName &name) {
123   kind_ = GenericKind::OtherKind::DefinedOp;
124   parseName_ = &name.v;
125   symbolName_ = name.v.source;
126 }
127 
128 void GenericSpecInfo::Analyze(const parser::GenericSpec &x) {
129   symbolName_ = x.source;
130   kind_ = common::visit(
131       common::visitors{
132           [&](const parser::Name &y) -> GenericKind {
133             parseName_ = &y;
134             symbolName_ = y.source;
135             return GenericKind::OtherKind::Name;
136           },
137           [&](const parser::DefinedOperator &y) {
138             return common::visit(
139                 common::visitors{
140                     [&](const parser::DefinedOpName &z) -> GenericKind {
141                       Analyze(z);
142                       return GenericKind::OtherKind::DefinedOp;
143                     },
144                     [&](const IntrinsicOperator &z) {
145                       return MapIntrinsicOperator(z);
146                     },
147                 },
148                 y.u);
149           },
150           [&](const parser::GenericSpec::Assignment &) -> GenericKind {
151             return GenericKind::OtherKind::Assignment;
152           },
153           [&](const parser::GenericSpec::ReadFormatted &) -> GenericKind {
154             return common::DefinedIo::ReadFormatted;
155           },
156           [&](const parser::GenericSpec::ReadUnformatted &) -> GenericKind {
157             return common::DefinedIo::ReadUnformatted;
158           },
159           [&](const parser::GenericSpec::WriteFormatted &) -> GenericKind {
160             return common::DefinedIo::WriteFormatted;
161           },
162           [&](const parser::GenericSpec::WriteUnformatted &) -> GenericKind {
163             return common::DefinedIo::WriteUnformatted;
164           },
165       },
166       x.u);
167 }
168 
169 llvm::raw_ostream &operator<<(
170     llvm::raw_ostream &os, const GenericSpecInfo &info) {
171   os << "GenericSpecInfo: kind=" << info.kind_.ToString();
172   os << " parseName="
173      << (info.parseName_ ? info.parseName_->ToString() : "null");
174   os << " symbolName="
175      << (info.symbolName_ ? info.symbolName_->ToString() : "null");
176   return os;
177 }
178 
179 // parser::DefinedOperator::IntrinsicOperator -> GenericKind
180 static GenericKind MapIntrinsicOperator(IntrinsicOperator op) {
181   switch (op) {
182     SWITCH_COVERS_ALL_CASES
183   case IntrinsicOperator::Concat:
184     return GenericKind::OtherKind::Concat;
185   case IntrinsicOperator::Power:
186     return NumericOperator::Power;
187   case IntrinsicOperator::Multiply:
188     return NumericOperator::Multiply;
189   case IntrinsicOperator::Divide:
190     return NumericOperator::Divide;
191   case IntrinsicOperator::Add:
192     return NumericOperator::Add;
193   case IntrinsicOperator::Subtract:
194     return NumericOperator::Subtract;
195   case IntrinsicOperator::AND:
196     return LogicalOperator::And;
197   case IntrinsicOperator::OR:
198     return LogicalOperator::Or;
199   case IntrinsicOperator::EQV:
200     return LogicalOperator::Eqv;
201   case IntrinsicOperator::NEQV:
202     return LogicalOperator::Neqv;
203   case IntrinsicOperator::NOT:
204     return LogicalOperator::Not;
205   case IntrinsicOperator::LT:
206     return RelationalOperator::LT;
207   case IntrinsicOperator::LE:
208     return RelationalOperator::LE;
209   case IntrinsicOperator::EQ:
210     return RelationalOperator::EQ;
211   case IntrinsicOperator::NE:
212     return RelationalOperator::NE;
213   case IntrinsicOperator::GE:
214     return RelationalOperator::GE;
215   case IntrinsicOperator::GT:
216     return RelationalOperator::GT;
217   }
218 }
219 
220 class ArraySpecAnalyzer {
221 public:
222   ArraySpecAnalyzer(SemanticsContext &context) : context_{context} {}
223   ArraySpec Analyze(const parser::ArraySpec &);
224   ArraySpec AnalyzeDeferredShapeSpecList(const parser::DeferredShapeSpecList &);
225   ArraySpec Analyze(const parser::ComponentArraySpec &);
226   ArraySpec Analyze(const parser::CoarraySpec &);
227 
228 private:
229   SemanticsContext &context_;
230   ArraySpec arraySpec_;
231 
232   template <typename T> void Analyze(const std::list<T> &list) {
233     for (const auto &elem : list) {
234       Analyze(elem);
235     }
236   }
237   void Analyze(const parser::AssumedShapeSpec &);
238   void Analyze(const parser::ExplicitShapeSpec &);
239   void Analyze(const parser::AssumedImpliedSpec &);
240   void Analyze(const parser::DeferredShapeSpecList &);
241   void Analyze(const parser::AssumedRankSpec &);
242   void MakeExplicit(const std::optional<parser::SpecificationExpr> &,
243       const parser::SpecificationExpr &);
244   void MakeImplied(const std::optional<parser::SpecificationExpr> &);
245   void MakeDeferred(int);
246   Bound GetBound(const std::optional<parser::SpecificationExpr> &);
247   Bound GetBound(const parser::SpecificationExpr &);
248 };
249 
250 ArraySpec AnalyzeArraySpec(
251     SemanticsContext &context, const parser::ArraySpec &arraySpec) {
252   return ArraySpecAnalyzer{context}.Analyze(arraySpec);
253 }
254 ArraySpec AnalyzeArraySpec(
255     SemanticsContext &context, const parser::ComponentArraySpec &arraySpec) {
256   return ArraySpecAnalyzer{context}.Analyze(arraySpec);
257 }
258 ArraySpec AnalyzeDeferredShapeSpecList(SemanticsContext &context,
259     const parser::DeferredShapeSpecList &deferredShapeSpecs) {
260   return ArraySpecAnalyzer{context}.AnalyzeDeferredShapeSpecList(
261       deferredShapeSpecs);
262 }
263 ArraySpec AnalyzeCoarraySpec(
264     SemanticsContext &context, const parser::CoarraySpec &coarraySpec) {
265   return ArraySpecAnalyzer{context}.Analyze(coarraySpec);
266 }
267 
268 ArraySpec ArraySpecAnalyzer::Analyze(const parser::ComponentArraySpec &x) {
269   common::visit([this](const auto &y) { Analyze(y); }, x.u);
270   CHECK(!arraySpec_.empty());
271   return arraySpec_;
272 }
273 ArraySpec ArraySpecAnalyzer::Analyze(const parser::ArraySpec &x) {
274   common::visit(common::visitors{
275                     [&](const parser::AssumedSizeSpec &y) {
276                       Analyze(
277                           std::get<std::list<parser::ExplicitShapeSpec>>(y.t));
278                       Analyze(std::get<parser::AssumedImpliedSpec>(y.t));
279                     },
280                     [&](const parser::ImpliedShapeSpec &y) { Analyze(y.v); },
281                     [&](const auto &y) { Analyze(y); },
282                 },
283       x.u);
284   CHECK(!arraySpec_.empty());
285   return arraySpec_;
286 }
287 ArraySpec ArraySpecAnalyzer::AnalyzeDeferredShapeSpecList(
288     const parser::DeferredShapeSpecList &x) {
289   Analyze(x);
290   CHECK(!arraySpec_.empty());
291   return arraySpec_;
292 }
293 ArraySpec ArraySpecAnalyzer::Analyze(const parser::CoarraySpec &x) {
294   common::visit(
295       common::visitors{
296           [&](const parser::DeferredCoshapeSpecList &y) { MakeDeferred(y.v); },
297           [&](const parser::ExplicitCoshapeSpec &y) {
298             Analyze(std::get<std::list<parser::ExplicitShapeSpec>>(y.t));
299             MakeImplied(
300                 std::get<std::optional<parser::SpecificationExpr>>(y.t));
301           },
302       },
303       x.u);
304   CHECK(!arraySpec_.empty());
305   return arraySpec_;
306 }
307 
308 void ArraySpecAnalyzer::Analyze(const parser::AssumedShapeSpec &x) {
309   arraySpec_.push_back(ShapeSpec::MakeAssumedShape(GetBound(x.v)));
310 }
311 void ArraySpecAnalyzer::Analyze(const parser::ExplicitShapeSpec &x) {
312   MakeExplicit(std::get<std::optional<parser::SpecificationExpr>>(x.t),
313       std::get<parser::SpecificationExpr>(x.t));
314 }
315 void ArraySpecAnalyzer::Analyze(const parser::AssumedImpliedSpec &x) {
316   MakeImplied(x.v);
317 }
318 void ArraySpecAnalyzer::Analyze(const parser::DeferredShapeSpecList &x) {
319   MakeDeferred(x.v);
320 }
321 void ArraySpecAnalyzer::Analyze(const parser::AssumedRankSpec &) {
322   arraySpec_.push_back(ShapeSpec::MakeAssumedRank());
323 }
324 
325 void ArraySpecAnalyzer::MakeExplicit(
326     const std::optional<parser::SpecificationExpr> &lb,
327     const parser::SpecificationExpr &ub) {
328   arraySpec_.push_back(ShapeSpec::MakeExplicit(GetBound(lb), GetBound(ub)));
329 }
330 void ArraySpecAnalyzer::MakeImplied(
331     const std::optional<parser::SpecificationExpr> &lb) {
332   arraySpec_.push_back(ShapeSpec::MakeImplied(GetBound(lb)));
333 }
334 void ArraySpecAnalyzer::MakeDeferred(int n) {
335   for (int i = 0; i < n; ++i) {
336     arraySpec_.push_back(ShapeSpec::MakeDeferred());
337   }
338 }
339 
340 Bound ArraySpecAnalyzer::GetBound(
341     const std::optional<parser::SpecificationExpr> &x) {
342   return x ? GetBound(*x) : Bound{1};
343 }
344 Bound ArraySpecAnalyzer::GetBound(const parser::SpecificationExpr &x) {
345   MaybeSubscriptIntExpr expr;
346   if (MaybeExpr maybeExpr{AnalyzeExpr(context_, x.v)}) {
347     if (auto *intExpr{evaluate::UnwrapExpr<SomeIntExpr>(*maybeExpr)}) {
348       expr = evaluate::Fold(context_.foldingContext(),
349           evaluate::ConvertToType<evaluate::SubscriptInteger>(
350               std::move(*intExpr)));
351     }
352   }
353   return Bound{std::move(expr)};
354 }
355 
356 // If src is SAVE (explicitly or implicitly),
357 // set SAVE attribute on all members of dst.
358 static void PropagateSaveAttr(
359     const EquivalenceObject &src, EquivalenceSet &dst) {
360   if (IsSaved(src.symbol)) {
361     for (auto &obj : dst) {
362       if (!obj.symbol.attrs().test(Attr::SAVE)) {
363         obj.symbol.attrs().set(Attr::SAVE);
364         // If the other equivalenced symbol itself is not SAVE,
365         // then adding SAVE here implies that it has to be implicit.
366         obj.symbol.implicitAttrs().set(Attr::SAVE);
367       }
368     }
369   }
370 }
371 static void PropagateSaveAttr(const EquivalenceSet &src, EquivalenceSet &dst) {
372   if (!src.empty()) {
373     PropagateSaveAttr(src.front(), dst);
374   }
375 }
376 
377 void EquivalenceSets::AddToSet(const parser::Designator &designator) {
378   if (CheckDesignator(designator)) {
379     Symbol &symbol{*currObject_.symbol};
380     if (!currSet_.empty()) {
381       // check this symbol against first of set for compatibility
382       Symbol &first{currSet_.front().symbol};
383       CheckCanEquivalence(designator.source, first, symbol) &&
384           CheckCanEquivalence(designator.source, symbol, first);
385     }
386     auto subscripts{currObject_.subscripts};
387     if (subscripts.empty() && symbol.IsObjectArray()) {
388       // record a whole array as its first element
389       for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) {
390         auto &lbound{spec.lbound().GetExplicit().value()};
391         subscripts.push_back(evaluate::ToInt64(lbound).value());
392       }
393     }
394     auto substringStart{currObject_.substringStart};
395     currSet_.emplace_back(
396         symbol, subscripts, substringStart, designator.source);
397     PropagateSaveAttr(currSet_.back(), currSet_);
398   }
399   currObject_ = {};
400 }
401 
402 void EquivalenceSets::FinishSet(const parser::CharBlock &source) {
403   std::set<std::size_t> existing; // indices of sets intersecting this one
404   for (auto &obj : currSet_) {
405     auto it{objectToSet_.find(obj)};
406     if (it != objectToSet_.end()) {
407       existing.insert(it->second); // symbol already in this set
408     }
409   }
410   if (existing.empty()) {
411     sets_.push_back({}); // create a new equivalence set
412     MergeInto(source, currSet_, sets_.size() - 1);
413   } else {
414     auto it{existing.begin()};
415     std::size_t dstIndex{*it};
416     MergeInto(source, currSet_, dstIndex);
417     while (++it != existing.end()) {
418       MergeInto(source, sets_[*it], dstIndex);
419     }
420   }
421   currSet_.clear();
422 }
423 
424 // Report an error or warning if sym1 and sym2 cannot be in the same equivalence
425 // set.
426 bool EquivalenceSets::CheckCanEquivalence(
427     const parser::CharBlock &source, const Symbol &sym1, const Symbol &sym2) {
428   std::optional<parser::MessageFixedText> msg;
429   const DeclTypeSpec *type1{sym1.GetType()};
430   const DeclTypeSpec *type2{sym2.GetType()};
431   bool isDefaultNum1{IsDefaultNumericSequenceType(type1)};
432   bool isAnyNum1{IsAnyNumericSequenceType(type1)};
433   bool isDefaultNum2{IsDefaultNumericSequenceType(type2)};
434   bool isAnyNum2{IsAnyNumericSequenceType(type2)};
435   bool isChar1{IsCharacterSequenceType(type1)};
436   bool isChar2{IsCharacterSequenceType(type2)};
437   if (sym1.attrs().test(Attr::PROTECTED) &&
438       !sym2.attrs().test(Attr::PROTECTED)) { // C8114
439     msg = "Equivalence set cannot contain '%s'"
440           " with PROTECTED attribute and '%s' without"_err_en_US;
441   } else if ((isDefaultNum1 && isDefaultNum2) || (isChar1 && isChar2)) {
442     // ok & standard conforming
443   } else if (!(isAnyNum1 || isChar1) &&
444       !(isAnyNum2 || isChar2)) { // C8110 - C8113
445     if (AreTkCompatibleTypes(type1, type2)) {
446       if (context_.ShouldWarn(LanguageFeature::EquivalenceSameNonSequence)) {
447         msg =
448             "nonstandard: Equivalence set contains '%s' and '%s' with same "
449             "type that is neither numeric nor character sequence type"_port_en_US;
450       }
451     } else {
452       msg = "Equivalence set cannot contain '%s' and '%s' with distinct types "
453             "that are not both numeric or character sequence types"_err_en_US;
454     }
455   } else if (isAnyNum1) {
456     if (isChar2) {
457       if (context_.ShouldWarn(
458               LanguageFeature::EquivalenceNumericWithCharacter)) {
459         msg = "nonstandard: Equivalence set contains '%s' that is numeric "
460               "sequence type and '%s' that is character"_port_en_US;
461       }
462     } else if (isAnyNum2 &&
463         context_.ShouldWarn(LanguageFeature::EquivalenceNonDefaultNumeric)) {
464       if (isDefaultNum1) {
465         msg =
466             "nonstandard: Equivalence set contains '%s' that is a default "
467             "numeric sequence type and '%s' that is numeric with non-default kind"_port_en_US;
468       } else if (!isDefaultNum2) {
469         msg = "nonstandard: Equivalence set contains '%s' and '%s' that are "
470               "numeric sequence types with non-default kinds"_port_en_US;
471       }
472     }
473   }
474   if (msg &&
475       (!context_.IsInModuleFile(source) ||
476           msg->severity() == parser::Severity::Error)) {
477     context_.Say(source, std::move(*msg), sym1.name(), sym2.name());
478     return false;
479   }
480   return true;
481 }
482 
483 // Move objects from src to sets_[dstIndex]
484 void EquivalenceSets::MergeInto(const parser::CharBlock &source,
485     EquivalenceSet &src, std::size_t dstIndex) {
486   EquivalenceSet &dst{sets_[dstIndex]};
487   PropagateSaveAttr(dst, src);
488   for (const auto &obj : src) {
489     dst.push_back(obj);
490     objectToSet_[obj] = dstIndex;
491   }
492   PropagateSaveAttr(src, dst);
493   src.clear();
494 }
495 
496 // If set has an object with this symbol, return it.
497 const EquivalenceObject *EquivalenceSets::Find(
498     const EquivalenceSet &set, const Symbol &symbol) {
499   for (const auto &obj : set) {
500     if (obj.symbol == symbol) {
501       return &obj;
502     }
503   }
504   return nullptr;
505 }
506 
507 bool EquivalenceSets::CheckDesignator(const parser::Designator &designator) {
508   return common::visit(
509       common::visitors{
510           [&](const parser::DataRef &x) {
511             return CheckDataRef(designator.source, x);
512           },
513           [&](const parser::Substring &x) {
514             const auto &dataRef{std::get<parser::DataRef>(x.t)};
515             const auto &range{std::get<parser::SubstringRange>(x.t)};
516             bool ok{CheckDataRef(designator.source, dataRef)};
517             if (const auto &lb{std::get<0>(range.t)}) {
518               ok &= CheckSubstringBound(lb->thing.thing.value(), true);
519             } else {
520               currObject_.substringStart = 1;
521             }
522             if (const auto &ub{std::get<1>(range.t)}) {
523               ok &= CheckSubstringBound(ub->thing.thing.value(), false);
524             }
525             return ok;
526           },
527       },
528       designator.u);
529 }
530 
531 bool EquivalenceSets::CheckDataRef(
532     const parser::CharBlock &source, const parser::DataRef &x) {
533   return common::visit(
534       common::visitors{
535           [&](const parser::Name &name) { return CheckObject(name); },
536           [&](const common::Indirection<parser::StructureComponent> &) {
537             context_.Say(source, // C8107
538                 "Derived type component '%s' is not allowed in an equivalence set"_err_en_US,
539                 source);
540             return false;
541           },
542           [&](const common::Indirection<parser::ArrayElement> &elem) {
543             bool ok{CheckDataRef(source, elem.value().base)};
544             for (const auto &subscript : elem.value().subscripts) {
545               ok &= common::visit(
546                   common::visitors{
547                       [&](const parser::SubscriptTriplet &) {
548                         context_.Say(source, // C924, R872
549                             "Array section '%s' is not allowed in an equivalence set"_err_en_US,
550                             source);
551                         return false;
552                       },
553                       [&](const parser::IntExpr &y) {
554                         return CheckArrayBound(y.thing.value());
555                       },
556                   },
557                   subscript.u);
558             }
559             return ok;
560           },
561           [&](const common::Indirection<parser::CoindexedNamedObject> &) {
562             context_.Say(source, // C924 (R872)
563                 "Coindexed object '%s' is not allowed in an equivalence set"_err_en_US,
564                 source);
565             return false;
566           },
567       },
568       x.u);
569 }
570 
571 static bool InCommonWithBind(const Symbol &symbol) {
572   if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
573     const Symbol *commonBlock{details->commonBlock()};
574     return commonBlock && commonBlock->attrs().test(Attr::BIND_C);
575   } else {
576     return false;
577   }
578 }
579 
580 // If symbol can't be in equivalence set report error and return false;
581 bool EquivalenceSets::CheckObject(const parser::Name &name) {
582   if (!name.symbol) {
583     return false; // an error has already occurred
584   }
585   currObject_.symbol = name.symbol;
586   parser::MessageFixedText msg;
587   const Symbol &symbol{*name.symbol};
588   if (symbol.owner().IsDerivedType()) { // C8107
589     msg = "Derived type component '%s'"
590           " is not allowed in an equivalence set"_err_en_US;
591   } else if (IsDummy(symbol)) { // C8106
592     msg = "Dummy argument '%s' is not allowed in an equivalence set"_err_en_US;
593   } else if (symbol.IsFuncResult()) { // C8106
594     msg = "Function result '%s' is not allow in an equivalence set"_err_en_US;
595   } else if (IsPointer(symbol)) { // C8106
596     msg = "Pointer '%s' is not allowed in an equivalence set"_err_en_US;
597   } else if (IsAllocatable(symbol)) { // C8106
598     msg = "Allocatable variable '%s'"
599           " is not allowed in an equivalence set"_err_en_US;
600   } else if (symbol.Corank() > 0) { // C8106
601     msg = "Coarray '%s' is not allowed in an equivalence set"_err_en_US;
602   } else if (symbol.has<UseDetails>()) { // C8115
603     msg = "Use-associated variable '%s'"
604           " is not allowed in an equivalence set"_err_en_US;
605   } else if (symbol.attrs().test(Attr::BIND_C)) { // C8106
606     msg = "Variable '%s' with BIND attribute"
607           " is not allowed in an equivalence set"_err_en_US;
608   } else if (symbol.attrs().test(Attr::TARGET)) { // C8108
609     msg = "Variable '%s' with TARGET attribute"
610           " is not allowed in an equivalence set"_err_en_US;
611   } else if (IsNamedConstant(symbol)) { // C8106
612     msg = "Named constant '%s' is not allowed in an equivalence set"_err_en_US;
613   } else if (InCommonWithBind(symbol)) { // C8106
614     msg = "Variable '%s' in common block with BIND attribute"
615           " is not allowed in an equivalence set"_err_en_US;
616   } else if (const auto *type{symbol.GetType()}) {
617     const auto *derived{type->AsDerived()};
618     if (derived && !derived->IsVectorType()) {
619       if (const auto *comp{FindUltimateComponent(
620               *derived, IsAllocatableOrPointer)}) { // C8106
621         msg = IsPointer(*comp)
622             ? "Derived type object '%s' with pointer ultimate component"
623               " is not allowed in an equivalence set"_err_en_US
624             : "Derived type object '%s' with allocatable ultimate component"
625               " is not allowed in an equivalence set"_err_en_US;
626       } else if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {
627         msg = "Nonsequence derived type object '%s'"
628               " is not allowed in an equivalence set"_err_en_US;
629       }
630     } else if (IsAutomatic(symbol)) {
631       msg = "Automatic object '%s'"
632             " is not allowed in an equivalence set"_err_en_US;
633     }
634   }
635   if (!msg.text().empty()) {
636     context_.Say(name.source, std::move(msg), name.source);
637     return false;
638   }
639   return true;
640 }
641 
642 bool EquivalenceSets::CheckArrayBound(const parser::Expr &bound) {
643   MaybeExpr expr{
644       evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};
645   if (!expr) {
646     return false;
647   }
648   if (expr->Rank() > 0) {
649     context_.Say(bound.source, // C924, R872
650         "Array with vector subscript '%s' is not allowed in an equivalence set"_err_en_US,
651         bound.source);
652     return false;
653   }
654   auto subscript{evaluate::ToInt64(*expr)};
655   if (!subscript) {
656     context_.Say(bound.source, // C8109
657         "Array with nonconstant subscript '%s' is not allowed in an equivalence set"_err_en_US,
658         bound.source);
659     return false;
660   }
661   currObject_.subscripts.push_back(*subscript);
662   return true;
663 }
664 
665 bool EquivalenceSets::CheckSubstringBound(
666     const parser::Expr &bound, bool isStart) {
667   MaybeExpr expr{
668       evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};
669   if (!expr) {
670     return false;
671   }
672   auto subscript{evaluate::ToInt64(*expr)};
673   if (!subscript) {
674     context_.Say(bound.source, // C8109
675         "Substring with nonconstant bound '%s' is not allowed in an equivalence set"_err_en_US,
676         bound.source);
677     return false;
678   }
679   if (!isStart) {
680     auto start{currObject_.substringStart};
681     if (*subscript < (start ? *start : 1)) {
682       context_.Say(bound.source, // C8116
683           "Substring with zero length is not allowed in an equivalence set"_err_en_US);
684       return false;
685     }
686   } else if (*subscript != 1) {
687     currObject_.substringStart = *subscript;
688   }
689   return true;
690 }
691 
692 bool EquivalenceSets::IsCharacterSequenceType(const DeclTypeSpec *type) {
693   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
694     auto kind{evaluate::ToInt64(type.kind())};
695     return type.category() == TypeCategory::Character && kind &&
696         kind.value() == context_.GetDefaultKind(TypeCategory::Character);
697   });
698 }
699 
700 // Numeric or logical type of default kind or DOUBLE PRECISION or DOUBLE COMPLEX
701 bool EquivalenceSets::IsDefaultKindNumericType(const IntrinsicTypeSpec &type) {
702   if (auto kind{evaluate::ToInt64(type.kind())}) {
703     switch (type.category()) {
704     case TypeCategory::Integer:
705     case TypeCategory::Logical:
706       return *kind == context_.GetDefaultKind(TypeCategory::Integer);
707     case TypeCategory::Real:
708     case TypeCategory::Complex:
709       return *kind == context_.GetDefaultKind(TypeCategory::Real) ||
710           *kind == context_.doublePrecisionKind();
711     default:
712       return false;
713     }
714   }
715   return false;
716 }
717 
718 bool EquivalenceSets::IsDefaultNumericSequenceType(const DeclTypeSpec *type) {
719   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
720     return IsDefaultKindNumericType(type);
721   });
722 }
723 
724 bool EquivalenceSets::IsAnyNumericSequenceType(const DeclTypeSpec *type) {
725   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
726     return type.category() == TypeCategory::Logical ||
727         common::IsNumericTypeCategory(type.category());
728   });
729 }
730 
731 // Is type an intrinsic type that satisfies predicate or a sequence type
732 // whose components do.
733 bool EquivalenceSets::IsSequenceType(const DeclTypeSpec *type,
734     std::function<bool(const IntrinsicTypeSpec &)> predicate) {
735   if (!type) {
736     return false;
737   } else if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) {
738     return predicate(*intrinsic);
739   } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
740     for (const auto &pair : *derived->typeSymbol().scope()) {
741       const Symbol &component{*pair.second};
742       if (IsAllocatableOrPointer(component) ||
743           !IsSequenceType(component.GetType(), predicate)) {
744         return false;
745       }
746     }
747     return true;
748   } else {
749     return false;
750   }
751 }
752 
753 // MapSubprogramToNewSymbols() relies on the following recursive symbol/scope
754 // copying infrastructure to duplicate an interface's symbols and map all
755 // of the symbol references in their contained expressions and interfaces
756 // to the new symbols.
757 
758 struct SymbolAndTypeMappings {
759   std::map<const Symbol *, const Symbol *> symbolMap;
760   std::map<const DeclTypeSpec *, const DeclTypeSpec *> typeMap;
761 };
762 
763 class SymbolMapper : public evaluate::AnyTraverse<SymbolMapper, bool> {
764 public:
765   using Base = evaluate::AnyTraverse<SymbolMapper, bool>;
766   SymbolMapper(Scope &scope, SymbolAndTypeMappings &map)
767       : Base{*this}, scope_{scope}, map_{map} {}
768   using Base::operator();
769   bool operator()(const SymbolRef &ref) const {
770     if (const Symbol *mapped{MapSymbol(*ref)}) {
771       const_cast<SymbolRef &>(ref) = *mapped;
772     }
773     return false;
774   }
775   bool operator()(const Symbol &x) const {
776     if (MapSymbol(x)) {
777       DIE("SymbolMapper hit symbol outside SymbolRef");
778     }
779     return false;
780   }
781   void MapSymbolExprs(Symbol &);
782   Symbol *CopySymbol(const Symbol *);
783 
784 private:
785   void MapParamValue(ParamValue &param) const { (*this)(param.GetExplicit()); }
786   void MapBound(Bound &bound) const { (*this)(bound.GetExplicit()); }
787   void MapShapeSpec(ShapeSpec &spec) const {
788     MapBound(spec.lbound());
789     MapBound(spec.ubound());
790   }
791   const Symbol *MapSymbol(const Symbol &) const;
792   const Symbol *MapSymbol(const Symbol *) const;
793   const DeclTypeSpec *MapType(const DeclTypeSpec &);
794   const DeclTypeSpec *MapType(const DeclTypeSpec *);
795   const Symbol *MapInterface(const Symbol *);
796 
797   Scope &scope_;
798   SymbolAndTypeMappings &map_;
799 };
800 
801 Symbol *SymbolMapper::CopySymbol(const Symbol *symbol) {
802   if (symbol) {
803     if (auto *subp{symbol->detailsIf<SubprogramDetails>()}) {
804       if (subp->isInterface()) {
805         if (auto pair{scope_.try_emplace(symbol->name(), symbol->attrs())};
806             pair.second) {
807           Symbol &copy{*pair.first->second};
808           map_.symbolMap[symbol] = &copy;
809           copy.set(symbol->test(Symbol::Flag::Subroutine)
810                   ? Symbol::Flag::Subroutine
811                   : Symbol::Flag::Function);
812           Scope &newScope{scope_.MakeScope(Scope::Kind::Subprogram, &copy)};
813           copy.set_scope(&newScope);
814           copy.set_details(SubprogramDetails{});
815           auto &newSubp{copy.get<SubprogramDetails>()};
816           newSubp.set_isInterface(true);
817           newSubp.set_isDummy(subp->isDummy());
818           newSubp.set_defaultIgnoreTKR(subp->defaultIgnoreTKR());
819           MapSubprogramToNewSymbols(*symbol, copy, newScope, &map_);
820           return &copy;
821         }
822       }
823     } else if (Symbol * copy{scope_.CopySymbol(*symbol)}) {
824       map_.symbolMap[symbol] = copy;
825       return copy;
826     }
827   }
828   return nullptr;
829 }
830 
831 void SymbolMapper::MapSymbolExprs(Symbol &symbol) {
832   common::visit(
833       common::visitors{[&](ObjectEntityDetails &object) {
834                          if (const DeclTypeSpec * type{object.type()}) {
835                            if (const DeclTypeSpec * newType{MapType(*type)}) {
836                              object.ReplaceType(*newType);
837                            }
838                          }
839                          for (ShapeSpec &spec : object.shape()) {
840                            MapShapeSpec(spec);
841                          }
842                          for (ShapeSpec &spec : object.coshape()) {
843                            MapShapeSpec(spec);
844                          }
845                        },
846           [&](ProcEntityDetails &proc) {
847             if (const Symbol *
848                 mappedSymbol{MapInterface(proc.procInterface())}) {
849               proc.set_procInterface(*mappedSymbol);
850             } else if (const DeclTypeSpec * mappedType{MapType(proc.type())}) {
851               proc.set_type(*mappedType);
852             }
853             if (proc.init()) {
854               if (const Symbol * mapped{MapSymbol(*proc.init())}) {
855                 proc.set_init(*mapped);
856               }
857             }
858           },
859           [&](const HostAssocDetails &hostAssoc) {
860             if (const Symbol * mapped{MapSymbol(hostAssoc.symbol())}) {
861               symbol.set_details(HostAssocDetails{*mapped});
862             }
863           },
864           [](const auto &) {}},
865       symbol.details());
866 }
867 
868 const Symbol *SymbolMapper::MapSymbol(const Symbol &symbol) const {
869   if (auto iter{map_.symbolMap.find(&symbol)}; iter != map_.symbolMap.end()) {
870     return iter->second;
871   }
872   return nullptr;
873 }
874 
875 const Symbol *SymbolMapper::MapSymbol(const Symbol *symbol) const {
876   return symbol ? MapSymbol(*symbol) : nullptr;
877 }
878 
879 const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec &type) {
880   if (auto iter{map_.typeMap.find(&type)}; iter != map_.typeMap.end()) {
881     return iter->second;
882   }
883   const DeclTypeSpec *newType{nullptr};
884   if (type.category() == DeclTypeSpec::Category::Character) {
885     const CharacterTypeSpec &charType{type.characterTypeSpec()};
886     if (charType.length().GetExplicit()) {
887       ParamValue newLen{charType.length()};
888       (*this)(newLen.GetExplicit());
889       newType = &scope_.MakeCharacterType(
890           std::move(newLen), KindExpr{charType.kind()});
891     }
892   } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {
893     if (!derived->parameters().empty()) {
894       DerivedTypeSpec newDerived{derived->name(), derived->typeSymbol()};
895       newDerived.CookParameters(scope_.context().foldingContext());
896       for (const auto &[paramName, paramValue] : derived->parameters()) {
897         ParamValue newParamValue{paramValue};
898         MapParamValue(newParamValue);
899         newDerived.AddParamValue(paramName, std::move(newParamValue));
900       }
901       // Scope::InstantiateDerivedTypes() instantiates it later.
902       newType = &scope_.MakeDerivedType(type.category(), std::move(newDerived));
903     }
904   }
905   if (newType) {
906     map_.typeMap[&type] = newType;
907   }
908   return newType;
909 }
910 
911 const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec *type) {
912   return type ? MapType(*type) : nullptr;
913 }
914 
915 const Symbol *SymbolMapper::MapInterface(const Symbol *interface) {
916   if (const Symbol *mapped{MapSymbol(interface)}) {
917     return mapped;
918   }
919   if (interface) {
920     if (&interface->owner() != &scope_) {
921       return interface;
922     } else if (const auto *subp{interface->detailsIf<SubprogramDetails>()};
923                subp && subp->isInterface()) {
924       return CopySymbol(interface);
925     }
926   }
927   return nullptr;
928 }
929 
930 void MapSubprogramToNewSymbols(const Symbol &oldSymbol, Symbol &newSymbol,
931     Scope &newScope, SymbolAndTypeMappings *mappings) {
932   SymbolAndTypeMappings newMappings;
933   if (!mappings) {
934     mappings = &newMappings;
935   }
936   mappings->symbolMap[&oldSymbol] = &newSymbol;
937   const auto &oldDetails{oldSymbol.get<SubprogramDetails>()};
938   auto &newDetails{newSymbol.get<SubprogramDetails>()};
939   SymbolMapper mapper{newScope, *mappings};
940   for (const Symbol *dummyArg : oldDetails.dummyArgs()) {
941     if (!dummyArg) {
942       newDetails.add_alternateReturn();
943     } else if (Symbol * copy{mapper.CopySymbol(dummyArg)}) {
944       copy->set(Symbol::Flag::Implicit, false);
945       newDetails.add_dummyArg(*copy);
946       mappings->symbolMap[dummyArg] = copy;
947     }
948   }
949   if (oldDetails.isFunction()) {
950     newScope.erase(newSymbol.name());
951     const Symbol &result{oldDetails.result()};
952     if (Symbol * copy{mapper.CopySymbol(&result)}) {
953       newDetails.set_result(*copy);
954       mappings->symbolMap[&result] = copy;
955     }
956   }
957   for (auto &[_, ref] : newScope) {
958     mapper.MapSymbolExprs(*ref);
959   }
960   newScope.InstantiateDerivedTypes();
961 }
962 
963 } // namespace Fortran::semantics
964