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