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 | |
26 | namespace Fortran::semantics { |
27 | |
28 | using common::LanguageFeature; |
29 | using common::LogicalOperator; |
30 | using common::NumericOperator; |
31 | using common::RelationalOperator; |
32 | using IntrinsicOperator = parser::DefinedOperator::IntrinsicOperator; |
33 | |
34 | static GenericKind MapIntrinsicOperator(IntrinsicOperator); |
35 | |
36 | Symbol *Resolve(const parser::Name &name, Symbol *symbol) { |
37 | if (symbol && !name.symbol) { |
38 | name.symbol = symbol; |
39 | } |
40 | return symbol; |
41 | } |
42 | Symbol &Resolve(const parser::Name &name, Symbol &symbol) { |
43 | return *Resolve(name, &symbol); |
44 | } |
45 | |
46 | parser::MessageFixedText WithSeverity( |
47 | const parser::MessageFixedText &msg, parser::Severity severity) { |
48 | return parser::MessageFixedText{ |
49 | msg.text().begin(), msg.text().size(), severity}; |
50 | } |
51 | |
52 | bool 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 | |
70 | bool 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 | |
78 | void 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 | |
89 | void GenericSpecInfo::Analyze(const parser::DefinedOpName &name) { |
90 | kind_ = GenericKind::OtherKind::DefinedOp; |
91 | parseName_ = &name.v; |
92 | symbolName_ = name.v.source; |
93 | } |
94 | |
95 | void 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 | |
136 | llvm::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 |
147 | static 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 | |
187 | class ArraySpecAnalyzer { |
188 | public: |
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 | |
195 | private: |
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 | |
217 | ArraySpec AnalyzeArraySpec( |
218 | SemanticsContext &context, const parser::ArraySpec &arraySpec) { |
219 | return ArraySpecAnalyzer{context}.Analyze(arraySpec); |
220 | } |
221 | ArraySpec AnalyzeArraySpec( |
222 | SemanticsContext &context, const parser::ComponentArraySpec &arraySpec) { |
223 | return ArraySpecAnalyzer{context}.Analyze(arraySpec); |
224 | } |
225 | ArraySpec AnalyzeDeferredShapeSpecList(SemanticsContext &context, |
226 | const parser::DeferredShapeSpecList &deferredShapeSpecs) { |
227 | return ArraySpecAnalyzer{context}.AnalyzeDeferredShapeSpecList( |
228 | deferredShapeSpecs); |
229 | } |
230 | ArraySpec AnalyzeCoarraySpec( |
231 | SemanticsContext &context, const parser::CoarraySpec &coarraySpec) { |
232 | return ArraySpecAnalyzer{context}.Analyze(coarraySpec); |
233 | } |
234 | |
235 | ArraySpec 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 | } |
240 | ArraySpec 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 | } |
254 | ArraySpec ArraySpecAnalyzer::AnalyzeDeferredShapeSpecList( |
255 | const parser::DeferredShapeSpecList &x) { |
256 | Analyze(x); |
257 | CHECK(!arraySpec_.empty()); |
258 | return arraySpec_; |
259 | } |
260 | ArraySpec 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 | |
275 | void ArraySpecAnalyzer::Analyze(const parser::AssumedShapeSpec &x) { |
276 | arraySpec_.push_back(ShapeSpec::MakeAssumedShape(GetBound(x.v))); |
277 | } |
278 | void ArraySpecAnalyzer::Analyze(const parser::ExplicitShapeSpec &x) { |
279 | MakeExplicit(std::get<std::optional<parser::SpecificationExpr>>(x.t), |
280 | std::get<parser::SpecificationExpr>(x.t)); |
281 | } |
282 | void ArraySpecAnalyzer::Analyze(const parser::AssumedImpliedSpec &x) { |
283 | MakeImplied(x.v); |
284 | } |
285 | void ArraySpecAnalyzer::Analyze(const parser::DeferredShapeSpecList &x) { |
286 | MakeDeferred(x.v); |
287 | } |
288 | void ArraySpecAnalyzer::Analyze(const parser::AssumedRankSpec &) { |
289 | arraySpec_.push_back(ShapeSpec::MakeAssumedRank()); |
290 | } |
291 | |
292 | void 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 | } |
297 | void ArraySpecAnalyzer::MakeImplied( |
298 | const std::optional<parser::SpecificationExpr> &lb) { |
299 | arraySpec_.push_back(ShapeSpec::MakeImplied(GetBound(lb))); |
300 | } |
301 | void ArraySpecAnalyzer::MakeDeferred(int n) { |
302 | for (int i = 0; i < n; ++i) { |
303 | arraySpec_.push_back(ShapeSpec::MakeDeferred()); |
304 | } |
305 | } |
306 | |
307 | Bound ArraySpecAnalyzer::GetBound( |
308 | const std::optional<parser::SpecificationExpr> &x) { |
309 | return x ? GetBound(*x) : Bound{1}; |
310 | } |
311 | Bound 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. |
325 | static 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 | } |
338 | static void PropagateSaveAttr(const EquivalenceSet &src, EquivalenceSet &dst) { |
339 | if (!src.empty()) { |
340 | PropagateSaveAttr(src.front(), dst); |
341 | } |
342 | } |
343 | |
344 | void 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 | |
379 | void 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. |
403 | bool 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] |
461 | void 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. |
474 | const 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 | |
484 | bool 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 | |
508 | bool 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 | |
548 | bool EquivalenceSets::CheckObject(const parser::Name &name) { |
549 | currObject_.symbol = name.symbol; |
550 | return currObject_.symbol != nullptr; |
551 | } |
552 | |
553 | bool 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 | |
576 | bool 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 | |
603 | bool 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 |
612 | bool 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 | |
629 | bool EquivalenceSets::IsDefaultNumericSequenceType(const DeclTypeSpec *type) { |
630 | return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) { |
631 | return IsDefaultKindNumericType(type); |
632 | }); |
633 | } |
634 | |
635 | bool 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. |
644 | bool 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 | |
669 | struct SymbolAndTypeMappings { |
670 | std::map<const Symbol *, const Symbol *> symbolMap; |
671 | std::map<const DeclTypeSpec *, const DeclTypeSpec *> typeMap; |
672 | }; |
673 | |
674 | class SymbolMapper : public evaluate::AnyTraverse<SymbolMapper, bool> { |
675 | public: |
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 | |
697 | private: |
698 | void MapParamValue(ParamValue ¶m) { (*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 | |
714 | Symbol *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 ©{*pair.first->second}; |
721 | map_.symbolMap[symbol] = © |
722 | copy.set(symbol->test(Symbol::Flag::Subroutine) |
723 | ? Symbol::Flag::Subroutine |
724 | : Symbol::Flag::Function); |
725 | Scope &newScope{scope_.MakeScope(Scope::Kind::Subprogram, ©)}; |
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 © |
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 | |
744 | void 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 | |
786 | const 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 | |
793 | const Symbol *SymbolMapper::MapSymbol(const Symbol *symbol) const { |
794 | return symbol ? MapSymbol(*symbol) : nullptr; |
795 | } |
796 | |
797 | const 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 | |
829 | const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec *type) { |
830 | return type ? MapType(*type) : nullptr; |
831 | } |
832 | |
833 | const 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 | |
848 | void 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 |
Definitions
- MapIntrinsicOperator
- Resolve
- Resolve
- WithSeverity
- IsIntrinsicOperator
- IsLogicalConstant
- Resolve
- Analyze
- Analyze
- operator<<
- MapIntrinsicOperator
- ArraySpecAnalyzer
- ArraySpecAnalyzer
- Analyze
- AnalyzeArraySpec
- AnalyzeArraySpec
- AnalyzeDeferredShapeSpecList
- AnalyzeCoarraySpec
- Analyze
- Analyze
- AnalyzeDeferredShapeSpecList
- Analyze
- Analyze
- Analyze
- Analyze
- Analyze
- Analyze
- MakeExplicit
- MakeImplied
- MakeDeferred
- GetBound
- GetBound
- PropagateSaveAttr
- PropagateSaveAttr
- AddToSet
- FinishSet
- CheckCanEquivalence
- MergeInto
- Find
- CheckDesignator
- CheckDataRef
- CheckObject
- CheckArrayBound
- CheckSubstringBound
- IsCharacterSequenceType
- IsDefaultKindNumericType
- IsDefaultNumericSequenceType
- IsAnyNumericSequenceType
- IsSequenceType
- SymbolAndTypeMappings
- SymbolMapper
- SymbolMapper
- operator()
- operator()
- MapParamValue
- MapBound
- MapShapeSpec
- CopySymbol
- MapSymbolExprs
- MapSymbol
- MapSymbol
- MapType
- MapType
- MapInterface
Learn to use CMake with our Intro Training
Find out more