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