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 
25 namespace Fortran::semantics {
26 
27 // Find this or containing scope that matches predicate
28 static 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->IsGlobal()) {
35       return nullptr;
36     }
37   }
38 }
39 
40 const Scope &GetTopLevelUnitContaining(const Scope &start) {
41   CHECK(!start.IsGlobal());
42   return DEREF(FindScopeContaining(
43       start, [](const Scope &scope) { return scope.parent().IsGlobal(); }));
44 }
45 
46 const Scope &GetTopLevelUnitContaining(const Symbol &symbol) {
47   return GetTopLevelUnitContaining(symbol.owner());
48 }
49 
50 const Scope *FindModuleContaining(const Scope &start) {
51   return FindScopeContaining(
52       start, [](const Scope &scope) { return scope.IsModule(); });
53 }
54 
55 const Scope &GetProgramUnitContaining(const Scope &start) {
56   CHECK(!start.IsGlobal());
57   return DEREF(FindScopeContaining(start, [](const Scope &scope) {
58     switch (scope.kind()) {
59     case Scope::Kind::Module:
60     case Scope::Kind::MainProgram:
61     case Scope::Kind::Subprogram:
62     case Scope::Kind::BlockData:
63       return true;
64     default:
65       return false;
66     }
67   }));
68 }
69 
70 const Scope &GetProgramUnitContaining(const Symbol &symbol) {
71   return GetProgramUnitContaining(symbol.owner());
72 }
73 
74 const Scope *FindPureProcedureContaining(const Scope &start) {
75   // N.B. We only need to examine the innermost containing program unit
76   // because an internal subprogram of a pure subprogram must also
77   // be pure (C1592).
78   const Scope &scope{GetProgramUnitContaining(start)};
79   return IsPureProcedure(scope) ? &scope : nullptr;
80 }
81 
82 Tristate IsDefinedAssignment(
83     const std::optional<evaluate::DynamicType> &lhsType, int lhsRank,
84     const std::optional<evaluate::DynamicType> &rhsType, int rhsRank) {
85   if (!lhsType || !rhsType) {
86     return Tristate::No; // error or rhs is untyped
87   }
88   TypeCategory lhsCat{lhsType->category()};
89   TypeCategory rhsCat{rhsType->category()};
90   if (rhsRank > 0 && lhsRank != rhsRank) {
91     return Tristate::Yes;
92   } else if (lhsCat != TypeCategory::Derived) {
93     return ToTristate(lhsCat != rhsCat &&
94         (!IsNumericTypeCategory(lhsCat) || !IsNumericTypeCategory(rhsCat)));
95   } else {
96     const auto *lhsDerived{evaluate::GetDerivedTypeSpec(lhsType)};
97     const auto *rhsDerived{evaluate::GetDerivedTypeSpec(rhsType)};
98     if (lhsDerived && rhsDerived && *lhsDerived == *rhsDerived) {
99       return Tristate::Maybe; // TYPE(t) = TYPE(t) can be defined or
100                               // intrinsic
101     } else {
102       return Tristate::Yes;
103     }
104   }
105 }
106 
107 bool IsIntrinsicRelational(common::RelationalOperator opr,
108     const evaluate::DynamicType &type0, int rank0,
109     const evaluate::DynamicType &type1, int rank1) {
110   if (!evaluate::AreConformable(rank0, rank1)) {
111     return false;
112   } else {
113     auto cat0{type0.category()};
114     auto cat1{type1.category()};
115     if (IsNumericTypeCategory(cat0) && IsNumericTypeCategory(cat1)) {
116       // numeric types: EQ/NE always ok, others ok for non-complex
117       return opr == common::RelationalOperator::EQ ||
118           opr == common::RelationalOperator::NE ||
119           (cat0 != TypeCategory::Complex && cat1 != TypeCategory::Complex);
120     } else {
121       // not both numeric: only Character is ok
122       return cat0 == TypeCategory::Character && cat1 == TypeCategory::Character;
123     }
124   }
125 }
126 
127 bool IsIntrinsicNumeric(const evaluate::DynamicType &type0) {
128   return IsNumericTypeCategory(type0.category());
129 }
130 bool IsIntrinsicNumeric(const evaluate::DynamicType &type0, int rank0,
131     const evaluate::DynamicType &type1, int rank1) {
132   return evaluate::AreConformable(rank0, rank1) &&
133       IsNumericTypeCategory(type0.category()) &&
134       IsNumericTypeCategory(type1.category());
135 }
136 
137 bool IsIntrinsicLogical(const evaluate::DynamicType &type0) {
138   return type0.category() == TypeCategory::Logical;
139 }
140 bool IsIntrinsicLogical(const evaluate::DynamicType &type0, int rank0,
141     const evaluate::DynamicType &type1, int rank1) {
142   return evaluate::AreConformable(rank0, rank1) &&
143       type0.category() == TypeCategory::Logical &&
144       type1.category() == TypeCategory::Logical;
145 }
146 
147 bool IsIntrinsicConcat(const evaluate::DynamicType &type0, int rank0,
148     const evaluate::DynamicType &type1, int rank1) {
149   return evaluate::AreConformable(rank0, rank1) &&
150       type0.category() == TypeCategory::Character &&
151       type1.category() == TypeCategory::Character &&
152       type0.kind() == type1.kind();
153 }
154 
155 bool IsGenericDefinedOp(const Symbol &symbol) {
156   const Symbol &ultimate{symbol.GetUltimate()};
157   if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
158     return generic->kind().IsDefinedOperator();
159   } else if (const auto *misc{ultimate.detailsIf<MiscDetails>()}) {
160     return misc->kind() == MiscDetails::Kind::TypeBoundDefinedOp;
161   } else {
162     return false;
163   }
164 }
165 
166 bool IsDefinedOperator(SourceName name) {
167   const char *begin{name.begin()};
168   const char *end{name.end()};
169   return begin != end && begin[0] == '.' && end[-1] == '.';
170 }
171 
172 std::string MakeOpName(SourceName name) {
173   std::string result{name.ToString()};
174   return IsDefinedOperator(name)         ? "OPERATOR(" + result + ")"
175       : result.find("operator(", 0) == 0 ? parser::ToUpperCaseLetters(result)
176                                          : result;
177 }
178 
179 bool IsCommonBlockContaining(const Symbol &block, const Symbol &object) {
180   const auto &objects{block.get<CommonBlockDetails>().objects()};
181   auto found{std::find(objects.begin(), objects.end(), object)};
182   return found != objects.end();
183 }
184 
185 bool IsUseAssociated(const Symbol &symbol, const Scope &scope) {
186   const Scope &owner{GetProgramUnitContaining(symbol.GetUltimate().owner())};
187   return owner.kind() == Scope::Kind::Module &&
188       owner != GetProgramUnitContaining(scope);
189 }
190 
191 bool DoesScopeContain(
192     const Scope *maybeAncestor, const Scope &maybeDescendent) {
193   return maybeAncestor && !maybeDescendent.IsGlobal() &&
194       FindScopeContaining(maybeDescendent.parent(),
195           [&](const Scope &scope) { return &scope == maybeAncestor; });
196 }
197 
198 bool DoesScopeContain(const Scope *maybeAncestor, const Symbol &symbol) {
199   return DoesScopeContain(maybeAncestor, symbol.owner());
200 }
201 
202 static const Symbol &FollowHostAssoc(const Symbol &symbol) {
203   for (const Symbol *s{&symbol};;) {
204     const auto *details{s->detailsIf<HostAssocDetails>()};
205     if (!details) {
206       return *s;
207     }
208     s = &details->symbol();
209   }
210 }
211 
212 bool IsHostAssociated(const Symbol &symbol, const Scope &scope) {
213   const Scope &subprogram{GetProgramUnitContaining(scope)};
214   return DoesScopeContain(
215       &GetProgramUnitContaining(FollowHostAssoc(symbol)), subprogram);
216 }
217 
218 bool IsInStmtFunction(const Symbol &symbol) {
219   if (const Symbol * function{symbol.owner().symbol()}) {
220     return IsStmtFunction(*function);
221   }
222   return false;
223 }
224 
225 bool IsStmtFunctionDummy(const Symbol &symbol) {
226   return IsDummy(symbol) && IsInStmtFunction(symbol);
227 }
228 
229 bool IsStmtFunctionResult(const Symbol &symbol) {
230   return IsFunctionResult(symbol) && IsInStmtFunction(symbol);
231 }
232 
233 bool IsPointerDummy(const Symbol &symbol) {
234   return IsPointer(symbol) && IsDummy(symbol);
235 }
236 
237 // proc-name
238 bool IsProcName(const Symbol &symbol) {
239   return symbol.GetUltimate().has<ProcEntityDetails>();
240 }
241 
242 bool IsBindCProcedure(const Symbol &symbol) {
243   if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
244     if (const Symbol * procInterface{procDetails->interface().symbol()}) {
245       // procedure component with a BIND(C) interface
246       return IsBindCProcedure(*procInterface);
247     }
248   }
249   return symbol.attrs().test(Attr::BIND_C) && IsProcedure(symbol);
250 }
251 
252 bool IsBindCProcedure(const Scope &scope) {
253   if (const Symbol * symbol{scope.GetSymbol()}) {
254     return IsBindCProcedure(*symbol);
255   } else {
256     return false;
257   }
258 }
259 
260 static const Symbol *FindPointerComponent(
261     const Scope &scope, std::set<const Scope *> &visited) {
262   if (!scope.IsDerivedType()) {
263     return nullptr;
264   }
265   if (!visited.insert(&scope).second) {
266     return nullptr;
267   }
268   // If there's a top-level pointer component, return it for clearer error
269   // messaging.
270   for (const auto &pair : scope) {
271     const Symbol &symbol{*pair.second};
272     if (IsPointer(symbol)) {
273       return &symbol;
274     }
275   }
276   for (const auto &pair : scope) {
277     const Symbol &symbol{*pair.second};
278     if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
279       if (const DeclTypeSpec * type{details->type()}) {
280         if (const DerivedTypeSpec * derived{type->AsDerived()}) {
281           if (const Scope * nested{derived->scope()}) {
282             if (const Symbol *
283                 pointer{FindPointerComponent(*nested, visited)}) {
284               return pointer;
285             }
286           }
287         }
288       }
289     }
290   }
291   return nullptr;
292 }
293 
294 const Symbol *FindPointerComponent(const Scope &scope) {
295   std::set<const Scope *> visited;
296   return FindPointerComponent(scope, visited);
297 }
298 
299 const Symbol *FindPointerComponent(const DerivedTypeSpec &derived) {
300   if (const Scope * scope{derived.scope()}) {
301     return FindPointerComponent(*scope);
302   } else {
303     return nullptr;
304   }
305 }
306 
307 const Symbol *FindPointerComponent(const DeclTypeSpec &type) {
308   if (const DerivedTypeSpec * derived{type.AsDerived()}) {
309     return FindPointerComponent(*derived);
310   } else {
311     return nullptr;
312   }
313 }
314 
315 const Symbol *FindPointerComponent(const DeclTypeSpec *type) {
316   return type ? FindPointerComponent(*type) : nullptr;
317 }
318 
319 const Symbol *FindPointerComponent(const Symbol &symbol) {
320   return IsPointer(symbol) ? &symbol : FindPointerComponent(symbol.GetType());
321 }
322 
323 // C1594 specifies several ways by which an object might be globally visible.
324 const Symbol *FindExternallyVisibleObject(
325     const Symbol &object, const Scope &scope) {
326   // TODO: Storage association with any object for which this predicate holds,
327   // once EQUIVALENCE is supported.
328   if (IsUseAssociated(object, scope) || IsHostAssociated(object, scope) ||
329       (IsPureProcedure(scope) && IsPointerDummy(object)) ||
330       (IsIntentIn(object) && IsDummy(object))) {
331     return &object;
332   } else if (const Symbol * block{FindCommonBlockContaining(object)}) {
333     return block;
334   } else {
335     return nullptr;
336   }
337 }
338 
339 bool ExprHasTypeCategory(
340     const SomeExpr &expr, const common::TypeCategory &type) {
341   auto dynamicType{expr.GetType()};
342   return dynamicType && dynamicType->category() == type;
343 }
344 
345 bool ExprTypeKindIsDefault(
346     const SomeExpr &expr, const SemanticsContext &context) {
347   auto dynamicType{expr.GetType()};
348   return dynamicType &&
349       dynamicType->category() != common::TypeCategory::Derived &&
350       dynamicType->kind() == context.GetDefaultKind(dynamicType->category());
351 }
352 
353 // If an analyzed expr or assignment is missing, dump the node and die.
354 template <typename T>
355 static void CheckMissingAnalysis(bool absent, const T &x) {
356   if (absent) {
357     std::string buf;
358     llvm::raw_string_ostream ss{buf};
359     ss << "node has not been analyzed:\n";
360     parser::DumpTree(ss, x);
361     common::die(ss.str().c_str());
362   }
363 }
364 
365 const SomeExpr *GetExprHelper::Get(const parser::Expr &x) {
366   CheckMissingAnalysis(!x.typedExpr, x);
367   return common::GetPtrFromOptional(x.typedExpr->v);
368 }
369 const SomeExpr *GetExprHelper::Get(const parser::Variable &x) {
370   CheckMissingAnalysis(!x.typedExpr, x);
371   return common::GetPtrFromOptional(x.typedExpr->v);
372 }
373 const SomeExpr *GetExprHelper::Get(const parser::DataStmtConstant &x) {
374   CheckMissingAnalysis(!x.typedExpr, x);
375   return common::GetPtrFromOptional(x.typedExpr->v);
376 }
377 
378 const evaluate::Assignment *GetAssignment(const parser::AssignmentStmt &x) {
379   CheckMissingAnalysis(!x.typedAssignment, x);
380   return common::GetPtrFromOptional(x.typedAssignment->v);
381 }
382 const evaluate::Assignment *GetAssignment(
383     const parser::PointerAssignmentStmt &x) {
384   CheckMissingAnalysis(!x.typedAssignment, x);
385   return common::GetPtrFromOptional(x.typedAssignment->v);
386 }
387 
388 const Symbol *FindInterface(const Symbol &symbol) {
389   return std::visit(
390       common::visitors{
391           [](const ProcEntityDetails &details) {
392             return details.interface().symbol();
393           },
394           [](const ProcBindingDetails &details) { return &details.symbol(); },
395           [](const auto &) -> const Symbol * { return nullptr; },
396       },
397       symbol.details());
398 }
399 
400 const Symbol *FindSubprogram(const Symbol &symbol) {
401   return std::visit(
402       common::visitors{
403           [&](const ProcEntityDetails &details) -> const Symbol * {
404             if (const Symbol * interface{details.interface().symbol()}) {
405               return FindSubprogram(*interface);
406             } else {
407               return &symbol;
408             }
409           },
410           [](const ProcBindingDetails &details) {
411             return FindSubprogram(details.symbol());
412           },
413           [&](const SubprogramDetails &) { return &symbol; },
414           [](const UseDetails &details) {
415             return FindSubprogram(details.symbol());
416           },
417           [](const HostAssocDetails &details) {
418             return FindSubprogram(details.symbol());
419           },
420           [](const auto &) -> const Symbol * { return nullptr; },
421       },
422       symbol.details());
423 }
424 
425 const Symbol *FindFunctionResult(const Symbol &symbol) {
426   if (const Symbol * subp{FindSubprogram(symbol)}) {
427     if (const auto &subpDetails{subp->detailsIf<SubprogramDetails>()}) {
428       if (subpDetails->isFunction()) {
429         return &subpDetails->result();
430       }
431     }
432   }
433   return nullptr;
434 }
435 
436 const Symbol *FindOverriddenBinding(const Symbol &symbol) {
437   if (symbol.has<ProcBindingDetails>()) {
438     if (const DeclTypeSpec * parentType{FindParentTypeSpec(symbol.owner())}) {
439       if (const DerivedTypeSpec * parentDerived{parentType->AsDerived()}) {
440         if (const Scope * parentScope{parentDerived->typeSymbol().scope()}) {
441           return parentScope->FindComponent(symbol.name());
442         }
443       }
444     }
445   }
446   return nullptr;
447 }
448 
449 const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &derived) {
450   return FindParentTypeSpec(derived.typeSymbol());
451 }
452 
453 const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &decl) {
454   if (const DerivedTypeSpec * derived{decl.AsDerived()}) {
455     return FindParentTypeSpec(*derived);
456   } else {
457     return nullptr;
458   }
459 }
460 
461 const DeclTypeSpec *FindParentTypeSpec(const Scope &scope) {
462   if (scope.kind() == Scope::Kind::DerivedType) {
463     if (const auto *symbol{scope.symbol()}) {
464       return FindParentTypeSpec(*symbol);
465     }
466   }
467   return nullptr;
468 }
469 
470 const DeclTypeSpec *FindParentTypeSpec(const Symbol &symbol) {
471   if (const Scope * scope{symbol.scope()}) {
472     if (const auto *details{symbol.detailsIf<DerivedTypeDetails>()}) {
473       if (const Symbol * parent{details->GetParentComponent(*scope)}) {
474         return parent->GetType();
475       }
476     }
477   }
478   return nullptr;
479 }
480 
481 bool IsExtensibleType(const DerivedTypeSpec *derived) {
482   return derived && !IsIsoCType(derived) &&
483       !derived->typeSymbol().attrs().test(Attr::BIND_C) &&
484       !derived->typeSymbol().get<DerivedTypeDetails>().sequence();
485 }
486 
487 bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {
488   if (!derived) {
489     return false;
490   } else {
491     const auto &symbol{derived->typeSymbol()};
492     return symbol.owner().IsModule() &&
493         symbol.owner().GetName().value() == "__fortran_builtins" &&
494         symbol.name() == "__builtin_"s + name;
495   }
496 }
497 
498 bool IsIsoCType(const DerivedTypeSpec *derived) {
499   return IsBuiltinDerivedType(derived, "c_ptr") ||
500       IsBuiltinDerivedType(derived, "c_funptr");
501 }
502 
503 bool IsTeamType(const DerivedTypeSpec *derived) {
504   return IsBuiltinDerivedType(derived, "team_type");
505 }
506 
507 bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
508   return IsBuiltinDerivedType(derivedTypeSpec, "event_type") ||
509       IsBuiltinDerivedType(derivedTypeSpec, "lock_type");
510 }
511 
512 bool IsOrContainsEventOrLockComponent(const Symbol &symbol) {
513   if (const Symbol * root{GetAssociationRoot(symbol)}) {
514     if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) {
515       if (const DeclTypeSpec * type{details->type()}) {
516         if (const DerivedTypeSpec * derived{type->AsDerived()}) {
517           return IsEventTypeOrLockType(derived) ||
518               FindEventOrLockPotentialComponent(*derived);
519         }
520       }
521     }
522   }
523   return false;
524 }
525 
526 // Check this symbol suitable as a type-bound procedure - C769
527 bool CanBeTypeBoundProc(const Symbol *symbol) {
528   if (!symbol || IsDummy(*symbol) || IsProcedurePointer(*symbol)) {
529     return false;
530   } else if (symbol->has<SubprogramNameDetails>()) {
531     return symbol->owner().kind() == Scope::Kind::Module;
532   } else if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
533     return symbol->owner().kind() == Scope::Kind::Module ||
534         details->isInterface();
535   } else if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
536     return !symbol->attrs().test(Attr::INTRINSIC) &&
537         proc->HasExplicitInterface();
538   } else {
539     return false;
540   }
541 }
542 
543 bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements) {
544   if (!ignoreDATAstatements && symbol.test(Symbol::Flag::InDataStmt)) {
545     return true;
546   } else if (IsNamedConstant(symbol)) {
547     return false;
548   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
549     if (object->init()) {
550       return true;
551     } else if (object->isDummy() || IsFunctionResult(symbol)) {
552       return false;
553     } else if (IsAllocatable(symbol)) {
554       return true;
555     } else if (!IsPointer(symbol) && object->type()) {
556       if (const auto *derived{object->type()->AsDerived()}) {
557         if (derived->HasDefaultInitialization()) {
558           return true;
559         }
560       }
561     }
562   } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
563     return proc->init().has_value();
564   }
565   return false;
566 }
567 
568 bool HasIntrinsicTypeName(const Symbol &symbol) {
569   std::string name{symbol.name().ToString()};
570   if (name == "doubleprecision") {
571     return true;
572   } else if (name == "derived") {
573     return false;
574   } else {
575     for (int i{0}; i != common::TypeCategory_enumSize; ++i) {
576       if (name == parser::ToLowerCaseLetters(EnumToString(TypeCategory{i}))) {
577         return true;
578       }
579     }
580     return false;
581   }
582 }
583 
584 bool IsSeparateModuleProcedureInterface(const Symbol *symbol) {
585   if (symbol && symbol->attrs().test(Attr::MODULE)) {
586     if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
587       return details->isInterface();
588     }
589   }
590   return false;
591 }
592 
593 // 3.11 automatic data object
594 bool IsAutomatic(const Symbol &symbol) {
595   if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
596     if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {
597       if (const DeclTypeSpec * type{symbol.GetType()}) {
598         // If a type parameter value is not a constant expression, the
599         // object is automatic.
600         if (type->category() == DeclTypeSpec::Character) {
601           if (const auto &length{
602                   type->characterTypeSpec().length().GetExplicit()}) {
603             if (!evaluate::IsConstantExpr(*length)) {
604               return true;
605             }
606           }
607         } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
608           for (const auto &pair : derived->parameters()) {
609             if (const auto &value{pair.second.GetExplicit()}) {
610               if (!evaluate::IsConstantExpr(*value)) {
611                 return true;
612               }
613             }
614           }
615         }
616       }
617       // If an array bound is not a constant expression, the object is
618       // automatic.
619       for (const ShapeSpec &dim : object->shape()) {
620         if (const auto &lb{dim.lbound().GetExplicit()}) {
621           if (!evaluate::IsConstantExpr(*lb)) {
622             return true;
623           }
624         }
625         if (const auto &ub{dim.ubound().GetExplicit()}) {
626           if (!evaluate::IsConstantExpr(*ub)) {
627             return true;
628           }
629         }
630       }
631     }
632   }
633   return false;
634 }
635 
636 bool IsFinalizable(const Symbol &symbol) {
637   if (const DeclTypeSpec * type{symbol.GetType()}) {
638     if (const DerivedTypeSpec * derived{type->AsDerived()}) {
639       return IsFinalizable(*derived);
640     }
641   }
642   return false;
643 }
644 
645 bool IsFinalizable(const DerivedTypeSpec &derived) {
646   if (!derived.typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
647     return true;
648   }
649   DirectComponentIterator components{derived};
650   return bool{std::find_if(components.begin(), components.end(),
651       [](const Symbol &component) { return IsFinalizable(component); })};
652 }
653 
654 bool HasImpureFinal(const DerivedTypeSpec &derived) {
655   if (const auto *details{
656           derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) {
657     const auto &finals{details->finals()};
658     return std::any_of(finals.begin(), finals.end(),
659         [](const auto &x) { return !x.second->attrs().test(Attr::PURE); });
660   } else {
661     return false;
662   }
663 }
664 
665 bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; }
666 
667 bool IsAutomaticObject(const Symbol &symbol) {
668   if (IsDummy(symbol) || IsPointer(symbol) || IsAllocatable(symbol)) {
669     return false;
670   }
671   if (const DeclTypeSpec * type{symbol.GetType()}) {
672     if (type->category() == DeclTypeSpec::Character) {
673       ParamValue length{type->characterTypeSpec().length()};
674       if (length.isExplicit()) {
675         if (MaybeIntExpr lengthExpr{length.GetExplicit()}) {
676           if (!ToInt64(lengthExpr)) {
677             return true;
678           }
679         }
680       }
681     }
682   }
683   if (symbol.IsObjectArray()) {
684     for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) {
685       auto &lbound{spec.lbound().GetExplicit()};
686       auto &ubound{spec.ubound().GetExplicit()};
687       if ((lbound && !evaluate::ToInt64(*lbound)) ||
688           (ubound && !evaluate::ToInt64(*ubound))) {
689         return true;
690       }
691     }
692   }
693   return false;
694 }
695 
696 bool IsAssumedLengthCharacter(const Symbol &symbol) {
697   if (const DeclTypeSpec * type{symbol.GetType()}) {
698     return type->category() == DeclTypeSpec::Character &&
699         type->characterTypeSpec().length().isAssumed();
700   } else {
701     return false;
702   }
703 }
704 
705 bool IsInBlankCommon(const Symbol &symbol) {
706   const Symbol *block{FindCommonBlockContaining(symbol)};
707   return block && block->name().empty();
708 }
709 
710 // C722 and C723:  For a function to be assumed length, it must be external and
711 // of CHARACTER type
712 bool IsExternal(const Symbol &symbol) {
713   return ClassifyProcedure(symbol) == ProcedureDefinitionClass::External;
714 }
715 
716 bool IsModuleProcedure(const Symbol &symbol) {
717   return ClassifyProcedure(symbol) == ProcedureDefinitionClass::Module;
718 }
719 const Symbol *IsExternalInPureContext(
720     const Symbol &symbol, const Scope &scope) {
721   if (const auto *pureProc{FindPureProcedureContaining(scope)}) {
722     if (const Symbol * root{GetAssociationRoot(symbol)}) {
723       if (const Symbol *
724           visible{FindExternallyVisibleObject(*root, *pureProc)}) {
725         return visible;
726       }
727     }
728   }
729   return nullptr;
730 }
731 
732 PotentialComponentIterator::const_iterator FindPolymorphicPotentialComponent(
733     const DerivedTypeSpec &derived) {
734   PotentialComponentIterator potentials{derived};
735   return std::find_if(
736       potentials.begin(), potentials.end(), [](const Symbol &component) {
737         if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
738           const DeclTypeSpec *type{details->type()};
739           return type && type->IsPolymorphic();
740         }
741         return false;
742       });
743 }
744 
745 bool IsOrContainsPolymorphicComponent(const Symbol &symbol) {
746   if (const Symbol * root{GetAssociationRoot(symbol)}) {
747     if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) {
748       if (const DeclTypeSpec * type{details->type()}) {
749         if (type->IsPolymorphic()) {
750           return true;
751         }
752         if (const DerivedTypeSpec * derived{type->AsDerived()}) {
753           return (bool)FindPolymorphicPotentialComponent(*derived);
754         }
755       }
756     }
757   }
758   return false;
759 }
760 
761 bool InProtectedContext(const Symbol &symbol, const Scope &currentScope) {
762   return IsProtected(symbol) && !IsHostAssociated(symbol, currentScope);
763 }
764 
765 // C1101 and C1158
766 std::optional<parser::MessageFixedText> WhyNotModifiable(
767     const Symbol &symbol, const Scope &scope) {
768   const Symbol *root{GetAssociationRoot(symbol)};
769   if (!root) {
770     return "'%s' is construct associated with an expression"_en_US;
771   } else if (InProtectedContext(*root, scope)) {
772     return "'%s' is protected in this scope"_en_US;
773   } else if (IsExternalInPureContext(*root, scope)) {
774     return "'%s' is externally visible and referenced in a pure"
775            " procedure"_en_US;
776   } else if (IsOrContainsEventOrLockComponent(*root)) {
777     return "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US;
778   } else if (IsIntentIn(*root)) {
779     return "'%s' is an INTENT(IN) dummy argument"_en_US;
780   } else if (!IsVariableName(*root)) {
781     return "'%s' is not a variable"_en_US;
782   } else {
783     return std::nullopt;
784   }
785 }
786 
787 std::optional<parser::Message> WhyNotModifiable(parser::CharBlock at,
788     const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) {
789   if (!evaluate::IsVariable(expr)) {
790     return parser::Message{at, "Expression is not a variable"_en_US};
791   } else if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) {
792     if (!vectorSubscriptIsOk && evaluate::HasVectorSubscript(expr)) {
793       return parser::Message{at, "Variable has a vector subscript"_en_US};
794     }
795     const Symbol &symbol{dataRef->GetFirstSymbol()};
796     if (auto maybeWhy{WhyNotModifiable(symbol, scope)}) {
797       return parser::Message{symbol.name(),
798           parser::MessageFormattedText{std::move(*maybeWhy), symbol.name()}};
799     }
800   } else {
801     // reference to function returning POINTER
802   }
803   return std::nullopt;
804 }
805 
806 class ImageControlStmtHelper {
807   using ImageControlStmts = std::variant<parser::ChangeTeamConstruct,
808       parser::CriticalConstruct, parser::EventPostStmt, parser::EventWaitStmt,
809       parser::FormTeamStmt, parser::LockStmt, parser::StopStmt,
810       parser::SyncAllStmt, parser::SyncImagesStmt, parser::SyncMemoryStmt,
811       parser::SyncTeamStmt, parser::UnlockStmt>;
812 
813 public:
814   template <typename T> bool operator()(const T &) {
815     return common::HasMember<T, ImageControlStmts>;
816   }
817   template <typename T> bool operator()(const common::Indirection<T> &x) {
818     return (*this)(x.value());
819   }
820   bool operator()(const parser::AllocateStmt &stmt) {
821     const auto &allocationList{std::get<std::list<parser::Allocation>>(stmt.t)};
822     for (const auto &allocation : allocationList) {
823       const auto &allocateObject{
824           std::get<parser::AllocateObject>(allocation.t)};
825       if (IsCoarrayObject(allocateObject)) {
826         return true;
827       }
828     }
829     return false;
830   }
831   bool operator()(const parser::DeallocateStmt &stmt) {
832     const auto &allocateObjectList{
833         std::get<std::list<parser::AllocateObject>>(stmt.t)};
834     for (const auto &allocateObject : allocateObjectList) {
835       if (IsCoarrayObject(allocateObject)) {
836         return true;
837       }
838     }
839     return false;
840   }
841   bool operator()(const parser::CallStmt &stmt) {
842     const auto &procedureDesignator{
843         std::get<parser::ProcedureDesignator>(stmt.v.t)};
844     if (auto *name{std::get_if<parser::Name>(&procedureDesignator.u)}) {
845       // TODO: also ensure that the procedure is, in fact, an intrinsic
846       if (name->source == "move_alloc") {
847         const auto &args{std::get<std::list<parser::ActualArgSpec>>(stmt.v.t)};
848         if (!args.empty()) {
849           const parser::ActualArg &actualArg{
850               std::get<parser::ActualArg>(args.front().t)};
851           if (const auto *argExpr{
852                   std::get_if<common::Indirection<parser::Expr>>(
853                       &actualArg.u)}) {
854             return HasCoarray(argExpr->value());
855           }
856         }
857       }
858     }
859     return false;
860   }
861   bool operator()(const parser::Statement<parser::ActionStmt> &stmt) {
862     return std::visit(*this, stmt.statement.u);
863   }
864 
865 private:
866   bool IsCoarrayObject(const parser::AllocateObject &allocateObject) {
867     const parser::Name &name{GetLastName(allocateObject)};
868     return name.symbol && IsCoarray(*name.symbol);
869   }
870 };
871 
872 bool IsImageControlStmt(const parser::ExecutableConstruct &construct) {
873   return std::visit(ImageControlStmtHelper{}, construct.u);
874 }
875 
876 std::optional<parser::MessageFixedText> GetImageControlStmtCoarrayMsg(
877     const parser::ExecutableConstruct &construct) {
878   if (const auto *actionStmt{
879           std::get_if<parser::Statement<parser::ActionStmt>>(&construct.u)}) {
880     return std::visit(
881         common::visitors{
882             [](const common::Indirection<parser::AllocateStmt> &)
883                 -> std::optional<parser::MessageFixedText> {
884               return "ALLOCATE of a coarray is an image control"
885                      " statement"_en_US;
886             },
887             [](const common::Indirection<parser::DeallocateStmt> &)
888                 -> std::optional<parser::MessageFixedText> {
889               return "DEALLOCATE of a coarray is an image control"
890                      " statement"_en_US;
891             },
892             [](const common::Indirection<parser::CallStmt> &)
893                 -> std::optional<parser::MessageFixedText> {
894               return "MOVE_ALLOC of a coarray is an image control"
895                      " statement "_en_US;
896             },
897             [](const auto &) -> std::optional<parser::MessageFixedText> {
898               return std::nullopt;
899             },
900         },
901         actionStmt->statement.u);
902   }
903   return std::nullopt;
904 }
905 
906 parser::CharBlock GetImageControlStmtLocation(
907     const parser::ExecutableConstruct &executableConstruct) {
908   return std::visit(
909       common::visitors{
910           [](const common::Indirection<parser::ChangeTeamConstruct>
911                   &construct) {
912             return std::get<parser::Statement<parser::ChangeTeamStmt>>(
913                 construct.value().t)
914                 .source;
915           },
916           [](const common::Indirection<parser::CriticalConstruct> &construct) {
917             return std::get<parser::Statement<parser::CriticalStmt>>(
918                 construct.value().t)
919                 .source;
920           },
921           [](const parser::Statement<parser::ActionStmt> &actionStmt) {
922             return actionStmt.source;
923           },
924           [](const auto &) { return parser::CharBlock{}; },
925       },
926       executableConstruct.u);
927 }
928 
929 bool HasCoarray(const parser::Expr &expression) {
930   if (const auto *expr{GetExpr(expression)}) {
931     for (const Symbol &symbol : evaluate::CollectSymbols(*expr)) {
932       if (const Symbol * root{GetAssociationRoot(symbol)}) {
933         if (IsCoarray(*root)) {
934           return true;
935         }
936       }
937     }
938   }
939   return false;
940 }
941 
942 bool IsPolymorphic(const Symbol &symbol) {
943   if (const DeclTypeSpec * type{symbol.GetType()}) {
944     return type->IsPolymorphic();
945   }
946   return false;
947 }
948 
949 bool IsPolymorphicAllocatable(const Symbol &symbol) {
950   return IsAllocatable(symbol) && IsPolymorphic(symbol);
951 }
952 
953 std::optional<parser::MessageFormattedText> CheckAccessibleComponent(
954     const Scope &scope, const Symbol &symbol) {
955   CHECK(symbol.owner().IsDerivedType()); // symbol must be a component
956   if (symbol.attrs().test(Attr::PRIVATE)) {
957     if (const Scope * moduleScope{FindModuleContaining(symbol.owner())}) {
958       if (!moduleScope->Contains(scope)) {
959         return parser::MessageFormattedText{
960             "PRIVATE component '%s' is only accessible within module '%s'"_err_en_US,
961             symbol.name(), moduleScope->GetName().value()};
962       }
963     }
964   }
965   return std::nullopt;
966 }
967 
968 std::list<SourceName> OrderParameterNames(const Symbol &typeSymbol) {
969   std::list<SourceName> result;
970   if (const DerivedTypeSpec * spec{typeSymbol.GetParentTypeSpec()}) {
971     result = OrderParameterNames(spec->typeSymbol());
972   }
973   const auto &paramNames{typeSymbol.get<DerivedTypeDetails>().paramNames()};
974   result.insert(result.end(), paramNames.begin(), paramNames.end());
975   return result;
976 }
977 
978 SymbolVector OrderParameterDeclarations(const Symbol &typeSymbol) {
979   SymbolVector result;
980   if (const DerivedTypeSpec * spec{typeSymbol.GetParentTypeSpec()}) {
981     result = OrderParameterDeclarations(spec->typeSymbol());
982   }
983   const auto &paramDecls{typeSymbol.get<DerivedTypeDetails>().paramDecls()};
984   result.insert(result.end(), paramDecls.begin(), paramDecls.end());
985   return result;
986 }
987 
988 const DeclTypeSpec &FindOrInstantiateDerivedType(Scope &scope,
989     DerivedTypeSpec &&spec, SemanticsContext &semanticsContext,
990     DeclTypeSpec::Category category) {
991   spec.EvaluateParameters(semanticsContext);
992   if (const DeclTypeSpec *
993       type{scope.FindInstantiatedDerivedType(spec, category)}) {
994     return *type;
995   }
996   // Create a new instantiation of this parameterized derived type
997   // for this particular distinct set of actual parameter values.
998   DeclTypeSpec &type{scope.MakeDerivedType(category, std::move(spec))};
999   type.derivedTypeSpec().Instantiate(scope, semanticsContext);
1000   return type;
1001 }
1002 
1003 const Symbol *FindSeparateModuleSubprogramInterface(const Symbol *proc) {
1004   if (proc) {
1005     if (const Symbol * submodule{proc->owner().symbol()}) {
1006       if (const auto *details{submodule->detailsIf<ModuleDetails>()}) {
1007         if (const Scope * ancestor{details->ancestor()}) {
1008           const Symbol *iface{ancestor->FindSymbol(proc->name())};
1009           if (IsSeparateModuleProcedureInterface(iface)) {
1010             return iface;
1011           }
1012         }
1013       }
1014     }
1015   }
1016   return nullptr;
1017 }
1018 
1019 ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2
1020   const Symbol &ultimate{symbol.GetUltimate()};
1021   if (ultimate.attrs().test(Attr::INTRINSIC)) {
1022     return ProcedureDefinitionClass::Intrinsic;
1023   } else if (ultimate.attrs().test(Attr::EXTERNAL)) {
1024     return ProcedureDefinitionClass::External;
1025   } else if (const auto *procDetails{ultimate.detailsIf<ProcEntityDetails>()}) {
1026     if (procDetails->isDummy()) {
1027       return ProcedureDefinitionClass::Dummy;
1028     } else if (IsPointer(ultimate)) {
1029       return ProcedureDefinitionClass::Pointer;
1030     }
1031   } else if (const Symbol * subp{FindSubprogram(symbol)}) {
1032     if (const auto *subpDetails{subp->detailsIf<SubprogramDetails>()}) {
1033       if (subpDetails->stmtFunction()) {
1034         return ProcedureDefinitionClass::StatementFunction;
1035       }
1036     }
1037     switch (ultimate.owner().kind()) {
1038     case Scope::Kind::Global:
1039       return ProcedureDefinitionClass::External;
1040     case Scope::Kind::Module:
1041       return ProcedureDefinitionClass::Module;
1042     case Scope::Kind::MainProgram:
1043     case Scope::Kind::Subprogram:
1044       return ProcedureDefinitionClass::Internal;
1045     default:
1046       break;
1047     }
1048   }
1049   return ProcedureDefinitionClass::None;
1050 }
1051 
1052 // ComponentIterator implementation
1053 
1054 template <ComponentKind componentKind>
1055 typename ComponentIterator<componentKind>::const_iterator
1056 ComponentIterator<componentKind>::const_iterator::Create(
1057     const DerivedTypeSpec &derived) {
1058   const_iterator it{};
1059   it.componentPath_.emplace_back(derived);
1060   it.Increment(); // cue up first relevant component, if any
1061   return it;
1062 }
1063 
1064 template <ComponentKind componentKind>
1065 const DerivedTypeSpec *
1066 ComponentIterator<componentKind>::const_iterator::PlanComponentTraversal(
1067     const Symbol &component) const {
1068   if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
1069     if (const DeclTypeSpec * type{details->type()}) {
1070       if (const auto *derived{type->AsDerived()}) {
1071         bool traverse{false};
1072         if constexpr (componentKind == ComponentKind::Ordered) {
1073           // Order Component (only visit parents)
1074           traverse = component.test(Symbol::Flag::ParentComp);
1075         } else if constexpr (componentKind == ComponentKind::Direct) {
1076           traverse = !IsAllocatableOrPointer(component);
1077         } else if constexpr (componentKind == ComponentKind::Ultimate) {
1078           traverse = !IsAllocatableOrPointer(component);
1079         } else if constexpr (componentKind == ComponentKind::Potential) {
1080           traverse = !IsPointer(component);
1081         } else if constexpr (componentKind == ComponentKind::Scope) {
1082           traverse = !IsAllocatableOrPointer(component);
1083         }
1084         if (traverse) {
1085           const Symbol &newTypeSymbol{derived->typeSymbol()};
1086           // Avoid infinite loop if the type is already part of the types
1087           // being visited. It is possible to have "loops in type" because
1088           // C744 does not forbid to use not yet declared type for
1089           // ALLOCATABLE or POINTER components.
1090           for (const auto &node : componentPath_) {
1091             if (&newTypeSymbol == &node.GetTypeSymbol()) {
1092               return nullptr;
1093             }
1094           }
1095           return derived;
1096         }
1097       }
1098     } // intrinsic & unlimited polymorphic not traversable
1099   }
1100   return nullptr;
1101 }
1102 
1103 template <ComponentKind componentKind>
1104 static bool StopAtComponentPre(const Symbol &component) {
1105   if constexpr (componentKind == ComponentKind::Ordered) {
1106     // Parent components need to be iterated upon after their
1107     // sub-components in structure constructor analysis.
1108     return !component.test(Symbol::Flag::ParentComp);
1109   } else if constexpr (componentKind == ComponentKind::Direct) {
1110     return true;
1111   } else if constexpr (componentKind == ComponentKind::Ultimate) {
1112     return component.has<ProcEntityDetails>() ||
1113         IsAllocatableOrPointer(component) ||
1114         (component.get<ObjectEntityDetails>().type() &&
1115             component.get<ObjectEntityDetails>().type()->AsIntrinsic());
1116   } else if constexpr (componentKind == ComponentKind::Potential) {
1117     return !IsPointer(component);
1118   }
1119 }
1120 
1121 template <ComponentKind componentKind>
1122 static bool StopAtComponentPost(const Symbol &component) {
1123   return componentKind == ComponentKind::Ordered &&
1124       component.test(Symbol::Flag::ParentComp);
1125 }
1126 
1127 template <ComponentKind componentKind>
1128 void ComponentIterator<componentKind>::const_iterator::Increment() {
1129   while (!componentPath_.empty()) {
1130     ComponentPathNode &deepest{componentPath_.back()};
1131     if (deepest.component()) {
1132       if (!deepest.descended()) {
1133         deepest.set_descended(true);
1134         if (const DerivedTypeSpec *
1135             derived{PlanComponentTraversal(*deepest.component())}) {
1136           componentPath_.emplace_back(*derived);
1137           continue;
1138         }
1139       } else if (!deepest.visited()) {
1140         deepest.set_visited(true);
1141         return; // this is the next component to visit, after descending
1142       }
1143     }
1144     auto &nameIterator{deepest.nameIterator()};
1145     if (nameIterator == deepest.nameEnd()) {
1146       componentPath_.pop_back();
1147     } else if constexpr (componentKind == ComponentKind::Scope) {
1148       deepest.set_component(*nameIterator++->second);
1149       deepest.set_descended(false);
1150       deepest.set_visited(true);
1151       return; // this is the next component to visit, before descending
1152     } else {
1153       const Scope &scope{deepest.GetScope()};
1154       auto scopeIter{scope.find(*nameIterator++)};
1155       if (scopeIter != scope.cend()) {
1156         const Symbol &component{*scopeIter->second};
1157         deepest.set_component(component);
1158         deepest.set_descended(false);
1159         if (StopAtComponentPre<componentKind>(component)) {
1160           deepest.set_visited(true);
1161           return; // this is the next component to visit, before descending
1162         } else {
1163           deepest.set_visited(!StopAtComponentPost<componentKind>(component));
1164         }
1165       }
1166     }
1167   }
1168 }
1169 
1170 template <ComponentKind componentKind>
1171 std::string
1172 ComponentIterator<componentKind>::const_iterator::BuildResultDesignatorName()
1173     const {
1174   std::string designator{""};
1175   for (const auto &node : componentPath_) {
1176     designator += "%" + DEREF(node.component()).name().ToString();
1177   }
1178   return designator;
1179 }
1180 
1181 template class ComponentIterator<ComponentKind::Ordered>;
1182 template class ComponentIterator<ComponentKind::Direct>;
1183 template class ComponentIterator<ComponentKind::Ultimate>;
1184 template class ComponentIterator<ComponentKind::Potential>;
1185 template class ComponentIterator<ComponentKind::Scope>;
1186 
1187 UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
1188     const DerivedTypeSpec &derived) {
1189   UltimateComponentIterator ultimates{derived};
1190   return std::find_if(ultimates.begin(), ultimates.end(), IsCoarray);
1191 }
1192 
1193 UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
1194     const DerivedTypeSpec &derived) {
1195   UltimateComponentIterator ultimates{derived};
1196   return std::find_if(ultimates.begin(), ultimates.end(), IsPointer);
1197 }
1198 
1199 PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
1200     const DerivedTypeSpec &derived) {
1201   PotentialComponentIterator potentials{derived};
1202   return std::find_if(
1203       potentials.begin(), potentials.end(), [](const Symbol &component) {
1204         if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
1205           const DeclTypeSpec *type{details->type()};
1206           return type && IsEventTypeOrLockType(type->AsDerived());
1207         }
1208         return false;
1209       });
1210 }
1211 
1212 UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
1213     const DerivedTypeSpec &derived) {
1214   UltimateComponentIterator ultimates{derived};
1215   return std::find_if(ultimates.begin(), ultimates.end(), IsAllocatable);
1216 }
1217 
1218 UltimateComponentIterator::const_iterator
1219 FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &derived) {
1220   UltimateComponentIterator ultimates{derived};
1221   return std::find_if(
1222       ultimates.begin(), ultimates.end(), IsPolymorphicAllocatable);
1223 }
1224 
1225 UltimateComponentIterator::const_iterator
1226 FindPolymorphicAllocatableNonCoarrayUltimateComponent(
1227     const DerivedTypeSpec &derived) {
1228   UltimateComponentIterator ultimates{derived};
1229   return std::find_if(ultimates.begin(), ultimates.end(), [](const Symbol &x) {
1230     return IsPolymorphicAllocatable(x) && !IsCoarray(x);
1231   });
1232 }
1233 
1234 const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived,
1235     const std::function<bool(const Symbol &)> &predicate) {
1236   UltimateComponentIterator ultimates{derived};
1237   if (auto it{std::find_if(ultimates.begin(), ultimates.end(),
1238           [&predicate](const Symbol &component) -> bool {
1239             return predicate(component);
1240           })}) {
1241     return &*it;
1242   }
1243   return nullptr;
1244 }
1245 
1246 const Symbol *FindUltimateComponent(const Symbol &symbol,
1247     const std::function<bool(const Symbol &)> &predicate) {
1248   if (predicate(symbol)) {
1249     return &symbol;
1250   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1251     if (const auto *type{object->type()}) {
1252       if (const auto *derived{type->AsDerived()}) {
1253         return FindUltimateComponent(*derived, predicate);
1254       }
1255     }
1256   }
1257   return nullptr;
1258 }
1259 
1260 const Symbol *FindImmediateComponent(const DerivedTypeSpec &type,
1261     const std::function<bool(const Symbol &)> &predicate) {
1262   if (const Scope * scope{type.scope()}) {
1263     const Symbol *parent{nullptr};
1264     for (const auto &pair : *scope) {
1265       const Symbol *symbol{&*pair.second};
1266       if (predicate(*symbol)) {
1267         return symbol;
1268       }
1269       if (symbol->test(Symbol::Flag::ParentComp)) {
1270         parent = symbol;
1271       }
1272     }
1273     if (parent) {
1274       if (const auto *object{parent->detailsIf<ObjectEntityDetails>()}) {
1275         if (const auto *type{object->type()}) {
1276           if (const auto *derived{type->AsDerived()}) {
1277             return FindImmediateComponent(*derived, predicate);
1278           }
1279         }
1280       }
1281     }
1282   }
1283   return nullptr;
1284 }
1285 
1286 bool IsFunctionResultWithSameNameAsFunction(const Symbol &symbol) {
1287   if (IsFunctionResult(symbol)) {
1288     if (const Symbol * function{symbol.owner().symbol()}) {
1289       return symbol.name() == function->name();
1290     }
1291   }
1292   return false;
1293 }
1294 
1295 void LabelEnforce::Post(const parser::GotoStmt &gotoStmt) {
1296   checkLabelUse(gotoStmt.v);
1297 }
1298 void LabelEnforce::Post(const parser::ComputedGotoStmt &computedGotoStmt) {
1299   for (auto &i : std::get<std::list<parser::Label>>(computedGotoStmt.t)) {
1300     checkLabelUse(i);
1301   }
1302 }
1303 
1304 void LabelEnforce::Post(const parser::ArithmeticIfStmt &arithmeticIfStmt) {
1305   checkLabelUse(std::get<1>(arithmeticIfStmt.t));
1306   checkLabelUse(std::get<2>(arithmeticIfStmt.t));
1307   checkLabelUse(std::get<3>(arithmeticIfStmt.t));
1308 }
1309 
1310 void LabelEnforce::Post(const parser::AssignStmt &assignStmt) {
1311   checkLabelUse(std::get<parser::Label>(assignStmt.t));
1312 }
1313 
1314 void LabelEnforce::Post(const parser::AssignedGotoStmt &assignedGotoStmt) {
1315   for (auto &i : std::get<std::list<parser::Label>>(assignedGotoStmt.t)) {
1316     checkLabelUse(i);
1317   }
1318 }
1319 
1320 void LabelEnforce::Post(const parser::AltReturnSpec &altReturnSpec) {
1321   checkLabelUse(altReturnSpec.v);
1322 }
1323 
1324 void LabelEnforce::Post(const parser::ErrLabel &errLabel) {
1325   checkLabelUse(errLabel.v);
1326 }
1327 void LabelEnforce::Post(const parser::EndLabel &endLabel) {
1328   checkLabelUse(endLabel.v);
1329 }
1330 void LabelEnforce::Post(const parser::EorLabel &eorLabel) {
1331   checkLabelUse(eorLabel.v);
1332 }
1333 
1334 void LabelEnforce::checkLabelUse(const parser::Label &labelUsed) {
1335   if (labels_.find(labelUsed) == labels_.end()) {
1336     SayWithConstruct(context_, currentStatementSourcePosition_,
1337         parser::MessageFormattedText{
1338             "Control flow escapes from %s"_err_en_US, construct_},
1339         constructSourcePosition_);
1340   }
1341 }
1342 
1343 parser::MessageFormattedText LabelEnforce::GetEnclosingConstructMsg() {
1344   return {"Enclosing %s statement"_en_US, construct_};
1345 }
1346 
1347 void LabelEnforce::SayWithConstruct(SemanticsContext &context,
1348     parser::CharBlock stmtLocation, parser::MessageFormattedText &&message,
1349     parser::CharBlock constructLocation) {
1350   context.Say(stmtLocation, message)
1351       .Attach(constructLocation, GetEnclosingConstructMsg());
1352 }
1353 
1354 bool HasAlternateReturns(const Symbol &subprogram) {
1355   for (const auto *dummyArg : subprogram.get<SubprogramDetails>().dummyArgs()) {
1356     if (!dummyArg) {
1357       return true;
1358     }
1359   }
1360   return false;
1361 }
1362 
1363 bool InCommonBlock(const Symbol &symbol) {
1364   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
1365   return details && details->commonBlock();
1366 }
1367 
1368 const std::optional<parser::Name> &MaybeGetNodeName(
1369     const ConstructNode &construct) {
1370   return std::visit(
1371       common::visitors{
1372           [&](const parser::BlockConstruct *blockConstruct)
1373               -> const std::optional<parser::Name> & {
1374             return std::get<0>(blockConstruct->t).statement.v;
1375           },
1376           [&](const auto *a) -> const std::optional<parser::Name> & {
1377             return std::get<0>(std::get<0>(a->t).statement.t);
1378           },
1379       },
1380       construct);
1381 }
1382 
1383 } // namespace Fortran::semantics
1384