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