1//===-- lib/Semantics/tools.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 "flang/Parser/tools.h"
10#include "flang/Common/indirection.h"
11#include "flang/Parser/dump-parse-tree.h"
12#include "flang/Parser/message.h"
13#include "flang/Parser/parse-tree.h"
14#include "flang/Semantics/scope.h"
15#include "flang/Semantics/semantics.h"
16#include "flang/Semantics/symbol.h"
17#include "flang/Semantics/tools.h"
18#include "flang/Semantics/type.h"
19#include "flang/Support/Fortran.h"
20#include "llvm/ADT/StringSwitch.h"
21#include "llvm/Support/raw_ostream.h"
22#include <algorithm>
23#include <set>
24#include <variant>
25
26namespace Fortran::semantics {
27
28// Find this or containing scope that matches predicate
29static const Scope *FindScopeContaining(
30 const Scope &start, std::function<bool(const Scope &)> predicate) {
31 for (const Scope *scope{&start};; scope = &scope->parent()) {
32 if (predicate(*scope)) {
33 return scope;
34 }
35 if (scope->IsTopLevel()) {
36 return nullptr;
37 }
38 }
39}
40
41const Scope &GetTopLevelUnitContaining(const Scope &start) {
42 CHECK(!start.IsTopLevel());
43 return DEREF(FindScopeContaining(
44 start, [](const Scope &scope) { return scope.parent().IsTopLevel(); }));
45}
46
47const Scope &GetTopLevelUnitContaining(const Symbol &symbol) {
48 return GetTopLevelUnitContaining(symbol.owner());
49}
50
51const Scope *FindModuleContaining(const Scope &start) {
52 return FindScopeContaining(
53 start, [](const Scope &scope) { return scope.IsModule(); });
54}
55
56const Scope *FindModuleOrSubmoduleContaining(const Scope &start) {
57 return FindScopeContaining(start, [](const Scope &scope) {
58 return scope.IsModule() || scope.IsSubmodule();
59 });
60}
61
62const Scope *FindModuleFileContaining(const Scope &start) {
63 return FindScopeContaining(
64 start, [](const Scope &scope) { return scope.IsModuleFile(); });
65}
66
67const Scope &GetProgramUnitContaining(const Scope &start) {
68 CHECK(!start.IsTopLevel());
69 return DEREF(FindScopeContaining(start, [](const Scope &scope) {
70 switch (scope.kind()) {
71 case Scope::Kind::Module:
72 case Scope::Kind::MainProgram:
73 case Scope::Kind::Subprogram:
74 case Scope::Kind::BlockData:
75 return true;
76 default:
77 return false;
78 }
79 }));
80}
81
82const Scope &GetProgramUnitContaining(const Symbol &symbol) {
83 return GetProgramUnitContaining(symbol.owner());
84}
85
86const Scope &GetProgramUnitOrBlockConstructContaining(const Scope &start) {
87 CHECK(!start.IsTopLevel());
88 return DEREF(FindScopeContaining(start, [](const Scope &scope) {
89 switch (scope.kind()) {
90 case Scope::Kind::Module:
91 case Scope::Kind::MainProgram:
92 case Scope::Kind::Subprogram:
93 case Scope::Kind::BlockData:
94 case Scope::Kind::BlockConstruct:
95 return true;
96 default:
97 return false;
98 }
99 }));
100}
101
102const Scope &GetProgramUnitOrBlockConstructContaining(const Symbol &symbol) {
103 return GetProgramUnitOrBlockConstructContaining(symbol.owner());
104}
105
106const Scope *FindPureProcedureContaining(const Scope &start) {
107 // N.B. We only need to examine the innermost containing program unit
108 // because an internal subprogram of a pure subprogram must also
109 // be pure (C1592).
110 if (start.IsTopLevel()) {
111 return nullptr;
112 } else {
113 const Scope &scope{GetProgramUnitContaining(start)};
114 return IsPureProcedure(scope) ? &scope : nullptr;
115 }
116}
117
118const Scope *FindOpenACCConstructContaining(const Scope *scope) {
119 return scope ? FindScopeContaining(*scope,
120 [](const Scope &s) {
121 return s.kind() == Scope::Kind::OpenACCConstruct;
122 })
123 : nullptr;
124}
125
126// 7.5.2.4 "same derived type" test -- rely on IsTkCompatibleWith() and its
127// infrastructure to detect and handle comparisons on distinct (but "same")
128// sequence/bind(C) derived types
129static bool MightBeSameDerivedType(
130 const std::optional<evaluate::DynamicType> &lhsType,
131 const std::optional<evaluate::DynamicType> &rhsType) {
132 return lhsType && rhsType && lhsType->IsTkCompatibleWith(*rhsType);
133}
134
135Tristate IsDefinedAssignment(
136 const std::optional<evaluate::DynamicType> &lhsType, int lhsRank,
137 const std::optional<evaluate::DynamicType> &rhsType, int rhsRank) {
138 if (!lhsType || !rhsType) {
139 return Tristate::No; // error or rhs is untyped
140 }
141 TypeCategory lhsCat{lhsType->category()};
142 TypeCategory rhsCat{rhsType->category()};
143 if (rhsRank > 0 && lhsRank != rhsRank) {
144 return Tristate::Yes;
145 } else if (lhsCat != TypeCategory::Derived) {
146 return ToTristate(lhsCat != rhsCat &&
147 (!IsNumericTypeCategory(lhsCat) || !IsNumericTypeCategory(rhsCat) ||
148 lhsCat == TypeCategory::Unsigned ||
149 rhsCat == TypeCategory::Unsigned));
150 } else if (MightBeSameDerivedType(lhsType, rhsType)) {
151 return Tristate::Maybe; // TYPE(t) = TYPE(t) can be defined or intrinsic
152 } else {
153 return Tristate::Yes;
154 }
155}
156
157bool IsIntrinsicRelational(common::RelationalOperator opr,
158 const evaluate::DynamicType &type0, int rank0,
159 const evaluate::DynamicType &type1, int rank1) {
160 if (!evaluate::AreConformable(rank0, rank1)) {
161 return false;
162 } else {
163 auto cat0{type0.category()};
164 auto cat1{type1.category()};
165 if (cat0 == TypeCategory::Unsigned || cat1 == TypeCategory::Unsigned) {
166 return cat0 == cat1;
167 } else if (IsNumericTypeCategory(cat0) && IsNumericTypeCategory(cat1)) {
168 // numeric types: EQ/NE always ok, others ok for non-complex
169 return opr == common::RelationalOperator::EQ ||
170 opr == common::RelationalOperator::NE ||
171 (cat0 != TypeCategory::Complex && cat1 != TypeCategory::Complex);
172 } else {
173 // not both numeric: only Character is ok
174 return cat0 == TypeCategory::Character && cat1 == TypeCategory::Character;
175 }
176 }
177}
178
179bool IsIntrinsicNumeric(const evaluate::DynamicType &type0) {
180 return IsNumericTypeCategory(type0.category());
181}
182bool IsIntrinsicNumeric(const evaluate::DynamicType &type0, int rank0,
183 const evaluate::DynamicType &type1, int rank1) {
184 return evaluate::AreConformable(rank0, rank1) &&
185 IsNumericTypeCategory(type0.category()) &&
186 IsNumericTypeCategory(type1.category());
187}
188
189bool IsIntrinsicLogical(const evaluate::DynamicType &type0) {
190 return type0.category() == TypeCategory::Logical;
191}
192bool IsIntrinsicLogical(const evaluate::DynamicType &type0, int rank0,
193 const evaluate::DynamicType &type1, int rank1) {
194 return evaluate::AreConformable(rank0, rank1) &&
195 type0.category() == TypeCategory::Logical &&
196 type1.category() == TypeCategory::Logical;
197}
198
199bool IsIntrinsicConcat(const evaluate::DynamicType &type0, int rank0,
200 const evaluate::DynamicType &type1, int rank1) {
201 return evaluate::AreConformable(rank0, rank1) &&
202 type0.category() == TypeCategory::Character &&
203 type1.category() == TypeCategory::Character &&
204 type0.kind() == type1.kind();
205}
206
207bool IsGenericDefinedOp(const Symbol &symbol) {
208 const Symbol &ultimate{symbol.GetUltimate()};
209 if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
210 return generic->kind().IsDefinedOperator();
211 } else if (const auto *misc{ultimate.detailsIf<MiscDetails>()}) {
212 return misc->kind() == MiscDetails::Kind::TypeBoundDefinedOp;
213 } else {
214 return false;
215 }
216}
217
218bool IsDefinedOperator(SourceName name) {
219 const char *begin{name.begin()};
220 const char *end{name.end()};
221 return begin != end && begin[0] == '.' && end[-1] == '.';
222}
223
224std::string MakeOpName(SourceName name) {
225 std::string result{name.ToString()};
226 return IsDefinedOperator(name) ? "OPERATOR(" + result + ")"
227 : result.find("operator(", 0) == 0 ? parser::ToUpperCaseLetters(result)
228 : result;
229}
230
231bool IsCommonBlockContaining(const Symbol &block, const Symbol &object) {
232 const auto &objects{block.get<CommonBlockDetails>().objects()};
233 return llvm::is_contained(objects, object);
234}
235
236bool IsUseAssociated(const Symbol &symbol, const Scope &scope) {
237 const Scope &owner{GetTopLevelUnitContaining(symbol.GetUltimate().owner())};
238 return owner.kind() == Scope::Kind::Module &&
239 owner != GetTopLevelUnitContaining(scope);
240}
241
242bool DoesScopeContain(
243 const Scope *maybeAncestor, const Scope &maybeDescendent) {
244 return maybeAncestor && !maybeDescendent.IsTopLevel() &&
245 FindScopeContaining(maybeDescendent.parent(),
246 [&](const Scope &scope) { return &scope == maybeAncestor; });
247}
248
249bool DoesScopeContain(const Scope *maybeAncestor, const Symbol &symbol) {
250 return DoesScopeContain(maybeAncestor, symbol.owner());
251}
252
253static const Symbol &FollowHostAssoc(const Symbol &symbol) {
254 for (const Symbol *s{&symbol};;) {
255 const auto *details{s->detailsIf<HostAssocDetails>()};
256 if (!details) {
257 return *s;
258 }
259 s = &details->symbol();
260 }
261}
262
263bool IsHostAssociated(const Symbol &symbol, const Scope &scope) {
264 const Symbol &base{FollowHostAssoc(symbol)};
265 return base.owner().IsTopLevel() ||
266 DoesScopeContain(&GetProgramUnitOrBlockConstructContaining(base),
267 GetProgramUnitOrBlockConstructContaining(scope));
268}
269
270bool IsHostAssociatedIntoSubprogram(const Symbol &symbol, const Scope &scope) {
271 const Symbol &base{FollowHostAssoc(symbol)};
272 return base.owner().IsTopLevel() ||
273 DoesScopeContain(&GetProgramUnitOrBlockConstructContaining(base),
274 GetProgramUnitContaining(scope));
275}
276
277bool IsInStmtFunction(const Symbol &symbol) {
278 if (const Symbol * function{symbol.owner().symbol()}) {
279 return IsStmtFunction(*function);
280 }
281 return false;
282}
283
284bool IsStmtFunctionDummy(const Symbol &symbol) {
285 return IsDummy(symbol) && IsInStmtFunction(symbol);
286}
287
288bool IsStmtFunctionResult(const Symbol &symbol) {
289 return IsFunctionResult(symbol) && IsInStmtFunction(symbol);
290}
291
292bool IsPointerDummy(const Symbol &symbol) {
293 return IsPointer(symbol) && IsDummy(symbol);
294}
295
296bool IsBindCProcedure(const Symbol &original) {
297 const Symbol &symbol{original.GetUltimate()};
298 if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
299 if (procDetails->procInterface()) {
300 // procedure component with a BIND(C) interface
301 return IsBindCProcedure(*procDetails->procInterface());
302 }
303 }
304 return symbol.attrs().test(Attr::BIND_C) && IsProcedure(symbol);
305}
306
307bool IsBindCProcedure(const Scope &scope) {
308 if (const Symbol * symbol{scope.GetSymbol()}) {
309 return IsBindCProcedure(*symbol);
310 } else {
311 return false;
312 }
313}
314
315// C1594 specifies several ways by which an object might be globally visible.
316const Symbol *FindExternallyVisibleObject(
317 const Symbol &object, const Scope &scope, bool isPointerDefinition) {
318 // TODO: Storage association with any object for which this predicate holds,
319 // once EQUIVALENCE is supported.
320 const Symbol &ultimate{GetAssociationRoot(object)};
321 if (IsDummy(ultimate)) {
322 if (IsIntentIn(ultimate)) {
323 return &ultimate;
324 }
325 if (!isPointerDefinition && IsPointer(ultimate) &&
326 IsPureProcedure(ultimate.owner()) && IsFunction(ultimate.owner())) {
327 return &ultimate;
328 }
329 } else if (ultimate.owner().IsDerivedType()) {
330 return nullptr;
331 } else if (&GetProgramUnitContaining(ultimate) !=
332 &GetProgramUnitContaining(scope)) {
333 return &object;
334 } else if (const Symbol * block{FindCommonBlockContaining(ultimate)}) {
335 return block;
336 }
337 return nullptr;
338}
339
340const Symbol &BypassGeneric(const Symbol &symbol) {
341 const Symbol &ultimate{symbol.GetUltimate()};
342 if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
343 if (const Symbol * specific{generic->specific()}) {
344 return *specific;
345 }
346 }
347 return symbol;
348}
349
350const Symbol &GetCrayPointer(const Symbol &crayPointee) {
351 const Symbol *found{nullptr};
352 for (const auto &[pointee, pointer] :
353 crayPointee.GetUltimate().owner().crayPointers()) {
354 if (pointee == crayPointee.name()) {
355 found = &pointer.get();
356 break;
357 }
358 }
359 return DEREF(found);
360}
361
362bool ExprHasTypeCategory(
363 const SomeExpr &expr, const common::TypeCategory &type) {
364 auto dynamicType{expr.GetType()};
365 return dynamicType && dynamicType->category() == type;
366}
367
368bool ExprTypeKindIsDefault(
369 const SomeExpr &expr, const SemanticsContext &context) {
370 auto dynamicType{expr.GetType()};
371 return dynamicType &&
372 dynamicType->category() != common::TypeCategory::Derived &&
373 dynamicType->kind() == context.GetDefaultKind(dynamicType->category());
374}
375
376// If an analyzed expr or assignment is missing, dump the node and die.
377template <typename T>
378static void CheckMissingAnalysis(
379 bool crash, SemanticsContext *context, const T &x) {
380 if (crash && !(context && context->AnyFatalError())) {
381 std::string buf;
382 llvm::raw_string_ostream ss{buf};
383 ss << "node has not been analyzed:\n";
384 parser::DumpTree(ss, x);
385 common::die(buf.c_str());
386 }
387}
388
389const SomeExpr *GetExprHelper::Get(const parser::Expr &x) {
390 CheckMissingAnalysis(crashIfNoExpr_ && !x.typedExpr, context_, x);
391 return x.typedExpr ? common::GetPtrFromOptional(x.typedExpr->v) : nullptr;
392}
393const SomeExpr *GetExprHelper::Get(const parser::Variable &x) {
394 CheckMissingAnalysis(crashIfNoExpr_ && !x.typedExpr, context_, x);
395 return x.typedExpr ? common::GetPtrFromOptional(x.typedExpr->v) : nullptr;
396}
397const SomeExpr *GetExprHelper::Get(const parser::DataStmtConstant &x) {
398 CheckMissingAnalysis(crashIfNoExpr_ && !x.typedExpr, context_, x);
399 return x.typedExpr ? common::GetPtrFromOptional(x.typedExpr->v) : nullptr;
400}
401const SomeExpr *GetExprHelper::Get(const parser::AllocateObject &x) {
402 CheckMissingAnalysis(crashIfNoExpr_ && !x.typedExpr, context_, x);
403 return x.typedExpr ? common::GetPtrFromOptional(x.typedExpr->v) : nullptr;
404}
405const SomeExpr *GetExprHelper::Get(const parser::PointerObject &x) {
406 CheckMissingAnalysis(crashIfNoExpr_ && !x.typedExpr, context_, x);
407 return x.typedExpr ? common::GetPtrFromOptional(x.typedExpr->v) : nullptr;
408}
409
410const evaluate::Assignment *GetAssignment(const parser::AssignmentStmt &x) {
411 return x.typedAssignment ? common::GetPtrFromOptional(x.typedAssignment->v)
412 : nullptr;
413}
414const evaluate::Assignment *GetAssignment(
415 const parser::PointerAssignmentStmt &x) {
416 return x.typedAssignment ? common::GetPtrFromOptional(x.typedAssignment->v)
417 : nullptr;
418}
419
420const Symbol *FindInterface(const Symbol &symbol) {
421 return common::visit(
422 common::visitors{
423 [](const ProcEntityDetails &details) {
424 const Symbol *interface{details.procInterface()};
425 return interface ? FindInterface(*interface) : nullptr;
426 },
427 [](const ProcBindingDetails &details) {
428 return FindInterface(details.symbol());
429 },
430 [&](const SubprogramDetails &) { return &symbol; },
431 [](const UseDetails &details) {
432 return FindInterface(details.symbol());
433 },
434 [](const HostAssocDetails &details) {
435 return FindInterface(details.symbol());
436 },
437 [](const GenericDetails &details) {
438 return details.specific() ? FindInterface(*details.specific())
439 : nullptr;
440 },
441 [](const auto &) -> const Symbol * { return nullptr; },
442 },
443 symbol.details());
444}
445
446const Symbol *FindSubprogram(const Symbol &symbol) {
447 return common::visit(
448 common::visitors{
449 [&](const ProcEntityDetails &details) -> const Symbol * {
450 if (details.procInterface()) {
451 return FindSubprogram(*details.procInterface());
452 } else {
453 return &symbol;
454 }
455 },
456 [](const ProcBindingDetails &details) {
457 return FindSubprogram(details.symbol());
458 },
459 [&](const SubprogramDetails &) { return &symbol; },
460 [](const UseDetails &details) {
461 return FindSubprogram(details.symbol());
462 },
463 [](const HostAssocDetails &details) {
464 return FindSubprogram(details.symbol());
465 },
466 [](const GenericDetails &details) {
467 return details.specific() ? FindSubprogram(*details.specific())
468 : nullptr;
469 },
470 [](const auto &) -> const Symbol * { return nullptr; },
471 },
472 symbol.details());
473}
474
475const Symbol *FindOverriddenBinding(
476 const Symbol &symbol, bool &isInaccessibleDeferred) {
477 isInaccessibleDeferred = false;
478 if (symbol.has<ProcBindingDetails>()) {
479 if (const DeclTypeSpec * parentType{FindParentTypeSpec(symbol.owner())}) {
480 if (const DerivedTypeSpec * parentDerived{parentType->AsDerived()}) {
481 if (const Scope * parentScope{parentDerived->typeSymbol().scope()}) {
482 if (const Symbol *
483 overridden{parentScope->FindComponent(symbol.name())}) {
484 // 7.5.7.3 p1: only accessible bindings are overridden
485 if (IsAccessible(*overridden, symbol.owner())) {
486 return overridden;
487 } else if (overridden->attrs().test(Attr::DEFERRED)) {
488 isInaccessibleDeferred = true;
489 return overridden;
490 }
491 }
492 }
493 }
494 }
495 }
496 return nullptr;
497}
498
499const Symbol *FindGlobal(const Symbol &original) {
500 const Symbol &ultimate{original.GetUltimate()};
501 if (ultimate.owner().IsGlobal()) {
502 return &ultimate;
503 }
504 bool isLocal{false};
505 if (IsDummy(ultimate)) {
506 } else if (IsPointer(ultimate)) {
507 } else if (ultimate.has<ProcEntityDetails>()) {
508 isLocal = IsExternal(ultimate);
509 } else if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
510 isLocal = subp->isInterface();
511 }
512 if (isLocal) {
513 const std::string *bind{ultimate.GetBindName()};
514 if (!bind || ultimate.name() == *bind) {
515 const Scope &globalScope{ultimate.owner().context().globalScope()};
516 if (auto iter{globalScope.find(ultimate.name())};
517 iter != globalScope.end()) {
518 const Symbol &global{*iter->second};
519 const std::string *globalBind{global.GetBindName()};
520 if (!globalBind || global.name() == *globalBind) {
521 return &global;
522 }
523 }
524 }
525 }
526 return nullptr;
527}
528
529const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &derived) {
530 return FindParentTypeSpec(derived.typeSymbol());
531}
532
533const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &decl) {
534 if (const DerivedTypeSpec * derived{decl.AsDerived()}) {
535 return FindParentTypeSpec(*derived);
536 } else {
537 return nullptr;
538 }
539}
540
541const DeclTypeSpec *FindParentTypeSpec(const Scope &scope) {
542 if (scope.kind() == Scope::Kind::DerivedType) {
543 if (const auto *symbol{scope.symbol()}) {
544 return FindParentTypeSpec(*symbol);
545 }
546 }
547 return nullptr;
548}
549
550const DeclTypeSpec *FindParentTypeSpec(const Symbol &symbol) {
551 if (const Scope * scope{symbol.scope()}) {
552 if (const auto *details{symbol.detailsIf<DerivedTypeDetails>()}) {
553 if (const Symbol * parent{details->GetParentComponent(*scope)}) {
554 return parent->GetType();
555 }
556 }
557 }
558 return nullptr;
559}
560
561const EquivalenceSet *FindEquivalenceSet(const Symbol &symbol) {
562 const Symbol &ultimate{symbol.GetUltimate()};
563 for (const EquivalenceSet &set : ultimate.owner().equivalenceSets()) {
564 for (const EquivalenceObject &object : set) {
565 if (object.symbol == ultimate) {
566 return &set;
567 }
568 }
569 }
570 return nullptr;
571}
572
573bool IsOrContainsEventOrLockComponent(const Symbol &original) {
574 const Symbol &symbol{ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
575 if (evaluate::IsVariable(symbol)) {
576 if (const DeclTypeSpec * type{symbol.GetType()}) {
577 if (const DerivedTypeSpec * derived{type->AsDerived()}) {
578 return IsEventTypeOrLockType(derived) ||
579 FindEventOrLockPotentialComponent(*derived);
580 }
581 }
582 }
583 return false;
584}
585
586// Check this symbol suitable as a type-bound procedure - C769
587bool CanBeTypeBoundProc(const Symbol &symbol) {
588 if (IsDummy(symbol) || IsProcedurePointer(symbol)) {
589 return false;
590 } else if (symbol.has<SubprogramNameDetails>()) {
591 return symbol.owner().kind() == Scope::Kind::Module;
592 } else if (auto *details{symbol.detailsIf<SubprogramDetails>()}) {
593 if (details->isInterface()) {
594 return !symbol.attrs().test(Attr::ABSTRACT);
595 } else {
596 return symbol.owner().kind() == Scope::Kind::Module;
597 }
598 } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
599 return !symbol.attrs().test(Attr::INTRINSIC) &&
600 proc->HasExplicitInterface();
601 } else {
602 return false;
603 }
604}
605
606bool HasDeclarationInitializer(const Symbol &symbol) {
607 if (IsNamedConstant(symbol)) {
608 return false;
609 } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
610 return object->init().has_value();
611 } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
612 return proc->init().has_value();
613 } else {
614 return false;
615 }
616}
617
618bool IsInitialized(const Symbol &symbol, bool ignoreDataStatements,
619 bool ignoreAllocatable, bool ignorePointer) {
620 if (!ignoreAllocatable && IsAllocatable(symbol)) {
621 return true;
622 } else if (!ignoreDataStatements && symbol.test(Symbol::Flag::InDataStmt)) {
623 return true;
624 } else if (HasDeclarationInitializer(symbol)) {
625 return true;
626 } else if (IsPointer(symbol)) {
627 return !ignorePointer;
628 } else if (IsNamedConstant(symbol)) {
629 return false;
630 } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
631 if ((!object->isDummy() || IsIntentOut(symbol)) && object->type()) {
632 if (const auto *derived{object->type()->AsDerived()}) {
633 return derived->HasDefaultInitialization(
634 ignoreAllocatable, ignorePointer);
635 }
636 }
637 }
638 return false;
639}
640
641bool IsDestructible(const Symbol &symbol, const Symbol *derivedTypeSymbol) {
642 if (IsAllocatable(symbol) || IsAutomatic(symbol)) {
643 return true;
644 } else if (IsNamedConstant(symbol) || IsFunctionResult(symbol) ||
645 IsPointer(symbol)) {
646 return false;
647 } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
648 if ((!object->isDummy() || IsIntentOut(symbol)) && object->type()) {
649 if (const auto *derived{object->type()->AsDerived()}) {
650 return &derived->typeSymbol() != derivedTypeSymbol &&
651 derived->HasDestruction();
652 }
653 }
654 }
655 return false;
656}
657
658bool HasIntrinsicTypeName(const Symbol &symbol) {
659 std::string name{symbol.name().ToString()};
660 if (name == "doubleprecision") {
661 return true;
662 } else if (name == "derived") {
663 return false;
664 } else {
665 for (int i{0}; i != common::TypeCategory_enumSize; ++i) {
666 if (name == parser::ToLowerCaseLetters(EnumToString(TypeCategory{i}))) {
667 return true;
668 }
669 }
670 return false;
671 }
672}
673
674bool IsSeparateModuleProcedureInterface(const Symbol *symbol) {
675 if (symbol && symbol->attrs().test(Attr::MODULE)) {
676 if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
677 return details->isInterface();
678 }
679 }
680 return false;
681}
682
683SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &spec) {
684 SymbolVector result;
685 const Symbol &typeSymbol{spec.typeSymbol()};
686 if (const auto *derived{typeSymbol.detailsIf<DerivedTypeDetails>()}) {
687 for (const auto &pair : derived->finals()) {
688 const Symbol &subr{*pair.second};
689 // Errors in FINAL subroutines are caught in CheckFinal
690 // in check-declarations.cpp.
691 if (const auto *subprog{subr.detailsIf<SubprogramDetails>()};
692 subprog && subprog->dummyArgs().size() == 1) {
693 if (const Symbol * arg{subprog->dummyArgs()[0]}) {
694 if (const DeclTypeSpec * type{arg->GetType()}) {
695 if (type->category() == DeclTypeSpec::TypeDerived &&
696 evaluate::AreSameDerivedType(spec, type->derivedTypeSpec())) {
697 result.emplace_back(subr);
698 }
699 }
700 }
701 }
702 }
703 }
704 return result;
705}
706
707const Symbol *IsFinalizable(const Symbol &symbol,
708 std::set<const DerivedTypeSpec *> *inProgress, bool withImpureFinalizer) {
709 if (IsPointer(symbol) || evaluate::IsAssumedRank(symbol)) {
710 return nullptr;
711 }
712 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
713 if (object->isDummy() && !IsIntentOut(symbol)) {
714 return nullptr;
715 }
716 const DeclTypeSpec *type{object->type()};
717 if (const DerivedTypeSpec * typeSpec{type ? type->AsDerived() : nullptr}) {
718 return IsFinalizable(
719 *typeSpec, inProgress, withImpureFinalizer, symbol.Rank());
720 }
721 }
722 return nullptr;
723}
724
725const Symbol *IsFinalizable(const DerivedTypeSpec &derived,
726 std::set<const DerivedTypeSpec *> *inProgress, bool withImpureFinalizer,
727 std::optional<int> rank) {
728 const Symbol *elemental{nullptr};
729 for (auto ref : FinalsForDerivedTypeInstantiation(derived)) {
730 const Symbol *symbol{&ref->GetUltimate()};
731 if (const auto *binding{symbol->detailsIf<ProcBindingDetails>()}) {
732 symbol = &binding->symbol();
733 }
734 if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
735 symbol = proc->procInterface();
736 }
737 if (!symbol) {
738 } else if (IsElementalProcedure(*symbol)) {
739 elemental = symbol;
740 } else {
741 if (rank) {
742 if (const SubprogramDetails *
743 subp{symbol->detailsIf<SubprogramDetails>()}) {
744 if (const auto &args{subp->dummyArgs()}; !args.empty() &&
745 args.at(0) && !evaluate::IsAssumedRank(*args.at(0)) &&
746 args.at(0)->Rank() != *rank) {
747 continue; // not a finalizer for this rank
748 }
749 }
750 }
751 if (!withImpureFinalizer || !IsPureProcedure(*symbol)) {
752 return symbol;
753 }
754 // Found non-elemental pure finalizer of matching rank, but still
755 // need to check components for an impure finalizer.
756 elemental = nullptr;
757 break;
758 }
759 }
760 if (elemental && (!withImpureFinalizer || !IsPureProcedure(*elemental))) {
761 return elemental;
762 }
763 // Check components (including ancestors)
764 std::set<const DerivedTypeSpec *> basis;
765 if (inProgress) {
766 if (inProgress->find(&derived) != inProgress->end()) {
767 return nullptr; // don't loop on recursive type
768 }
769 } else {
770 inProgress = &basis;
771 }
772 auto iterator{inProgress->insert(&derived).first};
773 const Symbol *result{nullptr};
774 for (const Symbol &component : PotentialComponentIterator{derived}) {
775 result = IsFinalizable(component, inProgress, withImpureFinalizer);
776 if (result) {
777 break;
778 }
779 }
780 inProgress->erase(iterator);
781 return result;
782}
783
784static const Symbol *HasImpureFinal(
785 const DerivedTypeSpec &derived, std::optional<int> rank) {
786 return IsFinalizable(derived, nullptr, /*withImpureFinalizer=*/true, rank);
787}
788
789const Symbol *HasImpureFinal(const Symbol &original, std::optional<int> rank) {
790 const Symbol &symbol{ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
791 if (symbol.has<ObjectEntityDetails>()) {
792 if (const DeclTypeSpec * symType{symbol.GetType()}) {
793 if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
794 if (evaluate::IsAssumedRank(symbol)) {
795 // finalizable assumed-rank not allowed (C839)
796 return nullptr;
797 } else {
798 int actualRank{rank.value_or(symbol.Rank())};
799 return HasImpureFinal(*derived, actualRank);
800 }
801 }
802 }
803 }
804 return nullptr;
805}
806
807bool MayRequireFinalization(const DerivedTypeSpec &derived) {
808 return IsFinalizable(derived) ||
809 FindPolymorphicAllocatablePotentialComponent(derived);
810}
811
812bool HasAllocatableDirectComponent(const DerivedTypeSpec &derived) {
813 DirectComponentIterator directs{derived};
814 return std::any_of(directs.begin(), directs.end(), IsAllocatable);
815}
816
817bool IsAssumedLengthCharacter(const Symbol &symbol) {
818 if (const DeclTypeSpec * type{symbol.GetType()}) {
819 return type->category() == DeclTypeSpec::Character &&
820 type->characterTypeSpec().length().isAssumed();
821 } else {
822 return false;
823 }
824}
825
826bool IsInBlankCommon(const Symbol &symbol) {
827 const Symbol *block{FindCommonBlockContaining(symbol)};
828 return block && block->name().empty();
829}
830
831// C722 and C723: For a function to be assumed length, it must be external and
832// of CHARACTER type
833bool IsExternal(const Symbol &symbol) {
834 return ClassifyProcedure(symbol) == ProcedureDefinitionClass::External;
835}
836
837// Most scopes have no EQUIVALENCE, and this function is a fast no-op for them.
838std::list<std::list<SymbolRef>> GetStorageAssociations(const Scope &scope) {
839 UnorderedSymbolSet distinct;
840 for (const EquivalenceSet &set : scope.equivalenceSets()) {
841 for (const EquivalenceObject &object : set) {
842 distinct.emplace(object.symbol);
843 }
844 }
845 // This set is ordered by ascending offsets, with ties broken by greatest
846 // size. A multiset is used here because multiple symbols may have the
847 // same offset and size; the symbols in the set, however, are distinct.
848 std::multiset<SymbolRef, SymbolOffsetCompare> associated;
849 for (SymbolRef ref : distinct) {
850 associated.emplace(*ref);
851 }
852 std::list<std::list<SymbolRef>> result;
853 std::size_t limit{0};
854 const Symbol *currentCommon{nullptr};
855 for (const Symbol &symbol : associated) {
856 const Symbol *thisCommon{FindCommonBlockContaining(symbol)};
857 if (result.empty() || symbol.offset() >= limit ||
858 thisCommon != currentCommon) {
859 // Start a new group
860 result.emplace_back(std::list<SymbolRef>{});
861 limit = 0;
862 currentCommon = thisCommon;
863 }
864 result.back().emplace_back(symbol);
865 limit = std::max(limit, symbol.offset() + symbol.size());
866 }
867 return result;
868}
869
870bool IsModuleProcedure(const Symbol &symbol) {
871 return ClassifyProcedure(symbol) == ProcedureDefinitionClass::Module;
872}
873
874class ImageControlStmtHelper {
875 using ImageControlStmts =
876 std::variant<parser::ChangeTeamConstruct, parser::CriticalConstruct,
877 parser::EventPostStmt, parser::EventWaitStmt, parser::FormTeamStmt,
878 parser::LockStmt, parser::SyncAllStmt, parser::SyncImagesStmt,
879 parser::SyncMemoryStmt, parser::SyncTeamStmt, parser::UnlockStmt>;
880
881public:
882 template <typename T> bool operator()(const T &) {
883 return common::HasMember<T, ImageControlStmts>;
884 }
885 template <typename T> bool operator()(const common::Indirection<T> &x) {
886 return (*this)(x.value());
887 }
888 template <typename A> bool operator()(const parser::Statement<A> &x) {
889 return (*this)(x.statement);
890 }
891 bool operator()(const parser::AllocateStmt &stmt) {
892 const auto &allocationList{std::get<std::list<parser::Allocation>>(stmt.t)};
893 for (const auto &allocation : allocationList) {
894 const auto &allocateObject{
895 std::get<parser::AllocateObject>(allocation.t)};
896 if (IsCoarrayObject(allocateObject)) {
897 return true;
898 }
899 }
900 return false;
901 }
902 bool operator()(const parser::DeallocateStmt &stmt) {
903 const auto &allocateObjectList{
904 std::get<std::list<parser::AllocateObject>>(stmt.t)};
905 for (const auto &allocateObject : allocateObjectList) {
906 if (IsCoarrayObject(allocateObject)) {
907 return true;
908 }
909 }
910 return false;
911 }
912 bool operator()(const parser::CallStmt &stmt) {
913 const auto &procedureDesignator{
914 std::get<parser::ProcedureDesignator>(stmt.call.t)};
915 if (auto *name{std::get_if<parser::Name>(&procedureDesignator.u)}) {
916 // TODO: also ensure that the procedure is, in fact, an intrinsic
917 if (name->source == "move_alloc") {
918 const auto &args{
919 std::get<std::list<parser::ActualArgSpec>>(stmt.call.t)};
920 if (!args.empty()) {
921 const parser::ActualArg &actualArg{
922 std::get<parser::ActualArg>(args.front().t)};
923 if (const auto *argExpr{
924 std::get_if<common::Indirection<parser::Expr>>(
925 &actualArg.u)}) {
926 return HasCoarray(argExpr->value());
927 }
928 }
929 }
930 }
931 return false;
932 }
933 bool operator()(const parser::StopStmt &stmt) {
934 // STOP is an image control statement; ERROR STOP is not
935 return std::get<parser::StopStmt::Kind>(stmt.t) ==
936 parser::StopStmt::Kind::Stop;
937 }
938 bool operator()(const parser::IfStmt &stmt) {
939 return (*this)(
940 std::get<parser::UnlabeledStatement<parser::ActionStmt>>(stmt.t)
941 .statement);
942 }
943 bool operator()(const parser::ActionStmt &stmt) {
944 return common::visit(*this, stmt.u);
945 }
946
947private:
948 bool IsCoarrayObject(const parser::AllocateObject &allocateObject) {
949 const parser::Name &name{GetLastName(allocateObject)};
950 return name.symbol && evaluate::IsCoarray(*name.symbol);
951 }
952};
953
954bool IsImageControlStmt(const parser::ExecutableConstruct &construct) {
955 return common::visit(ImageControlStmtHelper{}, construct.u);
956}
957
958std::optional<parser::MessageFixedText> GetImageControlStmtCoarrayMsg(
959 const parser::ExecutableConstruct &construct) {
960 if (const auto *actionStmt{
961 std::get_if<parser::Statement<parser::ActionStmt>>(&construct.u)}) {
962 return common::visit(
963 common::visitors{
964 [](const common::Indirection<parser::AllocateStmt> &)
965 -> std::optional<parser::MessageFixedText> {
966 return "ALLOCATE of a coarray is an image control"
967 " statement"_en_US;
968 },
969 [](const common::Indirection<parser::DeallocateStmt> &)
970 -> std::optional<parser::MessageFixedText> {
971 return "DEALLOCATE of a coarray is an image control"
972 " statement"_en_US;
973 },
974 [](const common::Indirection<parser::CallStmt> &)
975 -> std::optional<parser::MessageFixedText> {
976 return "MOVE_ALLOC of a coarray is an image control"
977 " statement "_en_US;
978 },
979 [](const auto &) -> std::optional<parser::MessageFixedText> {
980 return std::nullopt;
981 },
982 },
983 actionStmt->statement.u);
984 }
985 return std::nullopt;
986}
987
988parser::CharBlock GetImageControlStmtLocation(
989 const parser::ExecutableConstruct &executableConstruct) {
990 return common::visit(
991 common::visitors{
992 [](const common::Indirection<parser::ChangeTeamConstruct>
993 &construct) {
994 return std::get<parser::Statement<parser::ChangeTeamStmt>>(
995 construct.value().t)
996 .source;
997 },
998 [](const common::Indirection<parser::CriticalConstruct> &construct) {
999 return std::get<parser::Statement<parser::CriticalStmt>>(
1000 construct.value().t)
1001 .source;
1002 },
1003 [](const parser::Statement<parser::ActionStmt> &actionStmt) {
1004 return actionStmt.source;
1005 },
1006 [](const auto &) { return parser::CharBlock{}; },
1007 },
1008 executableConstruct.u);
1009}
1010
1011bool HasCoarray(const parser::Expr &expression) {
1012 if (const auto *expr{GetExpr(nullptr, expression)}) {
1013 for (const Symbol &symbol : evaluate::CollectSymbols(*expr)) {
1014 if (evaluate::IsCoarray(symbol)) {
1015 return true;
1016 }
1017 }
1018 }
1019 return false;
1020}
1021
1022bool IsAssumedType(const Symbol &symbol) {
1023 if (const DeclTypeSpec * type{symbol.GetType()}) {
1024 return type->IsAssumedType();
1025 }
1026 return false;
1027}
1028
1029bool IsPolymorphic(const Symbol &symbol) {
1030 if (const DeclTypeSpec * type{symbol.GetType()}) {
1031 return type->IsPolymorphic();
1032 }
1033 return false;
1034}
1035
1036bool IsUnlimitedPolymorphic(const Symbol &symbol) {
1037 if (const DeclTypeSpec * type{symbol.GetType()}) {
1038 return type->IsUnlimitedPolymorphic();
1039 }
1040 return false;
1041}
1042
1043bool IsPolymorphicAllocatable(const Symbol &symbol) {
1044 return IsAllocatable(symbol) && IsPolymorphic(symbol);
1045}
1046
1047const Scope *FindCUDADeviceContext(const Scope *scope) {
1048 return !scope ? nullptr : FindScopeContaining(*scope, [](const Scope &s) {
1049 return IsCUDADeviceContext(&s);
1050 });
1051}
1052
1053std::optional<common::CUDADataAttr> GetCUDADataAttr(const Symbol *symbol) {
1054 const auto *object{
1055 symbol ? symbol->detailsIf<ObjectEntityDetails>() : nullptr};
1056 return object ? object->cudaDataAttr() : std::nullopt;
1057}
1058
1059bool IsAccessible(const Symbol &original, const Scope &scope) {
1060 const Symbol &ultimate{original.GetUltimate()};
1061 if (ultimate.attrs().test(Attr::PRIVATE)) {
1062 const Scope *module{FindModuleContaining(ultimate.owner())};
1063 return !module || module->Contains(scope);
1064 } else {
1065 return true;
1066 }
1067}
1068
1069std::optional<parser::MessageFormattedText> CheckAccessibleSymbol(
1070 const Scope &scope, const Symbol &symbol) {
1071 if (IsAccessible(symbol, scope)) {
1072 return std::nullopt;
1073 } else if (FindModuleFileContaining(scope)) {
1074 // Don't enforce component accessibility checks in module files;
1075 // there may be forward-substituted named constants of derived type
1076 // whose structure constructors reference private components.
1077 return std::nullopt;
1078 } else {
1079 return parser::MessageFormattedText{
1080 "PRIVATE name '%s' is accessible only within module '%s'"_err_en_US,
1081 symbol.name(),
1082 DEREF(FindModuleContaining(symbol.owner())).GetName().value()};
1083 }
1084}
1085
1086SymbolVector OrderParameterNames(const Symbol &typeSymbol) {
1087 SymbolVector result;
1088 if (const DerivedTypeSpec * spec{typeSymbol.GetParentTypeSpec()}) {
1089 result = OrderParameterNames(spec->typeSymbol());
1090 }
1091 const auto &paramNames{typeSymbol.get<DerivedTypeDetails>().paramNameOrder()};
1092 result.insert(result.end(), paramNames.begin(), paramNames.end());
1093 return result;
1094}
1095
1096SymbolVector OrderParameterDeclarations(const Symbol &typeSymbol) {
1097 SymbolVector result;
1098 if (const DerivedTypeSpec * spec{typeSymbol.GetParentTypeSpec()}) {
1099 result = OrderParameterDeclarations(spec->typeSymbol());
1100 }
1101 const auto &paramDecls{typeSymbol.get<DerivedTypeDetails>().paramDeclOrder()};
1102 result.insert(result.end(), paramDecls.begin(), paramDecls.end());
1103 return result;
1104}
1105
1106const DeclTypeSpec &FindOrInstantiateDerivedType(
1107 Scope &scope, DerivedTypeSpec &&spec, DeclTypeSpec::Category category) {
1108 spec.EvaluateParameters(scope.context());
1109 if (const DeclTypeSpec *
1110 type{scope.FindInstantiatedDerivedType(spec, category)}) {
1111 return *type;
1112 }
1113 // Create a new instantiation of this parameterized derived type
1114 // for this particular distinct set of actual parameter values.
1115 DeclTypeSpec &type{scope.MakeDerivedType(category, std::move(spec))};
1116 type.derivedTypeSpec().Instantiate(scope);
1117 return type;
1118}
1119
1120const Symbol *FindSeparateModuleSubprogramInterface(const Symbol *proc) {
1121 if (proc) {
1122 if (const auto *subprogram{proc->detailsIf<SubprogramDetails>()}) {
1123 if (const Symbol * iface{subprogram->moduleInterface()}) {
1124 return iface;
1125 }
1126 }
1127 }
1128 return nullptr;
1129}
1130
1131ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2
1132 const Symbol &ultimate{symbol.GetUltimate()};
1133 if (!IsProcedure(ultimate)) {
1134 return ProcedureDefinitionClass::None;
1135 } else if (ultimate.attrs().test(Attr::INTRINSIC)) {
1136 return ProcedureDefinitionClass::Intrinsic;
1137 } else if (IsDummy(ultimate)) {
1138 return ProcedureDefinitionClass::Dummy;
1139 } else if (IsProcedurePointer(symbol)) {
1140 return ProcedureDefinitionClass::Pointer;
1141 } else if (ultimate.attrs().test(Attr::EXTERNAL)) {
1142 return ProcedureDefinitionClass::External;
1143 } else if (const auto *nameDetails{
1144 ultimate.detailsIf<SubprogramNameDetails>()}) {
1145 switch (nameDetails->kind()) {
1146 case SubprogramKind::Module:
1147 return ProcedureDefinitionClass::Module;
1148 case SubprogramKind::Internal:
1149 return ProcedureDefinitionClass::Internal;
1150 }
1151 } else if (const Symbol * subp{FindSubprogram(symbol)}) {
1152 if (const auto *subpDetails{subp->detailsIf<SubprogramDetails>()}) {
1153 if (subpDetails->stmtFunction()) {
1154 return ProcedureDefinitionClass::StatementFunction;
1155 }
1156 }
1157 switch (ultimate.owner().kind()) {
1158 case Scope::Kind::Global:
1159 case Scope::Kind::IntrinsicModules:
1160 return ProcedureDefinitionClass::External;
1161 case Scope::Kind::Module:
1162 return ProcedureDefinitionClass::Module;
1163 case Scope::Kind::MainProgram:
1164 case Scope::Kind::Subprogram:
1165 return ProcedureDefinitionClass::Internal;
1166 default:
1167 break;
1168 }
1169 }
1170 return ProcedureDefinitionClass::None;
1171}
1172
1173// ComponentIterator implementation
1174
1175template <ComponentKind componentKind>
1176typename ComponentIterator<componentKind>::const_iterator
1177ComponentIterator<componentKind>::const_iterator::Create(
1178 const DerivedTypeSpec &derived) {
1179 const_iterator it{};
1180 it.componentPath_.emplace_back(derived);
1181 it.Increment(); // cue up first relevant component, if any
1182 return it;
1183}
1184
1185template <ComponentKind componentKind>
1186const DerivedTypeSpec *
1187ComponentIterator<componentKind>::const_iterator::PlanComponentTraversal(
1188 const Symbol &component) const {
1189 if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
1190 if (const DeclTypeSpec * type{details->type()}) {
1191 if (const auto *derived{type->AsDerived()}) {
1192 bool traverse{false};
1193 if constexpr (componentKind == ComponentKind::Ordered) {
1194 // Order Component (only visit parents)
1195 traverse = component.test(Symbol::Flag::ParentComp);
1196 } else if constexpr (componentKind == ComponentKind::Direct) {
1197 traverse = !IsAllocatableOrObjectPointer(&component);
1198 } else if constexpr (componentKind == ComponentKind::Ultimate) {
1199 traverse = !IsAllocatableOrObjectPointer(&component);
1200 } else if constexpr (componentKind == ComponentKind::Potential) {
1201 traverse = !IsPointer(component);
1202 } else if constexpr (componentKind == ComponentKind::Scope) {
1203 traverse = !IsAllocatableOrObjectPointer(&component);
1204 } else if constexpr (componentKind ==
1205 ComponentKind::PotentialAndPointer) {
1206 traverse = !IsPointer(component);
1207 }
1208 if (traverse) {
1209 const Symbol &newTypeSymbol{derived->typeSymbol()};
1210 // Avoid infinite loop if the type is already part of the types
1211 // being visited. It is possible to have "loops in type" because
1212 // C744 does not forbid to use not yet declared type for
1213 // ALLOCATABLE or POINTER components.
1214 for (const auto &node : componentPath_) {
1215 if (&newTypeSymbol == &node.GetTypeSymbol()) {
1216 return nullptr;
1217 }
1218 }
1219 return derived;
1220 }
1221 }
1222 } // intrinsic & unlimited polymorphic not traversable
1223 }
1224 return nullptr;
1225}
1226
1227template <ComponentKind componentKind>
1228static bool StopAtComponentPre(const Symbol &component) {
1229 if constexpr (componentKind == ComponentKind::Ordered) {
1230 // Parent components need to be iterated upon after their
1231 // sub-components in structure constructor analysis.
1232 return !component.test(Symbol::Flag::ParentComp);
1233 } else if constexpr (componentKind == ComponentKind::Direct) {
1234 return true;
1235 } else if constexpr (componentKind == ComponentKind::Ultimate) {
1236 return component.has<ProcEntityDetails>() ||
1237 IsAllocatableOrObjectPointer(&component) ||
1238 (component.has<ObjectEntityDetails>() &&
1239 component.get<ObjectEntityDetails>().type() &&
1240 component.get<ObjectEntityDetails>().type()->AsIntrinsic());
1241 } else if constexpr (componentKind == ComponentKind::Potential) {
1242 return !IsPointer(component);
1243 } else if constexpr (componentKind == ComponentKind::PotentialAndPointer) {
1244 return true;
1245 } else {
1246 DIE("unexpected ComponentKind");
1247 }
1248}
1249
1250template <ComponentKind componentKind>
1251static bool StopAtComponentPost(const Symbol &component) {
1252 return componentKind == ComponentKind::Ordered &&
1253 component.test(Symbol::Flag::ParentComp);
1254}
1255
1256template <ComponentKind componentKind>
1257void ComponentIterator<componentKind>::const_iterator::Increment() {
1258 while (!componentPath_.empty()) {
1259 ComponentPathNode &deepest{componentPath_.back()};
1260 if (deepest.component()) {
1261 if (!deepest.descended()) {
1262 deepest.set_descended(true);
1263 if (const DerivedTypeSpec *
1264 derived{PlanComponentTraversal(*deepest.component())}) {
1265 componentPath_.emplace_back(*derived);
1266 continue;
1267 }
1268 } else if (!deepest.visited()) {
1269 deepest.set_visited(true);
1270 return; // this is the next component to visit, after descending
1271 }
1272 }
1273 auto &nameIterator{deepest.nameIterator()};
1274 if (nameIterator == deepest.nameEnd()) {
1275 componentPath_.pop_back();
1276 } else if constexpr (componentKind == ComponentKind::Scope) {
1277 deepest.set_component(*nameIterator++->second);
1278 deepest.set_descended(false);
1279 deepest.set_visited(true);
1280 return; // this is the next component to visit, before descending
1281 } else {
1282 const Scope &scope{deepest.GetScope()};
1283 auto scopeIter{scope.find(*nameIterator++)};
1284 if (scopeIter != scope.cend()) {
1285 const Symbol &component{*scopeIter->second};
1286 deepest.set_component(component);
1287 deepest.set_descended(false);
1288 if (StopAtComponentPre<componentKind>(component)) {
1289 deepest.set_visited(true);
1290 return; // this is the next component to visit, before descending
1291 } else {
1292 deepest.set_visited(!StopAtComponentPost<componentKind>(component));
1293 }
1294 }
1295 }
1296 }
1297}
1298
1299template <ComponentKind componentKind>
1300SymbolVector
1301ComponentIterator<componentKind>::const_iterator::GetComponentPath() const {
1302 SymbolVector result;
1303 for (const auto &node : componentPath_) {
1304 result.push_back(DEREF(node.component()));
1305 }
1306 return result;
1307}
1308
1309template <ComponentKind componentKind>
1310std::string
1311ComponentIterator<componentKind>::const_iterator::BuildResultDesignatorName()
1312 const {
1313 std::string designator;
1314 for (const Symbol &component : GetComponentPath()) {
1315 designator += "%"s + component.name().ToString();
1316 }
1317 return designator;
1318}
1319
1320template class ComponentIterator<ComponentKind::Ordered>;
1321template class ComponentIterator<ComponentKind::Direct>;
1322template class ComponentIterator<ComponentKind::Ultimate>;
1323template class ComponentIterator<ComponentKind::Potential>;
1324template class ComponentIterator<ComponentKind::Scope>;
1325template class ComponentIterator<ComponentKind::PotentialAndPointer>;
1326
1327PotentialComponentIterator::const_iterator FindCoarrayPotentialComponent(
1328 const DerivedTypeSpec &derived) {
1329 PotentialComponentIterator potentials{derived};
1330 return std::find_if(potentials.begin(), potentials.end(),
1331 [](const Symbol &symbol) { return evaluate::IsCoarray(symbol); });
1332}
1333
1334PotentialAndPointerComponentIterator::const_iterator
1335FindPointerPotentialComponent(const DerivedTypeSpec &derived) {
1336 PotentialAndPointerComponentIterator potentials{derived};
1337 return std::find_if(potentials.begin(), potentials.end(), IsPointer);
1338}
1339
1340UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
1341 const DerivedTypeSpec &derived) {
1342 UltimateComponentIterator ultimates{derived};
1343 return std::find_if(ultimates.begin(), ultimates.end(),
1344 [](const Symbol &symbol) { return evaluate::IsCoarray(symbol); });
1345}
1346
1347UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
1348 const DerivedTypeSpec &derived) {
1349 UltimateComponentIterator ultimates{derived};
1350 return std::find_if(ultimates.begin(), ultimates.end(), IsPointer);
1351}
1352
1353PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
1354 const DerivedTypeSpec &derived, bool ignoreCoarrays) {
1355 PotentialComponentIterator potentials{derived};
1356 auto iter{potentials.begin()};
1357 for (auto end{potentials.end()}; iter != end; ++iter) {
1358 const Symbol &component{*iter};
1359 if (const auto *object{component.detailsIf<ObjectEntityDetails>()}) {
1360 if (const DeclTypeSpec * type{object->type()}) {
1361 if (IsEventTypeOrLockType(type->AsDerived())) {
1362 if (!ignoreCoarrays) {
1363 break; // found one
1364 }
1365 auto path{iter.GetComponentPath()};
1366 path.pop_back();
1367 if (std::find_if(path.begin(), path.end(), [](const Symbol &sym) {
1368 return evaluate::IsCoarray(sym);
1369 }) == path.end()) {
1370 break; // found one not in a coarray
1371 }
1372 }
1373 }
1374 }
1375 }
1376 return iter;
1377}
1378
1379UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
1380 const DerivedTypeSpec &derived) {
1381 UltimateComponentIterator ultimates{derived};
1382 return std::find_if(ultimates.begin(), ultimates.end(), IsAllocatable);
1383}
1384
1385DirectComponentIterator::const_iterator FindAllocatableOrPointerDirectComponent(
1386 const DerivedTypeSpec &derived) {
1387 DirectComponentIterator directs{derived};
1388 return std::find_if(directs.begin(), directs.end(), IsAllocatableOrPointer);
1389}
1390
1391PotentialComponentIterator::const_iterator
1392FindPolymorphicAllocatablePotentialComponent(const DerivedTypeSpec &derived) {
1393 PotentialComponentIterator potentials{derived};
1394 return std::find_if(
1395 potentials.begin(), potentials.end(), IsPolymorphicAllocatable);
1396}
1397
1398const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived,
1399 const std::function<bool(const Symbol &)> &predicate) {
1400 UltimateComponentIterator ultimates{derived};
1401 if (auto it{std::find_if(ultimates.begin(), ultimates.end(),
1402 [&predicate](const Symbol &component) -> bool {
1403 return predicate(component);
1404 })}) {
1405 return &*it;
1406 }
1407 return nullptr;
1408}
1409
1410const Symbol *FindUltimateComponent(const Symbol &symbol,
1411 const std::function<bool(const Symbol &)> &predicate) {
1412 if (predicate(symbol)) {
1413 return &symbol;
1414 } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1415 if (const auto *type{object->type()}) {
1416 if (const auto *derived{type->AsDerived()}) {
1417 return FindUltimateComponent(*derived, predicate);
1418 }
1419 }
1420 }
1421 return nullptr;
1422}
1423
1424const Symbol *FindImmediateComponent(const DerivedTypeSpec &type,
1425 const std::function<bool(const Symbol &)> &predicate) {
1426 if (const Scope * scope{type.scope()}) {
1427 const Symbol *parent{nullptr};
1428 for (const auto &pair : *scope) {
1429 const Symbol *symbol{&*pair.second};
1430 if (predicate(*symbol)) {
1431 return symbol;
1432 }
1433 if (symbol->test(Symbol::Flag::ParentComp)) {
1434 parent = symbol;
1435 }
1436 }
1437 if (parent) {
1438 if (const auto *object{parent->detailsIf<ObjectEntityDetails>()}) {
1439 if (const auto *type{object->type()}) {
1440 if (const auto *derived{type->AsDerived()}) {
1441 return FindImmediateComponent(*derived, predicate);
1442 }
1443 }
1444 }
1445 }
1446 }
1447 return nullptr;
1448}
1449
1450const Symbol *IsFunctionResultWithSameNameAsFunction(const Symbol &symbol) {
1451 if (IsFunctionResult(symbol)) {
1452 if (const Symbol * function{symbol.owner().symbol()}) {
1453 if (symbol.name() == function->name()) {
1454 return function;
1455 }
1456 }
1457 // Check ENTRY result symbols too
1458 const Scope &outer{symbol.owner().parent()};
1459 auto iter{outer.find(symbol.name())};
1460 if (iter != outer.end()) {
1461 const Symbol &outerSym{*iter->second};
1462 if (const auto *subp{outerSym.detailsIf<SubprogramDetails>()}) {
1463 if (subp->entryScope() == &symbol.owner() &&
1464 symbol.name() == outerSym.name()) {
1465 return &outerSym;
1466 }
1467 }
1468 }
1469 }
1470 return nullptr;
1471}
1472
1473void LabelEnforce::Post(const parser::GotoStmt &gotoStmt) {
1474 CheckLabelUse(gotoStmt.v);
1475}
1476void LabelEnforce::Post(const parser::ComputedGotoStmt &computedGotoStmt) {
1477 for (auto &i : std::get<std::list<parser::Label>>(computedGotoStmt.t)) {
1478 CheckLabelUse(i);
1479 }
1480}
1481
1482void LabelEnforce::Post(const parser::ArithmeticIfStmt &arithmeticIfStmt) {
1483 CheckLabelUse(std::get<1>(arithmeticIfStmt.t));
1484 CheckLabelUse(std::get<2>(arithmeticIfStmt.t));
1485 CheckLabelUse(std::get<3>(arithmeticIfStmt.t));
1486}
1487
1488void LabelEnforce::Post(const parser::AssignStmt &assignStmt) {
1489 CheckLabelUse(std::get<parser::Label>(assignStmt.t));
1490}
1491
1492void LabelEnforce::Post(const parser::AssignedGotoStmt &assignedGotoStmt) {
1493 for (auto &i : std::get<std::list<parser::Label>>(assignedGotoStmt.t)) {
1494 CheckLabelUse(i);
1495 }
1496}
1497
1498void LabelEnforce::Post(const parser::AltReturnSpec &altReturnSpec) {
1499 CheckLabelUse(altReturnSpec.v);
1500}
1501
1502void LabelEnforce::Post(const parser::ErrLabel &errLabel) {
1503 CheckLabelUse(errLabel.v);
1504}
1505void LabelEnforce::Post(const parser::EndLabel &endLabel) {
1506 CheckLabelUse(endLabel.v);
1507}
1508void LabelEnforce::Post(const parser::EorLabel &eorLabel) {
1509 CheckLabelUse(eorLabel.v);
1510}
1511
1512void LabelEnforce::CheckLabelUse(const parser::Label &labelUsed) {
1513 if (labels_.find(labelUsed) == labels_.end()) {
1514 SayWithConstruct(context_, currentStatementSourcePosition_,
1515 parser::MessageFormattedText{
1516 "Control flow escapes from %s"_err_en_US, construct_},
1517 constructSourcePosition_);
1518 }
1519}
1520
1521parser::MessageFormattedText LabelEnforce::GetEnclosingConstructMsg() {
1522 return {"Enclosing %s statement"_en_US, construct_};
1523}
1524
1525void LabelEnforce::SayWithConstruct(SemanticsContext &context,
1526 parser::CharBlock stmtLocation, parser::MessageFormattedText &&message,
1527 parser::CharBlock constructLocation) {
1528 context.Say(stmtLocation, message)
1529 .Attach(constructLocation, GetEnclosingConstructMsg());
1530}
1531
1532bool HasAlternateReturns(const Symbol &subprogram) {
1533 for (const auto *dummyArg : subprogram.get<SubprogramDetails>().dummyArgs()) {
1534 if (!dummyArg) {
1535 return true;
1536 }
1537 }
1538 return false;
1539}
1540
1541bool IsAutomaticallyDestroyed(const Symbol &symbol) {
1542 return symbol.has<ObjectEntityDetails>() &&
1543 (symbol.owner().kind() == Scope::Kind::Subprogram ||
1544 symbol.owner().kind() == Scope::Kind::BlockConstruct) &&
1545 !IsNamedConstant(symbol) && (!IsDummy(symbol) || IsIntentOut(symbol)) &&
1546 !IsPointer(symbol) && !IsSaved(symbol) &&
1547 !FindCommonBlockContaining(symbol);
1548}
1549
1550const std::optional<parser::Name> &MaybeGetNodeName(
1551 const ConstructNode &construct) {
1552 return common::visit(
1553 common::visitors{
1554 [&](const parser::BlockConstruct *blockConstruct)
1555 -> const std::optional<parser::Name> & {
1556 return std::get<0>(blockConstruct->t).statement.v;
1557 },
1558 [&](const auto *a) -> const std::optional<parser::Name> & {
1559 return std::get<0>(std::get<0>(a->t).statement.t);
1560 },
1561 },
1562 construct);
1563}
1564
1565std::optional<ArraySpec> ToArraySpec(
1566 evaluate::FoldingContext &context, const evaluate::Shape &shape) {
1567 if (auto extents{evaluate::AsConstantExtents(context, shape)};
1568 extents && !evaluate::HasNegativeExtent(*extents)) {
1569 ArraySpec result;
1570 for (const auto &extent : *extents) {
1571 result.emplace_back(ShapeSpec::MakeExplicit(Bound{extent}));
1572 }
1573 return {std::move(result)};
1574 } else {
1575 return std::nullopt;
1576 }
1577}
1578
1579std::optional<ArraySpec> ToArraySpec(evaluate::FoldingContext &context,
1580 const std::optional<evaluate::Shape> &shape) {
1581 return shape ? ToArraySpec(context, *shape) : std::nullopt;
1582}
1583
1584static const DeclTypeSpec *GetDtvArgTypeSpec(const Symbol &proc) {
1585 if (const auto *subp{proc.detailsIf<SubprogramDetails>()};
1586 subp && !subp->dummyArgs().empty()) {
1587 if (const auto *arg{subp->dummyArgs()[0]}) {
1588 return arg->GetType();
1589 }
1590 }
1591 return nullptr;
1592}
1593
1594const DerivedTypeSpec *GetDtvArgDerivedType(const Symbol &proc) {
1595 if (const auto *type{GetDtvArgTypeSpec(proc)}) {
1596 return type->AsDerived();
1597 } else {
1598 return nullptr;
1599 }
1600}
1601
1602bool HasDefinedIo(common::DefinedIo which, const DerivedTypeSpec &derived,
1603 const Scope *scope) {
1604 if (const Scope * dtScope{derived.scope()}) {
1605 for (const auto &pair : *dtScope) {
1606 const Symbol &symbol{*pair.second};
1607 if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
1608 GenericKind kind{generic->kind()};
1609 if (const auto *io{std::get_if<common::DefinedIo>(&kind.u)}) {
1610 if (*io == which) {
1611 return true; // type-bound GENERIC exists
1612 }
1613 }
1614 }
1615 }
1616 }
1617 if (scope) {
1618 SourceName name{GenericKind::AsFortran(which)};
1619 evaluate::DynamicType dyDerived{derived};
1620 for (; scope && !scope->IsGlobal(); scope = &scope->parent()) {
1621 auto iter{scope->find(name)};
1622 if (iter != scope->end()) {
1623 const auto &generic{iter->second->GetUltimate().get<GenericDetails>()};
1624 for (auto ref : generic.specificProcs()) {
1625 const Symbol &procSym{ref->GetUltimate()};
1626 if (const DeclTypeSpec * dtSpec{GetDtvArgTypeSpec(procSym)}) {
1627 if (auto dyDummy{evaluate::DynamicType::From(*dtSpec)}) {
1628 if (dyDummy->IsTkCompatibleWith(dyDerived)) {
1629 return true; // GENERIC or INTERFACE not in type
1630 }
1631 }
1632 }
1633 }
1634 }
1635 }
1636 }
1637 // Check for inherited defined I/O
1638 const auto *parentType{derived.typeSymbol().GetParentTypeSpec()};
1639 return parentType && HasDefinedIo(which, *parentType, scope);
1640}
1641
1642template <typename E>
1643std::forward_list<std::string> GetOperatorNames(
1644 const SemanticsContext &context, E opr) {
1645 std::forward_list<std::string> result;
1646 for (const char *name : context.languageFeatures().GetNames(opr)) {
1647 result.emplace_front("operator("s + name + ')');
1648 }
1649 return result;
1650}
1651
1652std::forward_list<std::string> GetAllNames(
1653 const SemanticsContext &context, const SourceName &name) {
1654 std::string str{name.ToString()};
1655 if (!name.empty() && name.end()[-1] == ')' &&
1656 name.ToString().rfind("operator(", 0) == 0) {
1657 for (int i{0}; i != common::LogicalOperator_enumSize; ++i) {
1658 auto names{GetOperatorNames(context, common::LogicalOperator{i})};
1659 if (llvm::is_contained(names, str)) {
1660 return names;
1661 }
1662 }
1663 for (int i{0}; i != common::RelationalOperator_enumSize; ++i) {
1664 auto names{GetOperatorNames(context, common::RelationalOperator{i})};
1665 if (llvm::is_contained(names, str)) {
1666 return names;
1667 }
1668 }
1669 }
1670 return {str};
1671}
1672
1673void WarnOnDeferredLengthCharacterScalar(SemanticsContext &context,
1674 const SomeExpr *expr, parser::CharBlock at, const char *what) {
1675 if (context.languageFeatures().ShouldWarn(
1676 common::UsageWarning::F202XAllocatableBreakingChange)) {
1677 if (const Symbol *
1678 symbol{evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)}) {
1679 const Symbol &ultimate{ResolveAssociations(*symbol)};
1680 if (const DeclTypeSpec * type{ultimate.GetType()}; type &&
1681 type->category() == DeclTypeSpec::Category::Character &&
1682 type->characterTypeSpec().length().isDeferred() &&
1683 IsAllocatable(ultimate) && ultimate.Rank() == 0) {
1684 context.Say(at,
1685 "The deferred length allocatable character scalar variable '%s' may be reallocated to a different length under the new Fortran 202X standard semantics for %s"_port_en_US,
1686 symbol->name(), what);
1687 }
1688 }
1689 }
1690}
1691
1692bool CouldBeDataPointerValuedFunction(const Symbol *original) {
1693 if (original) {
1694 const Symbol &ultimate{original->GetUltimate()};
1695 if (const Symbol * result{FindFunctionResult(ultimate)}) {
1696 return IsPointer(*result) && !IsProcedure(*result);
1697 }
1698 if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
1699 for (const SymbolRef &ref : generic->specificProcs()) {
1700 if (CouldBeDataPointerValuedFunction(&*ref)) {
1701 return true;
1702 }
1703 }
1704 }
1705 }
1706 return false;
1707}
1708
1709std::string GetModuleOrSubmoduleName(const Symbol &symbol) {
1710 const auto &details{symbol.get<ModuleDetails>()};
1711 std::string result{symbol.name().ToString()};
1712 if (details.ancestor() && details.ancestor()->symbol()) {
1713 result = details.ancestor()->symbol()->name().ToString() + ':' + result;
1714 }
1715 return result;
1716}
1717
1718std::string GetCommonBlockObjectName(const Symbol &common, bool underscoring) {
1719 if (const std::string * bind{common.GetBindName()}) {
1720 return *bind;
1721 }
1722 if (common.name().empty()) {
1723 return Fortran::common::blankCommonObjectName;
1724 }
1725 return underscoring ? common.name().ToString() + "_"s
1726 : common.name().ToString();
1727}
1728
1729bool HadUseError(
1730 SemanticsContext &context, SourceName at, const Symbol *symbol) {
1731 if (const auto *details{
1732 symbol ? symbol->detailsIf<UseErrorDetails>() : nullptr}) {
1733 auto &msg{context.Say(
1734 at, "Reference to '%s' is ambiguous"_err_en_US, symbol->name())};
1735 for (const auto &[location, sym] : details->occurrences()) {
1736 const Symbol &ultimate{sym->GetUltimate()};
1737 if (sym->owner().IsModule()) {
1738 auto &attachment{msg.Attach(location,
1739 "'%s' was use-associated from module '%s'"_en_US, at,
1740 sym->owner().GetName().value())};
1741 if (&*sym != &ultimate) {
1742 // For incompatible definitions where one comes from a hermetic
1743 // module file's incorporated dependences and the other from another
1744 // module of the same name.
1745 attachment.Attach(ultimate.name(),
1746 "ultimately from '%s' in module '%s'"_en_US, ultimate.name(),
1747 ultimate.owner().GetName().value());
1748 }
1749 } else {
1750 msg.Attach(sym->name(), "declared here"_en_US);
1751 }
1752 }
1753 context.SetError(*symbol);
1754 return true;
1755 } else {
1756 return false;
1757 }
1758}
1759
1760bool CheckForSymbolMatch(const SomeExpr *lhs, const SomeExpr *rhs) {
1761 if (lhs && rhs) {
1762 if (SymbolVector lhsSymbols{evaluate::GetSymbolVector(*lhs)};
1763 !lhsSymbols.empty()) {
1764 const Symbol &first{*lhsSymbols.front()};
1765 for (const Symbol &symbol : evaluate::GetSymbolVector(*rhs)) {
1766 if (first == symbol) {
1767 return true;
1768 }
1769 }
1770 }
1771 }
1772 return false;
1773}
1774
1775namespace operation {
1776template <typename T> //
1777SomeExpr asSomeExpr(const T &x) {
1778 auto copy{x};
1779 return AsGenericExpr(std::move(copy));
1780}
1781
1782template <bool IgnoreResizingConverts> //
1783struct ArgumentExtractor
1784 : public evaluate::Traverse<ArgumentExtractor<IgnoreResizingConverts>,
1785 std::pair<operation::Operator, std::vector<SomeExpr>>, false> {
1786 using Arguments = std::vector<SomeExpr>;
1787 using Result = std::pair<operation::Operator, Arguments>;
1788 using Base = evaluate::Traverse<ArgumentExtractor<IgnoreResizingConverts>,
1789 Result, false>;
1790 static constexpr auto IgnoreResizes = IgnoreResizingConverts;
1791 static constexpr auto Logical = common::TypeCategory::Logical;
1792 ArgumentExtractor() : Base(*this) {}
1793
1794 Result Default() const { return {}; }
1795
1796 using Base::operator();
1797
1798 template <int Kind> //
1799 Result operator()(
1800 const evaluate::Constant<evaluate::Type<Logical, Kind>> &x) const {
1801 if (const auto &val{x.GetScalarValue()}) {
1802 return val->IsTrue()
1803 ? std::make_pair(operation::Operator::True, Arguments{})
1804 : std::make_pair(operation::Operator::False, Arguments{});
1805 }
1806 return Default();
1807 }
1808
1809 template <typename R> //
1810 Result operator()(const evaluate::FunctionRef<R> &x) const {
1811 Result result{operation::OperationCode(x.proc()), {}};
1812 for (size_t i{0}, e{x.arguments().size()}; i != e; ++i) {
1813 if (auto *e{x.UnwrapArgExpr(i)}) {
1814 result.second.push_back(*e);
1815 }
1816 }
1817 return result;
1818 }
1819
1820 template <typename D, typename R, typename... Os>
1821 Result operator()(const evaluate::Operation<D, R, Os...> &x) const {
1822 if constexpr (std::is_same_v<D, evaluate::Parentheses<R>>) {
1823 // Ignore top-level parentheses.
1824 return (*this)(x.template operand<0>());
1825 }
1826 if constexpr (IgnoreResizes &&
1827 std::is_same_v<D, evaluate::Convert<R, R::category>>) {
1828 // Ignore conversions within the same category.
1829 // Atomic operations on int(kind=1) may be implicitly widened
1830 // to int(kind=4) for example.
1831 return (*this)(x.template operand<0>());
1832 } else {
1833 return std::make_pair(operation::OperationCode(x),
1834 OperationArgs(x, std::index_sequence_for<Os...>{}));
1835 }
1836 }
1837
1838 template <typename T> //
1839 Result operator()(const evaluate::Designator<T> &x) const {
1840 return {operation::Operator::Identity, {asSomeExpr(x)}};
1841 }
1842
1843 template <typename T> //
1844 Result operator()(const evaluate::Constant<T> &x) const {
1845 return {operation::Operator::Identity, {asSomeExpr(x)}};
1846 }
1847
1848 template <typename... Rs> //
1849 Result Combine(Result &&result, Rs &&...results) const {
1850 // There shouldn't be any combining needed, since we're stopping the
1851 // traversal at the top-level operation, but implement one that picks
1852 // the first non-empty result.
1853 if constexpr (sizeof...(Rs) == 0) {
1854 return std::move(result);
1855 } else {
1856 if (!result.second.empty()) {
1857 return std::move(result);
1858 } else {
1859 return Combine(std::move(results)...);
1860 }
1861 }
1862 }
1863
1864private:
1865 template <typename D, typename R, typename... Os, size_t... Is>
1866 Arguments OperationArgs(const evaluate::Operation<D, R, Os...> &x,
1867 std::index_sequence<Is...>) const {
1868 return Arguments{SomeExpr(x.template operand<Is>())...};
1869 }
1870};
1871} // namespace operation
1872
1873std::string operation::ToString(operation::Operator op) {
1874 switch (op) {
1875 case Operator::Unknown:
1876 return "??";
1877 case Operator::Add:
1878 return "+";
1879 case Operator::And:
1880 return "AND";
1881 case Operator::Associated:
1882 return "ASSOCIATED";
1883 case Operator::Call:
1884 return "function-call";
1885 case Operator::Constant:
1886 return "constant";
1887 case Operator::Convert:
1888 return "type-conversion";
1889 case Operator::Div:
1890 return "/";
1891 case Operator::Eq:
1892 return "==";
1893 case Operator::Eqv:
1894 return "EQV";
1895 case Operator::False:
1896 return ".FALSE.";
1897 case Operator::Ge:
1898 return ">=";
1899 case Operator::Gt:
1900 return ">";
1901 case Operator::Identity:
1902 return "identity";
1903 case Operator::Intrinsic:
1904 return "intrinsic";
1905 case Operator::Le:
1906 return "<=";
1907 case Operator::Lt:
1908 return "<";
1909 case Operator::Max:
1910 return "MAX";
1911 case Operator::Min:
1912 return "MIN";
1913 case Operator::Mul:
1914 return "*";
1915 case Operator::Ne:
1916 return "/=";
1917 case Operator::Neqv:
1918 return "NEQV/EOR";
1919 case Operator::Not:
1920 return "NOT";
1921 case Operator::Or:
1922 return "OR";
1923 case Operator::Pow:
1924 return "**";
1925 case Operator::Resize:
1926 return "resize";
1927 case Operator::Sub:
1928 return "-";
1929 case Operator::True:
1930 return ".TRUE.";
1931 }
1932 llvm_unreachable("Unhandler operator");
1933}
1934
1935operation::Operator operation::OperationCode(
1936 const evaluate::ProcedureDesignator &proc) {
1937 Operator code = llvm::StringSwitch<Operator>(proc.GetName())
1938 .Case("associated", Operator::Associated)
1939 .Case("min", Operator::Min)
1940 .Case("max", Operator::Max)
1941 .Case("iand", Operator::And)
1942 .Case("ior", Operator::Or)
1943 .Case("ieor", Operator::Neqv)
1944 .Default(Operator::Call);
1945 if (code == Operator::Call && proc.GetSpecificIntrinsic()) {
1946 return Operator::Intrinsic;
1947 }
1948 return code;
1949}
1950
1951std::pair<operation::Operator, std::vector<SomeExpr>> GetTopLevelOperation(
1952 const SomeExpr &expr) {
1953 return operation::ArgumentExtractor<true>{}(expr);
1954}
1955
1956namespace operation {
1957struct ConvertCollector
1958 : public evaluate::Traverse<ConvertCollector,
1959 std::pair<MaybeExpr, std::vector<evaluate::DynamicType>>, false> {
1960 using Result = std::pair<MaybeExpr, std::vector<evaluate::DynamicType>>;
1961 using Base = evaluate::Traverse<ConvertCollector, Result, false>;
1962 ConvertCollector() : Base(*this) {}
1963
1964 Result Default() const { return {}; }
1965
1966 using Base::operator();
1967
1968 template <typename T> //
1969 Result operator()(const evaluate::Designator<T> &x) const {
1970 return {asSomeExpr(x), {}};
1971 }
1972
1973 template <typename T> //
1974 Result operator()(const evaluate::FunctionRef<T> &x) const {
1975 return {asSomeExpr(x), {}};
1976 }
1977
1978 template <typename T> //
1979 Result operator()(const evaluate::Constant<T> &x) const {
1980 return {asSomeExpr(x), {}};
1981 }
1982
1983 template <typename D, typename R, typename... Os>
1984 Result operator()(const evaluate::Operation<D, R, Os...> &x) const {
1985 if constexpr (std::is_same_v<D, evaluate::Parentheses<R>>) {
1986 // Ignore parentheses.
1987 return (*this)(x.template operand<0>());
1988 } else if constexpr (is_convert_v<D>) {
1989 // Convert should always have a typed result, so it should be safe to
1990 // dereference x.GetType().
1991 return Combine(
1992 {std::nullopt, {*x.GetType()}}, (*this)(x.template operand<0>()));
1993 } else if constexpr (is_complex_constructor_v<D>) {
1994 // This is a conversion iff the imaginary operand is 0.
1995 if (IsZero(x.template operand<1>())) {
1996 return Combine(
1997 {std::nullopt, {*x.GetType()}}, (*this)(x.template operand<0>()));
1998 } else {
1999 return {asSomeExpr(x.derived()), {}};
2000 }
2001 } else {
2002 return {asSomeExpr(x.derived()), {}};
2003 }
2004 }
2005
2006 template <typename... Rs> //
2007 Result Combine(Result &&result, Rs &&...results) const {
2008 Result v(std::move(result));
2009 auto setValue{[](MaybeExpr &x, MaybeExpr &&y) {
2010 assert((!x.has_value() || !y.has_value()) && "Multiple designators");
2011 if (!x.has_value()) {
2012 x = std::move(y);
2013 }
2014 }};
2015 auto moveAppend{[](auto &accum, auto &&other) {
2016 for (auto &&s : other) {
2017 accum.push_back(std::move(s));
2018 }
2019 }};
2020 (setValue(v.first, std::move(results).first), ...);
2021 (moveAppend(v.second, std::move(results).second), ...);
2022 return v;
2023 }
2024
2025private:
2026 template <typename T> //
2027 static bool IsZero(const T &x) {
2028 return false;
2029 }
2030 template <typename T> //
2031 static bool IsZero(const evaluate::Expr<T> &x) {
2032 return common::visit([](auto &&s) { return IsZero(s); }, x.u);
2033 }
2034 template <typename T> //
2035 static bool IsZero(const evaluate::Constant<T> &x) {
2036 if (auto &&maybeScalar{x.GetScalarValue()}) {
2037 return maybeScalar->IsZero();
2038 } else {
2039 return false;
2040 }
2041 }
2042
2043 template <typename T> //
2044 struct is_convert {
2045 static constexpr bool value{false};
2046 };
2047 template <typename T, common::TypeCategory C> //
2048 struct is_convert<evaluate::Convert<T, C>> {
2049 static constexpr bool value{true};
2050 };
2051 template <int K> //
2052 struct is_convert<evaluate::ComplexComponent<K>> {
2053 // Conversion from complex to real.
2054 static constexpr bool value{true};
2055 };
2056 template <typename T> //
2057 static constexpr bool is_convert_v = is_convert<T>::value;
2058
2059 template <typename T> //
2060 struct is_complex_constructor {
2061 static constexpr bool value{false};
2062 };
2063 template <int K> //
2064 struct is_complex_constructor<evaluate::ComplexConstructor<K>> {
2065 static constexpr bool value{true};
2066 };
2067 template <typename T> //
2068 static constexpr bool is_complex_constructor_v =
2069 is_complex_constructor<T>::value;
2070};
2071} // namespace operation
2072
2073MaybeExpr GetConvertInput(const SomeExpr &x) {
2074 // This returns SomeExpr(x) when x is a designator/functionref/constant.
2075 return operation::ConvertCollector{}(x).first;
2076}
2077
2078bool IsSameOrConvertOf(const SomeExpr &expr, const SomeExpr &x) {
2079 // Check if expr is same as x, or a sequence of Convert operations on x.
2080 if (expr == x) {
2081 return true;
2082 } else if (auto maybe{GetConvertInput(expr)}) {
2083 return *maybe == x;
2084 } else {
2085 return false;
2086 }
2087}
2088} // namespace Fortran::semantics

source code of flang/lib/Semantics/tools.cpp