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