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