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