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