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
26namespace Fortran::semantics {
27
28using common::LanguageFeature;
29using common::LogicalOperator;
30using common::NumericOperator;
31using common::RelationalOperator;
32using IntrinsicOperator = parser::DefinedOperator::IntrinsicOperator;
33
34static constexpr const char *operatorPrefix{"operator("};
35
36static GenericKind MapIntrinsicOperator(IntrinsicOperator);
37
38Symbol *Resolve(const parser::Name &name, Symbol *symbol) {
39 if (symbol && !name.symbol) {
40 name.symbol = symbol;
41 }
42 return symbol;
43}
44Symbol &Resolve(const parser::Name &name, Symbol &symbol) {
45 return *Resolve(name, &symbol);
46}
47
48parser::MessageFixedText WithSeverity(
49 const parser::MessageFixedText &msg, parser::Severity severity) {
50 return parser::MessageFixedText{
51 msg.text().begin(), msg.text().size(), severity};
52}
53
54bool 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
72template <typename E>
73std::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
82std::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
103bool 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
111void 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
122void GenericSpecInfo::Analyze(const parser::DefinedOpName &name) {
123 kind_ = GenericKind::OtherKind::DefinedOp;
124 parseName_ = &name.v;
125 symbolName_ = name.v.source;
126}
127
128void 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
169llvm::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
180static 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
220class ArraySpecAnalyzer {
221public:
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
228private:
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
250ArraySpec AnalyzeArraySpec(
251 SemanticsContext &context, const parser::ArraySpec &arraySpec) {
252 return ArraySpecAnalyzer{context}.Analyze(arraySpec);
253}
254ArraySpec AnalyzeArraySpec(
255 SemanticsContext &context, const parser::ComponentArraySpec &arraySpec) {
256 return ArraySpecAnalyzer{context}.Analyze(arraySpec);
257}
258ArraySpec AnalyzeDeferredShapeSpecList(SemanticsContext &context,
259 const parser::DeferredShapeSpecList &deferredShapeSpecs) {
260 return ArraySpecAnalyzer{context}.AnalyzeDeferredShapeSpecList(
261 deferredShapeSpecs);
262}
263ArraySpec AnalyzeCoarraySpec(
264 SemanticsContext &context, const parser::CoarraySpec &coarraySpec) {
265 return ArraySpecAnalyzer{context}.Analyze(coarraySpec);
266}
267
268ArraySpec 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}
273ArraySpec 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}
287ArraySpec ArraySpecAnalyzer::AnalyzeDeferredShapeSpecList(
288 const parser::DeferredShapeSpecList &x) {
289 Analyze(x);
290 CHECK(!arraySpec_.empty());
291 return arraySpec_;
292}
293ArraySpec 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
308void ArraySpecAnalyzer::Analyze(const parser::AssumedShapeSpec &x) {
309 arraySpec_.push_back(ShapeSpec::MakeAssumedShape(GetBound(x.v)));
310}
311void ArraySpecAnalyzer::Analyze(const parser::ExplicitShapeSpec &x) {
312 MakeExplicit(std::get<std::optional<parser::SpecificationExpr>>(x.t),
313 std::get<parser::SpecificationExpr>(x.t));
314}
315void ArraySpecAnalyzer::Analyze(const parser::AssumedImpliedSpec &x) {
316 MakeImplied(x.v);
317}
318void ArraySpecAnalyzer::Analyze(const parser::DeferredShapeSpecList &x) {
319 MakeDeferred(x.v);
320}
321void ArraySpecAnalyzer::Analyze(const parser::AssumedRankSpec &) {
322 arraySpec_.push_back(ShapeSpec::MakeAssumedRank());
323}
324
325void 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}
330void ArraySpecAnalyzer::MakeImplied(
331 const std::optional<parser::SpecificationExpr> &lb) {
332 arraySpec_.push_back(ShapeSpec::MakeImplied(GetBound(lb)));
333}
334void ArraySpecAnalyzer::MakeDeferred(int n) {
335 for (int i = 0; i < n; ++i) {
336 arraySpec_.push_back(ShapeSpec::MakeDeferred());
337 }
338}
339
340Bound ArraySpecAnalyzer::GetBound(
341 const std::optional<parser::SpecificationExpr> &x) {
342 return x ? GetBound(*x) : Bound{1};
343}
344Bound 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.
358static 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}
371static void PropagateSaveAttr(const EquivalenceSet &src, EquivalenceSet &dst) {
372 if (!src.empty()) {
373 PropagateSaveAttr(src.front(), dst);
374 }
375}
376
377void 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
402void 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.
426bool 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]
484void 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.
497const 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
507bool 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
531bool 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
571static 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;
581bool 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
642bool 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
665bool 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
692bool 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
701bool 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
718bool EquivalenceSets::IsDefaultNumericSequenceType(const DeclTypeSpec *type) {
719 return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
720 return IsDefaultKindNumericType(type);
721 });
722}
723
724bool 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.
733bool 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
758struct SymbolAndTypeMappings {
759 std::map<const Symbol *, const Symbol *> symbolMap;
760 std::map<const DeclTypeSpec *, const DeclTypeSpec *> typeMap;
761};
762
763class SymbolMapper : public evaluate::AnyTraverse<SymbolMapper, bool> {
764public:
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
784private:
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
801Symbol *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
831void 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.rawProcInterface())}) {
849 proc.set_procInterfaces(
850 *mappedSymbol, BypassGeneric(mappedSymbol->GetUltimate()));
851 } else if (const DeclTypeSpec * mappedType{MapType(proc.type())}) {
852 proc.set_type(*mappedType);
853 }
854 if (proc.init()) {
855 if (const Symbol * mapped{MapSymbol(*proc.init())}) {
856 proc.set_init(*mapped);
857 }
858 }
859 },
860 [&](const HostAssocDetails &hostAssoc) {
861 if (const Symbol * mapped{MapSymbol(hostAssoc.symbol())}) {
862 symbol.set_details(HostAssocDetails{*mapped});
863 }
864 },
865 [](const auto &) {}},
866 symbol.details());
867}
868
869const Symbol *SymbolMapper::MapSymbol(const Symbol &symbol) const {
870 if (auto iter{map_.symbolMap.find(&symbol)}; iter != map_.symbolMap.end()) {
871 return iter->second;
872 }
873 return nullptr;
874}
875
876const Symbol *SymbolMapper::MapSymbol(const Symbol *symbol) const {
877 return symbol ? MapSymbol(*symbol) : nullptr;
878}
879
880const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec &type) {
881 if (auto iter{map_.typeMap.find(&type)}; iter != map_.typeMap.end()) {
882 return iter->second;
883 }
884 const DeclTypeSpec *newType{nullptr};
885 if (type.category() == DeclTypeSpec::Category::Character) {
886 const CharacterTypeSpec &charType{type.characterTypeSpec()};
887 if (charType.length().GetExplicit()) {
888 ParamValue newLen{charType.length()};
889 (*this)(newLen.GetExplicit());
890 newType = &scope_.MakeCharacterType(
891 std::move(newLen), KindExpr{charType.kind()});
892 }
893 } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {
894 if (!derived->parameters().empty()) {
895 DerivedTypeSpec newDerived{derived->name(), derived->typeSymbol()};
896 newDerived.CookParameters(scope_.context().foldingContext());
897 for (const auto &[paramName, paramValue] : derived->parameters()) {
898 ParamValue newParamValue{paramValue};
899 MapParamValue(newParamValue);
900 newDerived.AddParamValue(paramName, std::move(newParamValue));
901 }
902 // Scope::InstantiateDerivedTypes() instantiates it later.
903 newType = &scope_.MakeDerivedType(type.category(), std::move(newDerived));
904 }
905 }
906 if (newType) {
907 map_.typeMap[&type] = newType;
908 }
909 return newType;
910}
911
912const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec *type) {
913 return type ? MapType(*type) : nullptr;
914}
915
916const Symbol *SymbolMapper::MapInterface(const Symbol *interface) {
917 if (const Symbol *mapped{MapSymbol(interface)}) {
918 return mapped;
919 }
920 if (interface) {
921 if (&interface->owner() != &scope_) {
922 return interface;
923 } else if (const auto *subp{interface->detailsIf<SubprogramDetails>()};
924 subp && subp->isInterface()) {
925 return CopySymbol(interface);
926 }
927 }
928 return nullptr;
929}
930
931void MapSubprogramToNewSymbols(const Symbol &oldSymbol, Symbol &newSymbol,
932 Scope &newScope, SymbolAndTypeMappings *mappings) {
933 SymbolAndTypeMappings newMappings;
934 if (!mappings) {
935 mappings = &newMappings;
936 }
937 mappings->symbolMap[&oldSymbol] = &newSymbol;
938 const auto &oldDetails{oldSymbol.get<SubprogramDetails>()};
939 auto &newDetails{newSymbol.get<SubprogramDetails>()};
940 SymbolMapper mapper{newScope, *mappings};
941 for (const Symbol *dummyArg : oldDetails.dummyArgs()) {
942 if (!dummyArg) {
943 newDetails.add_alternateReturn();
944 } else if (Symbol * copy{mapper.CopySymbol(dummyArg)}) {
945 copy->set(Symbol::Flag::Implicit, false);
946 newDetails.add_dummyArg(*copy);
947 mappings->symbolMap[dummyArg] = copy;
948 }
949 }
950 if (oldDetails.isFunction()) {
951 newScope.erase(newSymbol.name());
952 const Symbol &result{oldDetails.result()};
953 if (Symbol * copy{mapper.CopySymbol(&result)}) {
954 newDetails.set_result(*copy);
955 mappings->symbolMap[&result] = copy;
956 }
957 }
958 for (auto &[_, ref] : newScope) {
959 mapper.MapSymbolExprs(*ref);
960 }
961 newScope.InstantiateDerivedTypes();
962}
963
964} // namespace Fortran::semantics
965

source code of flang/lib/Semantics/resolve-names-utils.cpp