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

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