1//===-- lib/Semantics/check-do-forall.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 "check-do-forall.h"
10#include "definable.h"
11#include "flang/Common/template.h"
12#include "flang/Evaluate/call.h"
13#include "flang/Evaluate/expression.h"
14#include "flang/Evaluate/tools.h"
15#include "flang/Evaluate/traverse.h"
16#include "flang/Parser/message.h"
17#include "flang/Parser/parse-tree-visitor.h"
18#include "flang/Parser/tools.h"
19#include "flang/Semantics/attr.h"
20#include "flang/Semantics/scope.h"
21#include "flang/Semantics/semantics.h"
22#include "flang/Semantics/symbol.h"
23#include "flang/Semantics/tools.h"
24#include "flang/Semantics/type.h"
25
26namespace Fortran::evaluate {
27using ActualArgumentRef = common::Reference<const ActualArgument>;
28
29inline bool operator<(ActualArgumentRef x, ActualArgumentRef y) {
30 return &*x < &*y;
31}
32} // namespace Fortran::evaluate
33
34namespace Fortran::semantics {
35
36using namespace parser::literals;
37
38using Bounds = parser::LoopControl::Bounds;
39using IndexVarKind = SemanticsContext::IndexVarKind;
40
41static const parser::ConcurrentHeader &GetConcurrentHeader(
42 const parser::LoopControl &loopControl) {
43 const auto &concurrent{
44 std::get<parser::LoopControl::Concurrent>(loopControl.u)};
45 return std::get<parser::ConcurrentHeader>(concurrent.t);
46}
47static const parser::ConcurrentHeader &GetConcurrentHeader(
48 const parser::ForallConstruct &construct) {
49 const auto &stmt{
50 std::get<parser::Statement<parser::ForallConstructStmt>>(construct.t)};
51 return std::get<common::Indirection<parser::ConcurrentHeader>>(
52 stmt.statement.t)
53 .value();
54}
55static const parser::ConcurrentHeader &GetConcurrentHeader(
56 const parser::ForallStmt &stmt) {
57 return std::get<common::Indirection<parser::ConcurrentHeader>>(stmt.t)
58 .value();
59}
60template <typename T>
61static const std::list<parser::ConcurrentControl> &GetControls(const T &x) {
62 return std::get<std::list<parser::ConcurrentControl>>(
63 GetConcurrentHeader(x).t);
64}
65
66static const Bounds &GetBounds(const parser::DoConstruct &doConstruct) {
67 auto &loopControl{doConstruct.GetLoopControl().value()};
68 return std::get<Bounds>(loopControl.u);
69}
70
71static const parser::Name &GetDoVariable(
72 const parser::DoConstruct &doConstruct) {
73 const Bounds &bounds{GetBounds(doConstruct)};
74 return bounds.name.thing;
75}
76
77static parser::MessageFixedText GetEnclosingDoMsg() {
78 return "Enclosing DO CONCURRENT statement"_en_US;
79}
80
81static void SayWithDo(SemanticsContext &context, parser::CharBlock stmtLocation,
82 parser::MessageFixedText &&message, parser::CharBlock doLocation) {
83 context.Say(stmtLocation, message).Attach(doLocation, GetEnclosingDoMsg());
84}
85
86// 11.1.7.5 - enforce semantics constraints on a DO CONCURRENT loop body
87class DoConcurrentBodyEnforce {
88public:
89 DoConcurrentBodyEnforce(
90 SemanticsContext &context, parser::CharBlock doConcurrentSourcePosition)
91 : context_{context},
92 doConcurrentSourcePosition_{doConcurrentSourcePosition} {}
93 std::set<parser::Label> labels() { return labels_; }
94 template <typename T> bool Pre(const T &x) {
95 if (const auto *expr{GetExpr(context_, x)}) {
96 if (auto bad{FindImpureCall(context_.foldingContext(), *expr)}) {
97 context_.Say(currentStatementSourcePosition_,
98 "Impure procedure '%s' may not be referenced in DO CONCURRENT"_err_en_US,
99 *bad);
100 }
101 }
102 return true;
103 }
104 template <typename T> bool Pre(const parser::Statement<T> &statement) {
105 currentStatementSourcePosition_ = statement.source;
106 if (statement.label.has_value()) {
107 labels_.insert(*statement.label);
108 }
109 return true;
110 }
111 template <typename T> bool Pre(const parser::UnlabeledStatement<T> &stmt) {
112 currentStatementSourcePosition_ = stmt.source;
113 return true;
114 }
115 bool Pre(const parser::CallStmt &x) {
116 if (x.typedCall.get()) {
117 if (auto bad{FindImpureCall(context_.foldingContext(), *x.typedCall)}) {
118 context_.Say(currentStatementSourcePosition_,
119 "Impure procedure '%s' may not be referenced in DO CONCURRENT"_err_en_US,
120 *bad);
121 }
122 }
123 return true;
124 }
125 bool Pre(const parser::ConcurrentHeader &) {
126 // handled in CheckConcurrentHeader
127 return false;
128 }
129 template <typename T> void Post(const T &) {}
130
131 // C1140 -- Can't deallocate a polymorphic entity in a DO CONCURRENT.
132 // Deallocation can be caused by exiting a block that declares an allocatable
133 // entity, assignment to an allocatable variable, or an actual DEALLOCATE
134 // statement
135 //
136 // Note also that the deallocation of a derived type entity might cause the
137 // invocation of an IMPURE final subroutine. (C1139)
138 //
139
140 // Predicate for deallocations caused by block exit and direct deallocation
141 static bool DeallocateAll(const Symbol &) { return true; }
142
143 // Predicate for deallocations caused by intrinsic assignment
144 static bool DeallocateNonCoarray(const Symbol &component) {
145 return !evaluate::IsCoarray(component);
146 }
147
148 static bool WillDeallocatePolymorphic(const Symbol &entity,
149 const std::function<bool(const Symbol &)> &WillDeallocate) {
150 return WillDeallocate(entity) && IsPolymorphicAllocatable(entity);
151 }
152
153 // Is it possible that we will we deallocate a polymorphic entity or one
154 // of its components?
155 static bool MightDeallocatePolymorphic(const Symbol &original,
156 const std::function<bool(const Symbol &)> &WillDeallocate) {
157 const Symbol &symbol{
158 ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
159 // Check the entity itself, no coarray exception here
160 if (IsPolymorphicAllocatable(symbol)) {
161 return true;
162 }
163 // Check the components
164 if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
165 if (const DeclTypeSpec * entityType{details->type()}) {
166 if (const DerivedTypeSpec * derivedType{entityType->AsDerived()}) {
167 UltimateComponentIterator ultimates{*derivedType};
168 for (const auto &ultimate : ultimates) {
169 if (WillDeallocatePolymorphic(ultimate, WillDeallocate)) {
170 return true;
171 }
172 }
173 }
174 }
175 }
176 return false;
177 }
178
179 void SayDeallocateWithImpureFinal(
180 const Symbol &entity, const char *reason, const Symbol &impure) {
181 context_.SayWithDecl(entity, currentStatementSourcePosition_,
182 "Deallocation of an entity with an IMPURE FINAL procedure '%s' caused by %s not allowed in DO CONCURRENT"_err_en_US,
183 impure.name(), reason);
184 }
185
186 void SayDeallocateOfPolymorphic(
187 parser::CharBlock location, const Symbol &entity, const char *reason) {
188 context_.SayWithDecl(entity, location,
189 "Deallocation of a polymorphic entity caused by %s not allowed in DO CONCURRENT"_err_en_US,
190 reason);
191 }
192
193 // Deallocation caused by block exit
194 // Allocatable entities and all of their allocatable subcomponents will be
195 // deallocated. This test is different from the other two because it does
196 // not deallocate in cases where the entity itself is not allocatable but
197 // has allocatable polymorphic components
198 void Post(const parser::BlockConstruct &blockConstruct) {
199 const auto &endBlockStmt{
200 std::get<parser::Statement<parser::EndBlockStmt>>(blockConstruct.t)};
201 const Scope &blockScope{context_.FindScope(endBlockStmt.source)};
202 const Scope &doScope{context_.FindScope(doConcurrentSourcePosition_)};
203 if (DoesScopeContain(&doScope, blockScope)) {
204 const char *reason{"block exit"};
205 for (auto &pair : blockScope) {
206 const Symbol &entity{*pair.second};
207 if (IsAllocatable(entity) && !IsSaved(entity) &&
208 MightDeallocatePolymorphic(entity, DeallocateAll)) {
209 SayDeallocateOfPolymorphic(endBlockStmt.source, entity, reason);
210 }
211 if (const Symbol * impure{HasImpureFinal(entity)}) {
212 SayDeallocateWithImpureFinal(entity, reason, *impure);
213 }
214 }
215 }
216 }
217
218 // Deallocation caused by assignment
219 // Note that this case does not cause deallocation of coarray components
220 void Post(const parser::AssignmentStmt &stmt) {
221 const auto &variable{std::get<parser::Variable>(stmt.t)};
222 if (const Symbol * entity{GetLastName(variable).symbol}) {
223 const char *reason{"assignment"};
224 if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) {
225 SayDeallocateOfPolymorphic(variable.GetSource(), *entity, reason);
226 }
227 if (const auto *assignment{GetAssignment(stmt)}) {
228 const auto &lhs{assignment->lhs};
229 if (const Symbol * impure{HasImpureFinal(*entity, lhs.Rank())}) {
230 SayDeallocateWithImpureFinal(entity: *entity, reason, impure: *impure);
231 }
232 }
233 }
234 if (const auto *assignment{GetAssignment(stmt)}) {
235 if (const auto *call{
236 std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {
237 if (auto bad{FindImpureCall(context_.foldingContext(), *call)}) {
238 context_.Say(currentStatementSourcePosition_,
239 "The defined assignment subroutine '%s' is not pure"_err_en_US,
240 *bad);
241 }
242 }
243 }
244 }
245
246 // Deallocation from a DEALLOCATE statement
247 // This case is different because DEALLOCATE statements deallocate both
248 // ALLOCATABLE and POINTER entities
249 void Post(const parser::DeallocateStmt &stmt) {
250 const auto &allocateObjectList{
251 std::get<std::list<parser::AllocateObject>>(stmt.t)};
252 for (const auto &allocateObject : allocateObjectList) {
253 const parser::Name &name{GetLastName(allocateObject)};
254 const char *reason{"a DEALLOCATE statement"};
255 if (name.symbol) {
256 const Symbol &entity{*name.symbol};
257 const DeclTypeSpec *entityType{entity.GetType()};
258 if ((entityType && entityType->IsPolymorphic()) || // POINTER case
259 MightDeallocatePolymorphic(entity, DeallocateAll)) {
260 SayDeallocateOfPolymorphic(
261 currentStatementSourcePosition_, entity, reason);
262 }
263 if (const Symbol * impure{HasImpureFinal(entity)}) {
264 SayDeallocateWithImpureFinal(entity, reason, *impure);
265 }
266 }
267 }
268 }
269
270 // C1137 -- No image control statements in a DO CONCURRENT
271 void Post(const parser::ExecutableConstruct &construct) {
272 if (IsImageControlStmt(construct)) {
273 const parser::CharBlock statementLocation{
274 GetImageControlStmtLocation(construct)};
275 auto &msg{context_.Say(statementLocation,
276 "An image control statement is not allowed in DO CONCURRENT"_err_en_US)};
277 if (auto coarrayMsg{GetImageControlStmtCoarrayMsg(construct)}) {
278 msg.Attach(statementLocation, *coarrayMsg);
279 }
280 msg.Attach(doConcurrentSourcePosition_, GetEnclosingDoMsg());
281 }
282 }
283
284 // C1136 -- No RETURN statements in a DO CONCURRENT
285 void Post(const parser::ReturnStmt &) {
286 context_
287 .Say(currentStatementSourcePosition_,
288 "RETURN is not allowed in DO CONCURRENT"_err_en_US)
289 .Attach(doConcurrentSourcePosition_, GetEnclosingDoMsg());
290 }
291
292 // C1145, C1146: cannot call ieee_[gs]et_flag, ieee_[gs]et_halting_mode,
293 // ieee_[gs]et_status, ieee_set_rounding_mode, or ieee_set_underflow_mode
294 void Post(const parser::ProcedureDesignator &procedureDesignator) {
295 if (auto *name{std::get_if<parser::Name>(&procedureDesignator.u)}) {
296 if (name->symbol) {
297 const Symbol &ultimate{name->symbol->GetUltimate()};
298 const Scope &scope{ultimate.owner()};
299 if (const Symbol * module{scope.IsModule() ? scope.symbol() : nullptr};
300 module &&
301 (module->name() == "__fortran_ieee_arithmetic" ||
302 module->name() == "__fortran_ieee_exceptions")) {
303 std::string s{ultimate.name().ToString()};
304 static constexpr const char *badName[]{"ieee_get_flag",
305 "ieee_set_flag", "ieee_get_halting_mode", "ieee_set_halting_mode",
306 "ieee_get_status", "ieee_set_status", "ieee_set_rounding_mode",
307 "ieee_set_underflow_mode", nullptr};
308 for (std::size_t j{0}; badName[j]; ++j) {
309 if (s.find(badName[j]) != s.npos) {
310 context_
311 .Say(name->source,
312 "'%s' may not be called in DO CONCURRENT"_err_en_US,
313 badName[j])
314 .Attach(doConcurrentSourcePosition_, GetEnclosingDoMsg());
315 break;
316 }
317 }
318 }
319 }
320 }
321 }
322
323 // 11.1.7.5, paragraph 5, no ADVANCE specifier in a DO CONCURRENT
324 void Post(const parser::IoControlSpec &ioControlSpec) {
325 if (auto *charExpr{
326 std::get_if<parser::IoControlSpec::CharExpr>(&ioControlSpec.u)}) {
327 if (std::get<parser::IoControlSpec::CharExpr::Kind>(charExpr->t) ==
328 parser::IoControlSpec::CharExpr::Kind::Advance) {
329 SayWithDo(context_, currentStatementSourcePosition_,
330 "ADVANCE specifier is not allowed in DO"
331 " CONCURRENT"_err_en_US,
332 doConcurrentSourcePosition_);
333 }
334 }
335 }
336
337private:
338 std::set<parser::Label> labels_;
339 parser::CharBlock currentStatementSourcePosition_;
340 SemanticsContext &context_;
341 parser::CharBlock doConcurrentSourcePosition_;
342}; // class DoConcurrentBodyEnforce
343
344// Class for enforcing C1130 -- in a DO CONCURRENT with DEFAULT(NONE),
345// variables from enclosing scopes must have their locality specified
346class DoConcurrentVariableEnforce {
347public:
348 DoConcurrentVariableEnforce(
349 SemanticsContext &context, parser::CharBlock doConcurrentSourcePosition)
350 : context_{context},
351 doConcurrentSourcePosition_{doConcurrentSourcePosition},
352 blockScope_{context.FindScope(doConcurrentSourcePosition_)} {}
353
354 template <typename T> bool Pre(const T &) { return true; }
355 template <typename T> void Post(const T &) {}
356
357 // Check to see if the name is a variable from an enclosing scope
358 void Post(const parser::Name &name) {
359 if (const Symbol * symbol{name.symbol}) {
360 if (IsVariableName(*symbol)) {
361 const Scope &variableScope{symbol->owner()};
362 if (DoesScopeContain(&variableScope, blockScope_)) {
363 context_.SayWithDecl(*symbol, name.source,
364 "Variable '%s' from an enclosing scope referenced in DO "
365 "CONCURRENT with DEFAULT(NONE) must appear in a "
366 "locality-spec"_err_en_US,
367 symbol->name());
368 }
369 }
370 }
371 }
372
373private:
374 SemanticsContext &context_;
375 parser::CharBlock doConcurrentSourcePosition_;
376 const Scope &blockScope_;
377}; // class DoConcurrentVariableEnforce
378
379// Find a DO or FORALL and enforce semantics checks on its body
380class DoContext {
381public:
382 DoContext(SemanticsContext &context, IndexVarKind kind,
383 const std::list<IndexVarKind> nesting)
384 : context_{context}, kind_{kind} {
385 if (!nesting.empty()) {
386 concurrentNesting_ = nesting.back();
387 }
388 }
389
390 // Mark this DO construct as a point of definition for the DO variables
391 // or index-names it contains. If they're already defined, emit an error
392 // message. We need to remember both the variable and the source location of
393 // the variable in the DO construct so that we can remove it when we leave
394 // the DO construct and use its location in error messages.
395 void DefineDoVariables(const parser::DoConstruct &doConstruct) {
396 if (doConstruct.IsDoNormal()) {
397 context_.ActivateIndexVar(GetDoVariable(doConstruct), IndexVarKind::DO);
398 } else if (doConstruct.IsDoConcurrent()) {
399 if (const auto &loopControl{doConstruct.GetLoopControl()}) {
400 ActivateIndexVars(GetControls(*loopControl));
401 }
402 }
403 }
404
405 // Called at the end of a DO construct to deactivate the DO construct
406 void ResetDoVariables(const parser::DoConstruct &doConstruct) {
407 if (doConstruct.IsDoNormal()) {
408 context_.DeactivateIndexVar(GetDoVariable(doConstruct));
409 } else if (doConstruct.IsDoConcurrent()) {
410 if (const auto &loopControl{doConstruct.GetLoopControl()}) {
411 DeactivateIndexVars(GetControls(*loopControl));
412 }
413 }
414 }
415
416 void ActivateIndexVars(const std::list<parser::ConcurrentControl> &controls) {
417 for (const auto &control : controls) {
418 context_.ActivateIndexVar(std::get<parser::Name>(control.t), kind_);
419 }
420 }
421 void DeactivateIndexVars(
422 const std::list<parser::ConcurrentControl> &controls) {
423 for (const auto &control : controls) {
424 context_.DeactivateIndexVar(std::get<parser::Name>(control.t));
425 }
426 }
427
428 void Check(const parser::DoConstruct &doConstruct) {
429 if (doConstruct.IsDoConcurrent()) {
430 CheckDoConcurrent(doConstruct);
431 } else if (doConstruct.IsDoNormal()) {
432 CheckDoNormal(doConstruct);
433 } else {
434 // TODO: handle the other cases
435 }
436 }
437
438 void Check(const parser::ForallStmt &stmt) {
439 CheckConcurrentHeader(GetConcurrentHeader(stmt));
440 }
441 void Check(const parser::ForallConstruct &construct) {
442 CheckConcurrentHeader(GetConcurrentHeader(construct));
443 }
444
445 void Check(const parser::ForallAssignmentStmt &stmt) {
446 if (const evaluate::Assignment *
447 assignment{common::visit(
448 common::visitors{[&](const auto &x) { return GetAssignment(x); }},
449 stmt.u)}) {
450 CheckForallIndexesUsed(*assignment);
451 CheckForImpureCall(assignment->lhs, kind_);
452 CheckForImpureCall(assignment->rhs, kind_);
453
454 if (IsVariable(assignment->lhs)) {
455 if (const Symbol * symbol{GetLastSymbol(assignment->lhs)}) {
456 if (auto impureFinal{
457 HasImpureFinal(*symbol, assignment->lhs.Rank())}) {
458 context_.SayWithDecl(*symbol, parser::FindSourceLocation(stmt),
459 "Impure procedure '%s' is referenced by finalization in a %s"_err_en_US,
460 impureFinal->name(), LoopKindName());
461 }
462 }
463 }
464
465 if (const auto *proc{
466 std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {
467 CheckForImpureCall(*proc, kind_);
468 }
469 common::visit(
470 common::visitors{
471 [](const evaluate::Assignment::Intrinsic &) {},
472 [&](const evaluate::ProcedureRef &proc) {
473 CheckForImpureCall(proc, kind_);
474 },
475 [&](const evaluate::Assignment::BoundsSpec &bounds) {
476 for (const auto &bound : bounds) {
477 CheckForImpureCall(SomeExpr{bound}, kind_);
478 }
479 },
480 [&](const evaluate::Assignment::BoundsRemapping &bounds) {
481 for (const auto &bound : bounds) {
482 CheckForImpureCall(SomeExpr{bound.first}, kind_);
483 CheckForImpureCall(SomeExpr{bound.second}, kind_);
484 }
485 },
486 },
487 assignment->u);
488 }
489 }
490
491private:
492 void SayBadDoControl(parser::CharBlock sourceLocation) {
493 context_.Say(sourceLocation, "DO controls should be INTEGER"_err_en_US);
494 }
495
496 void CheckDoControl(const parser::CharBlock &sourceLocation, bool isReal) {
497 if (isReal) {
498 context_.Warn(common::LanguageFeature::RealDoControls, sourceLocation,
499 "DO controls should be INTEGER"_port_en_US);
500 } else {
501 SayBadDoControl(sourceLocation);
502 }
503 }
504
505 void CheckDoVariable(const parser::ScalarName &scalarName) {
506 const parser::CharBlock &sourceLocation{scalarName.thing.source};
507 if (const Symbol * symbol{scalarName.thing.symbol}) {
508 if (!IsVariableName(*symbol)) {
509 context_.Say(
510 sourceLocation, "DO control must be an INTEGER variable"_err_en_US);
511 } else if (auto why{WhyNotDefinable(sourceLocation,
512 context_.FindScope(sourceLocation), DefinabilityFlags{},
513 *symbol)}) {
514 context_
515 .Say(sourceLocation,
516 "'%s' may not be used as a DO variable"_err_en_US,
517 symbol->name())
518 .Attach(std::move(why->set_severity(parser::Severity::Because)));
519 } else {
520 const DeclTypeSpec *symType{symbol->GetType()};
521 if (!symType) {
522 SayBadDoControl(sourceLocation);
523 } else {
524 if (!symType->IsNumeric(TypeCategory::Integer)) {
525 CheckDoControl(
526 sourceLocation, symType->IsNumeric(TypeCategory::Real));
527 }
528 }
529 } // No messages for INTEGER
530 }
531 }
532
533 // Semantic checks for the limit and step expressions
534 void CheckDoExpression(const parser::ScalarExpr &scalarExpression) {
535 if (const SomeExpr * expr{GetExpr(context_, scalarExpression)}) {
536 if (!ExprHasTypeCategory(*expr, TypeCategory::Integer)) {
537 // No warnings or errors for type INTEGER
538 const parser::CharBlock &loc{scalarExpression.thing.value().source};
539 CheckDoControl(loc, ExprHasTypeCategory(*expr, TypeCategory::Real));
540 }
541 }
542 }
543
544 void CheckDoNormal(const parser::DoConstruct &doConstruct) {
545 // C1120 -- types of DO variables must be INTEGER, extended by allowing
546 // REAL and DOUBLE PRECISION
547 const Bounds &bounds{GetBounds(doConstruct)};
548 CheckDoVariable(bounds.name);
549 CheckDoExpression(bounds.lower);
550 CheckDoExpression(bounds.upper);
551 if (bounds.step) {
552 CheckDoExpression(*bounds.step);
553 if (IsZero(*bounds.step)) {
554 context_.Warn(common::UsageWarning::ZeroDoStep,
555 bounds.step->thing.value().source,
556 "DO step expression should not be zero"_warn_en_US);
557 }
558 }
559 }
560
561 void CheckDoConcurrent(const parser::DoConstruct &doConstruct) {
562 auto &doStmt{
563 std::get<parser::Statement<parser::NonLabelDoStmt>>(doConstruct.t)};
564 currentStatementSourcePosition_ = doStmt.source;
565
566 const parser::Block &block{std::get<parser::Block>(doConstruct.t)};
567 DoConcurrentBodyEnforce doConcurrentBodyEnforce{context_, doStmt.source};
568 parser::Walk(block, doConcurrentBodyEnforce);
569
570 LabelEnforce doConcurrentLabelEnforce{context_,
571 doConcurrentBodyEnforce.labels(), currentStatementSourcePosition_,
572 "DO CONCURRENT"};
573 parser::Walk(block, doConcurrentLabelEnforce);
574
575 const auto &loopControl{doConstruct.GetLoopControl()};
576 CheckConcurrentLoopControl(*loopControl);
577 CheckLocalitySpecs(*loopControl, block);
578 }
579
580 // Return a set of symbols whose names are in a Local locality-spec. Look
581 // the names up in the scope that encloses the DO construct to avoid getting
582 // the local versions of them. Then follow the host-, use-, and
583 // construct-associations to get the root symbols
584 UnorderedSymbolSet GatherLocals(
585 const std::list<parser::LocalitySpec> &localitySpecs) const {
586 UnorderedSymbolSet symbols;
587 const Scope &parentScope{
588 context_.FindScope(currentStatementSourcePosition_).parent()};
589 // Loop through the LocalitySpec::Local locality-specs
590 for (const auto &ls : localitySpecs) {
591 if (const auto *names{std::get_if<parser::LocalitySpec::Local>(&ls.u)}) {
592 // Loop through the names in the Local locality-spec getting their
593 // symbols
594 for (const parser::Name &name : names->v) {
595 if (const Symbol * symbol{parentScope.FindSymbol(name.source)}) {
596 symbols.insert(ResolveAssociations(*symbol));
597 }
598 }
599 }
600 }
601 return symbols;
602 }
603
604 UnorderedSymbolSet GatherSymbolsFromExpression(
605 const parser::Expr &expression) const {
606 UnorderedSymbolSet result;
607 if (const auto *expr{GetExpr(context_, expression)}) {
608 for (const Symbol &symbol : evaluate::CollectSymbols(*expr)) {
609 result.insert(ResolveAssociations(symbol));
610 }
611 }
612 return result;
613 }
614
615 // C1121 - procedures in mask must be pure
616 void CheckMaskIsPure(const parser::ScalarLogicalExpr &mask) const {
617 UnorderedSymbolSet references{
618 GatherSymbolsFromExpression(mask.thing.thing.value())};
619 for (const Symbol &ref : OrderBySourcePosition(references)) {
620 if (IsProcedure(ref) && !IsPureProcedure(ref)) {
621 context_.SayWithDecl(ref, parser::Unwrap<parser::Expr>(mask)->source,
622 "%s mask expression may not reference impure procedure '%s'"_err_en_US,
623 LoopKindName(), ref.name());
624 return;
625 }
626 }
627 }
628
629 void CheckNoCollisions(const UnorderedSymbolSet &refs,
630 const UnorderedSymbolSet &uses, parser::MessageFixedText &&errorMessage,
631 const parser::CharBlock &refPosition) const {
632 for (const Symbol &ref : OrderBySourcePosition(refs)) {
633 if (uses.find(ref) != uses.end()) {
634 context_.SayWithDecl(ref, refPosition, std::move(errorMessage),
635 LoopKindName(), ref.name());
636 return;
637 }
638 }
639 }
640
641 void HasNoReferences(const UnorderedSymbolSet &indexNames,
642 const parser::ScalarIntExpr &expr) const {
643 CheckNoCollisions(GatherSymbolsFromExpression(expr.thing.thing.value()),
644 indexNames,
645 "%s limit expression may not reference index variable '%s'"_err_en_US,
646 expr.thing.thing.value().source);
647 }
648
649 // C1129, names in local locality-specs can't be in mask expressions
650 void CheckMaskDoesNotReferenceLocal(const parser::ScalarLogicalExpr &mask,
651 const UnorderedSymbolSet &localVars) const {
652 CheckNoCollisions(GatherSymbolsFromExpression(mask.thing.thing.value()),
653 localVars,
654 "%s mask expression references variable '%s'"
655 " in LOCAL locality-spec"_err_en_US,
656 mask.thing.thing.value().source);
657 }
658
659 // C1129, names in local locality-specs can't be in limit or step
660 // expressions
661 void CheckExprDoesNotReferenceLocal(const parser::ScalarIntExpr &expr,
662 const UnorderedSymbolSet &localVars) const {
663 CheckNoCollisions(GatherSymbolsFromExpression(expr.thing.thing.value()),
664 localVars,
665 "%s expression references variable '%s'"
666 " in LOCAL locality-spec"_err_en_US,
667 expr.thing.thing.value().source);
668 }
669
670 // C1130, DEFAULT(NONE) locality requires names to be in locality-specs to
671 // be used in the body of the DO loop
672 void CheckDefaultNoneImpliesExplicitLocality(
673 const std::list<parser::LocalitySpec> &localitySpecs,
674 const parser::Block &block) const {
675 bool hasDefaultNone{false};
676 for (auto &ls : localitySpecs) {
677 if (std::holds_alternative<parser::LocalitySpec::DefaultNone>(ls.u)) {
678 if (hasDefaultNone) {
679 // F'2023 C1129, you can only have one DEFAULT(NONE)
680 context_.Warn(common::LanguageFeature::BenignRedundancy,
681 currentStatementSourcePosition_,
682 "Only one DEFAULT(NONE) may appear"_port_en_US);
683 break;
684 }
685 hasDefaultNone = true;
686 }
687 }
688 if (hasDefaultNone) {
689 DoConcurrentVariableEnforce doConcurrentVariableEnforce{
690 context_, currentStatementSourcePosition_};
691 parser::Walk(block, doConcurrentVariableEnforce);
692 }
693 }
694
695 void CheckReduce(const parser::LocalitySpec::Reduce &reduce) const {
696 const parser::ReductionOperator &reductionOperator{
697 std::get<parser::ReductionOperator>(reduce.t)};
698 // F'2023 C1132, reduction variables should have suitable intrinsic type
699 for (const parser::Name &x : std::get<std::list<parser::Name>>(reduce.t)) {
700 bool supportedIdentifier{false};
701 if (x.symbol && x.symbol->GetType()) {
702 const auto *type{x.symbol->GetType()};
703 auto typeMismatch{[&](const char *suitable_types) {
704 context_.Say(currentStatementSourcePosition_,
705 "Reduction variable '%s' ('%s') does not have a suitable type ('%s')."_err_en_US,
706 x.symbol->name(), type->AsFortran(), suitable_types);
707 }};
708 supportedIdentifier = true;
709 switch (reductionOperator.v) {
710 case parser::ReductionOperator::Operator::Plus:
711 case parser::ReductionOperator::Operator::Multiply:
712 if (!(type->IsNumeric(TypeCategory::Complex) ||
713 type->IsNumeric(TypeCategory::Integer) ||
714 type->IsNumeric(TypeCategory::Real))) {
715 typeMismatch("COMPLEX', 'INTEGER', or 'REAL");
716 }
717 break;
718 case parser::ReductionOperator::Operator::And:
719 case parser::ReductionOperator::Operator::Or:
720 case parser::ReductionOperator::Operator::Eqv:
721 case parser::ReductionOperator::Operator::Neqv:
722 if (type->category() != DeclTypeSpec::Category::Logical) {
723 typeMismatch("LOGICAL");
724 }
725 break;
726 case parser::ReductionOperator::Operator::Max:
727 case parser::ReductionOperator::Operator::Min:
728 if (!(type->IsNumeric(TypeCategory::Integer) ||
729 type->IsNumeric(TypeCategory::Real))) {
730 typeMismatch("INTEGER', or 'REAL");
731 }
732 break;
733 case parser::ReductionOperator::Operator::Iand:
734 case parser::ReductionOperator::Operator::Ior:
735 case parser::ReductionOperator::Operator::Ieor:
736 if (!type->IsNumeric(TypeCategory::Integer)) {
737 typeMismatch("INTEGER");
738 }
739 break;
740 }
741 }
742 if (!supportedIdentifier) {
743 context_.Say(currentStatementSourcePosition_,
744 "Invalid identifier in REDUCE clause."_err_en_US);
745 }
746 }
747 }
748
749 // C1123, concurrent limit or step expressions can't reference index-names
750 void CheckConcurrentHeader(const parser::ConcurrentHeader &header) const {
751 if (const auto &mask{
752 std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)}) {
753 CheckMaskIsPure(*mask);
754 }
755 const auto &controls{
756 std::get<std::list<parser::ConcurrentControl>>(header.t)};
757 UnorderedSymbolSet indexNames;
758 for (const parser::ConcurrentControl &control : controls) {
759 const auto &indexName{std::get<parser::Name>(control.t)};
760 if (indexName.symbol) {
761 indexNames.insert(*indexName.symbol);
762 }
763 CheckForImpureCall(std::get<1>(control.t), concurrentNesting_);
764 CheckForImpureCall(std::get<2>(control.t), concurrentNesting_);
765 if (const auto &stride{std::get<3>(control.t)}) {
766 CheckForImpureCall(*stride, concurrentNesting_);
767 }
768 }
769 if (!indexNames.empty()) {
770 for (const parser::ConcurrentControl &control : controls) {
771 HasNoReferences(indexNames, std::get<1>(control.t));
772 HasNoReferences(indexNames, std::get<2>(control.t));
773 if (const auto &intExpr{
774 std::get<std::optional<parser::ScalarIntExpr>>(control.t)}) {
775 const parser::Expr &expr{intExpr->thing.thing.value()};
776 CheckNoCollisions(GatherSymbolsFromExpression(expr), indexNames,
777 "%s step expression may not reference index variable '%s'"_err_en_US,
778 expr.source);
779 if (IsZero(expr)) {
780 context_.Say(expr.source,
781 "%s step expression may not be zero"_err_en_US, LoopKindName());
782 }
783 }
784 }
785 }
786 }
787
788 void CheckLocalitySpecs(
789 const parser::LoopControl &control, const parser::Block &block) const {
790 const auto &concurrent{
791 std::get<parser::LoopControl::Concurrent>(control.u)};
792 const auto &header{std::get<parser::ConcurrentHeader>(concurrent.t)};
793 const auto &localitySpecs{
794 std::get<std::list<parser::LocalitySpec>>(concurrent.t)};
795 if (!localitySpecs.empty()) {
796 const UnorderedSymbolSet &localVars{GatherLocals(localitySpecs)};
797 for (const auto &c : GetControls(control)) {
798 CheckExprDoesNotReferenceLocal(std::get<1>(c.t), localVars);
799 CheckExprDoesNotReferenceLocal(std::get<2>(c.t), localVars);
800 if (const auto &expr{
801 std::get<std::optional<parser::ScalarIntExpr>>(c.t)}) {
802 CheckExprDoesNotReferenceLocal(*expr, localVars);
803 }
804 }
805 if (const auto &mask{
806 std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)}) {
807 CheckMaskDoesNotReferenceLocal(*mask, localVars);
808 }
809 for (auto &ls : localitySpecs) {
810 if (const auto *reduce{
811 std::get_if<parser::LocalitySpec::Reduce>(&ls.u)}) {
812 CheckReduce(*reduce);
813 }
814 }
815 CheckDefaultNoneImpliesExplicitLocality(localitySpecs, block);
816 }
817 }
818
819 // check constraints [C1121 .. C1130]
820 void CheckConcurrentLoopControl(const parser::LoopControl &control) const {
821 const auto &concurrent{
822 std::get<parser::LoopControl::Concurrent>(control.u)};
823 CheckConcurrentHeader(std::get<parser::ConcurrentHeader>(concurrent.t));
824 }
825
826 template <typename T>
827 void CheckForImpureCall(
828 const T &x, std::optional<IndexVarKind> nesting) const {
829 if (auto bad{FindImpureCall(context_.foldingContext(), x)}) {
830 if (nesting) {
831 context_.Say(
832 "Impure procedure '%s' may not be referenced in a %s"_err_en_US,
833 *bad, LoopKindName(*nesting));
834 } else {
835 context_.Say(
836 "Impure procedure '%s' should not be referenced in a %s header"_warn_en_US,
837 *bad, LoopKindName(kind_));
838 }
839 }
840 }
841 void CheckForImpureCall(const parser::ScalarIntExpr &x,
842 std::optional<IndexVarKind> nesting) const {
843 const auto &parsedExpr{x.thing.thing.value()};
844 auto oldLocation{context_.location()};
845 context_.set_location(parsedExpr.source);
846 if (const auto &typedExpr{parsedExpr.typedExpr}) {
847 if (const auto &expr{typedExpr->v}) {
848 CheckForImpureCall(*expr, nesting);
849 }
850 }
851 context_.set_location(oldLocation);
852 }
853
854 // Each index should be used on the LHS of each assignment in a FORALL
855 void CheckForallIndexesUsed(const evaluate::Assignment &assignment) {
856 SymbolVector indexVars{context_.GetIndexVars(IndexVarKind::FORALL)};
857 if (!indexVars.empty()) {
858 UnorderedSymbolSet symbols{evaluate::CollectSymbols(assignment.lhs)};
859 common::visit(
860 common::visitors{
861 [&](const evaluate::Assignment::BoundsSpec &spec) {
862 for (const auto &bound : spec) {
863// TODO: this is working around missing std::set::merge in some versions of
864// clang that we are building with
865#ifdef __clang__
866 auto boundSymbols{evaluate::CollectSymbols(bound)};
867 symbols.insert(boundSymbols.begin(), boundSymbols.end());
868#else
869 symbols.merge(evaluate::CollectSymbols(bound));
870#endif
871 }
872 },
873 [&](const evaluate::Assignment::BoundsRemapping &remapping) {
874 for (const auto &bounds : remapping) {
875#ifdef __clang__
876 auto lbSymbols{evaluate::CollectSymbols(bounds.first)};
877 symbols.insert(lbSymbols.begin(), lbSymbols.end());
878 auto ubSymbols{evaluate::CollectSymbols(bounds.second)};
879 symbols.insert(ubSymbols.begin(), ubSymbols.end());
880#else
881 symbols.merge(evaluate::CollectSymbols(bounds.first));
882 symbols.merge(evaluate::CollectSymbols(bounds.second));
883#endif
884 }
885 },
886 [](const auto &) {},
887 },
888 assignment.u);
889 for (const Symbol &index : indexVars) {
890 if (symbols.count(index) == 0) {
891 context_.Warn(common::UsageWarning::UnusedForallIndex,
892 "FORALL index variable '%s' not used on left-hand side of assignment"_warn_en_US,
893 index.name());
894 }
895 }
896 }
897 }
898
899 // For messages where the DO loop must be DO CONCURRENT, make that explicit.
900 const char *LoopKindName(IndexVarKind kind) const {
901 return kind == IndexVarKind::DO ? "DO CONCURRENT" : "FORALL";
902 }
903 const char *LoopKindName() const { return LoopKindName(kind_); }
904
905 SemanticsContext &context_;
906 const IndexVarKind kind_;
907 parser::CharBlock currentStatementSourcePosition_;
908 std::optional<IndexVarKind> concurrentNesting_;
909}; // class DoContext
910
911void DoForallChecker::Enter(const parser::DoConstruct &doConstruct) {
912 DoContext doContext{context_, IndexVarKind::DO, nestedWithinConcurrent_};
913 if (doConstruct.IsDoConcurrent()) {
914 nestedWithinConcurrent_.push_back(IndexVarKind::DO);
915 }
916 doContext.DefineDoVariables(doConstruct);
917 doContext.Check(doConstruct);
918}
919
920void DoForallChecker::Leave(const parser::DoConstruct &doConstruct) {
921 DoContext doContext{context_, IndexVarKind::DO, nestedWithinConcurrent_};
922 doContext.ResetDoVariables(doConstruct);
923 if (doConstruct.IsDoConcurrent()) {
924 nestedWithinConcurrent_.pop_back();
925 }
926}
927
928void DoForallChecker::Enter(const parser::ForallConstruct &construct) {
929 DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
930 doContext.ActivateIndexVars(GetControls(construct));
931 nestedWithinConcurrent_.push_back(IndexVarKind::FORALL);
932 doContext.Check(construct);
933}
934void DoForallChecker::Leave(const parser::ForallConstruct &construct) {
935 DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
936 doContext.DeactivateIndexVars(GetControls(construct));
937 nestedWithinConcurrent_.pop_back();
938}
939
940void DoForallChecker::Enter(const parser::ForallStmt &stmt) {
941 DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
942 nestedWithinConcurrent_.push_back(IndexVarKind::FORALL);
943 doContext.Check(stmt);
944 doContext.ActivateIndexVars(GetControls(stmt));
945}
946void DoForallChecker::Leave(const parser::ForallStmt &stmt) {
947 DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
948 doContext.DeactivateIndexVars(GetControls(stmt));
949 nestedWithinConcurrent_.pop_back();
950}
951void DoForallChecker::Leave(const parser::ForallAssignmentStmt &stmt) {
952 DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
953 doContext.Check(stmt);
954}
955
956template <typename A>
957static parser::CharBlock GetConstructPosition(const A &a) {
958 return std::get<0>(a.t).source;
959}
960
961static parser::CharBlock GetNodePosition(const ConstructNode &construct) {
962 return common::visit(
963 [&](const auto &x) { return GetConstructPosition(*x); }, construct);
964}
965
966void DoForallChecker::SayBadLeave(StmtType stmtType,
967 const char *enclosingStmtName, const ConstructNode &construct) const {
968 context_
969 .Say("%s must not leave a %s statement"_err_en_US, EnumToString(stmtType),
970 enclosingStmtName)
971 .Attach(GetNodePosition(construct), "The construct that was left"_en_US);
972}
973
974static const parser::DoConstruct *MaybeGetDoConstruct(
975 const ConstructNode &construct) {
976 if (const auto *doNode{
977 std::get_if<const parser::DoConstruct *>(&construct)}) {
978 return *doNode;
979 } else {
980 return nullptr;
981 }
982}
983
984static bool ConstructIsDoConcurrent(const ConstructNode &construct) {
985 const parser::DoConstruct *doConstruct{MaybeGetDoConstruct(construct)};
986 return doConstruct && doConstruct->IsDoConcurrent();
987}
988
989// Check that CYCLE and EXIT statements do not cause flow of control to
990// leave DO CONCURRENT, CRITICAL, or CHANGE TEAM constructs.
991void DoForallChecker::CheckForBadLeave(
992 StmtType stmtType, const ConstructNode &construct) const {
993 common::visit(common::visitors{
994 [&](const parser::DoConstruct *doConstructPtr) {
995 if (doConstructPtr->IsDoConcurrent()) {
996 // C1135 and C1167 -- CYCLE and EXIT statements can't
997 // leave a DO CONCURRENT
998 SayBadLeave(stmtType, "DO CONCURRENT", construct);
999 }
1000 },
1001 [&](const parser::CriticalConstruct *) {
1002 // C1135 and C1168 -- similarly, for CRITICAL
1003 SayBadLeave(stmtType, "CRITICAL", construct);
1004 },
1005 [&](const parser::ChangeTeamConstruct *) {
1006 // C1135 and C1168 -- similarly, for CHANGE TEAM
1007 SayBadLeave(stmtType, "CHANGE TEAM", construct);
1008 },
1009 [](const auto *) {},
1010 },
1011 construct);
1012}
1013
1014static bool StmtMatchesConstruct(const parser::Name *stmtName,
1015 StmtType stmtType, const std::optional<parser::Name> &constructName,
1016 const ConstructNode &construct) {
1017 bool inDoConstruct{MaybeGetDoConstruct(construct) != nullptr};
1018 if (!stmtName) {
1019 return inDoConstruct; // Unlabeled statements match all DO constructs
1020 } else if (constructName && constructName->source == stmtName->source) {
1021 return stmtType == StmtType::EXIT || inDoConstruct;
1022 } else {
1023 return false;
1024 }
1025}
1026
1027// C1167 Can't EXIT from a DO CONCURRENT
1028void DoForallChecker::CheckDoConcurrentExit(
1029 StmtType stmtType, const ConstructNode &construct) const {
1030 if (stmtType == StmtType::EXIT && ConstructIsDoConcurrent(construct)) {
1031 SayBadLeave(StmtType::EXIT, "DO CONCURRENT", construct);
1032 }
1033}
1034
1035// Check nesting violations for a CYCLE or EXIT statement. Loop up the
1036// nesting levels looking for a construct that matches the CYCLE or EXIT
1037// statment. At every construct, check for a violation. If we find a match
1038// without finding a violation, the check is complete.
1039void DoForallChecker::CheckNesting(
1040 StmtType stmtType, const parser::Name *stmtName) const {
1041 const ConstructStack &stack{context_.constructStack()};
1042 for (auto iter{stack.cend()}; iter-- != stack.cbegin();) {
1043 const ConstructNode &construct{*iter};
1044 const std::optional<parser::Name> &constructName{
1045 MaybeGetNodeName(construct)};
1046 if (StmtMatchesConstruct(stmtName, stmtType, constructName, construct)) {
1047 CheckDoConcurrentExit(stmtType, construct);
1048 return; // We got a match, so we're finished checking
1049 }
1050 CheckForBadLeave(stmtType, construct);
1051 }
1052
1053 // We haven't found a match in the enclosing constructs
1054 if (stmtType == StmtType::EXIT) {
1055 context_.Say("No matching construct for EXIT statement"_err_en_US);
1056 } else {
1057 context_.Say("No matching DO construct for CYCLE statement"_err_en_US);
1058 }
1059}
1060
1061// C1135 -- Nesting for CYCLE statements
1062void DoForallChecker::Enter(const parser::CycleStmt &cycleStmt) {
1063 CheckNesting(StmtType::CYCLE, common::GetPtrFromOptional(cycleStmt.v));
1064}
1065
1066// C1167 and C1168 -- Nesting for EXIT statements
1067void DoForallChecker::Enter(const parser::ExitStmt &exitStmt) {
1068 CheckNesting(StmtType::EXIT, common::GetPtrFromOptional(exitStmt.v));
1069}
1070
1071void DoForallChecker::Leave(const parser::AssignmentStmt &stmt) {
1072 const auto &variable{std::get<parser::Variable>(stmt.t)};
1073 context_.CheckIndexVarRedefine(variable);
1074}
1075
1076static void CheckIfArgIsDoVar(const evaluate::ActualArgument &arg,
1077 const parser::CharBlock location, SemanticsContext &context) {
1078 common::Intent intent{arg.dummyIntent()};
1079 if (intent == common::Intent::Out || intent == common::Intent::InOut) {
1080 if (const SomeExpr * argExpr{arg.UnwrapExpr()}) {
1081 if (const Symbol * var{evaluate::UnwrapWholeSymbolDataRef(*argExpr)}) {
1082 if (intent == common::Intent::Out) {
1083 context.CheckIndexVarRedefine(location, *var);
1084 } else {
1085 context.WarnIndexVarRedefine(location, *var); // INTENT(INOUT)
1086 }
1087 }
1088 }
1089 }
1090}
1091
1092// Check to see if a DO variable is being passed as an actual argument to a
1093// dummy argument whose intent is OUT or INOUT. To do this, we need to find
1094// the expressions for actual arguments which contain DO variables. We get the
1095// intents of the dummy arguments from the ProcedureRef in the "typedCall"
1096// field of the CallStmt which was filled in during expression checking. At
1097// the same time, we need to iterate over the parser::Expr versions of the
1098// actual arguments to get their source locations of the arguments for the
1099// messages.
1100void DoForallChecker::Leave(const parser::CallStmt &callStmt) {
1101 if (const auto &typedCall{callStmt.typedCall}) {
1102 const auto &parsedArgs{
1103 std::get<std::list<parser::ActualArgSpec>>(callStmt.call.t)};
1104 auto parsedArgIter{parsedArgs.begin()};
1105 const evaluate::ActualArguments &checkedArgs{typedCall->arguments()};
1106 for (const auto &checkedOptionalArg : checkedArgs) {
1107 if (parsedArgIter == parsedArgs.end()) {
1108 break; // No more parsed arguments, we're done.
1109 }
1110 const auto &parsedArg{std::get<parser::ActualArg>(parsedArgIter->t)};
1111 ++parsedArgIter;
1112 if (checkedOptionalArg) {
1113 const evaluate::ActualArgument &checkedArg{*checkedOptionalArg};
1114 if (const auto *parsedExpr{
1115 std::get_if<common::Indirection<parser::Expr>>(&parsedArg.u)}) {
1116 CheckIfArgIsDoVar(checkedArg, parsedExpr->value().source, context_);
1117 }
1118 }
1119 }
1120 }
1121}
1122
1123void DoForallChecker::Leave(const parser::ConnectSpec &connectSpec) {
1124 const auto *newunit{
1125 std::get_if<parser::ConnectSpec::Newunit>(&connectSpec.u)};
1126 if (newunit) {
1127 context_.CheckIndexVarRedefine(newunit->v.thing.thing);
1128 }
1129}
1130
1131using ActualArgumentSet = std::set<evaluate::ActualArgumentRef>;
1132
1133struct CollectActualArgumentsHelper
1134 : public evaluate::SetTraverse<CollectActualArgumentsHelper,
1135 ActualArgumentSet> {
1136 using Base = SetTraverse<CollectActualArgumentsHelper, ActualArgumentSet>;
1137 CollectActualArgumentsHelper() : Base{*this} {}
1138 using Base::operator();
1139 ActualArgumentSet operator()(const evaluate::ActualArgument &arg) const {
1140 return Combine(ActualArgumentSet{arg},
1141 CollectActualArgumentsHelper{}(arg.UnwrapExpr()));
1142 }
1143};
1144
1145template <typename A> ActualArgumentSet CollectActualArguments(const A &x) {
1146 return CollectActualArgumentsHelper{}(x);
1147}
1148
1149template ActualArgumentSet CollectActualArguments(const SomeExpr &);
1150
1151void DoForallChecker::Enter(const parser::Expr &parsedExpr) { ++exprDepth_; }
1152
1153void DoForallChecker::Leave(const parser::Expr &parsedExpr) {
1154 CHECK(exprDepth_ > 0);
1155 if (--exprDepth_ == 0) { // Only check top level expressions
1156 if (const SomeExpr * expr{GetExpr(context_, parsedExpr)}) {
1157 ActualArgumentSet argSet{CollectActualArguments(*expr)};
1158 for (const evaluate::ActualArgumentRef &argRef : argSet) {
1159 CheckIfArgIsDoVar(*argRef, parsedExpr.source, context_);
1160 }
1161 }
1162 }
1163}
1164
1165void DoForallChecker::Leave(const parser::InquireSpec &inquireSpec) {
1166 const auto *intVar{std::get_if<parser::InquireSpec::IntVar>(&inquireSpec.u)};
1167 if (intVar) {
1168 const auto &scalar{std::get<parser::ScalarIntVariable>(intVar->t)};
1169 context_.CheckIndexVarRedefine(scalar.thing.thing);
1170 }
1171}
1172
1173void DoForallChecker::Leave(const parser::IoControlSpec &ioControlSpec) {
1174 const auto *size{std::get_if<parser::IoControlSpec::Size>(&ioControlSpec.u)};
1175 if (size) {
1176 context_.CheckIndexVarRedefine(size->v.thing.thing);
1177 }
1178}
1179
1180void DoForallChecker::Leave(const parser::OutputImpliedDo &outputImpliedDo) {
1181 const auto &control{std::get<parser::IoImpliedDoControl>(outputImpliedDo.t)};
1182 const parser::Name &name{control.name.thing.thing};
1183 context_.CheckIndexVarRedefine(name.source, *name.symbol);
1184}
1185
1186void DoForallChecker::Leave(const parser::StatVariable &statVariable) {
1187 context_.CheckIndexVarRedefine(statVariable.v.thing.thing);
1188}
1189
1190} // namespace Fortran::semantics
1191

source code of flang/lib/Semantics/check-do-forall.cpp