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

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