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

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