flang/lib/Semantics/check-do-forall.cpp

   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
  26 namespace Fortran::evaluate {
  27 using ActualArgumentRef = common::Reference<const ActualArgument>;
  28
  29 inline bool operator<(ActualArgumentRef x, ActualArgumentRef y) {
  30   return &*x < &*y;
  31 }
  32 } // namespace Fortran::evaluate
  33
  34 namespace Fortran::semantics {
  35
  36 using namespace parser::literals;
  37
  38 using Bounds = parser::LoopControl::Bounds;
  39 using IndexVarKind = SemanticsContext::IndexVarKind;
  40
  41 static 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 }
  47 static 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 }
  55 static const parser::ConcurrentHeader &GetConcurrentHeader(
  56     const parser::ForallStmt &stmt) {
  57   return std::get<common::Indirection<parser::ConcurrentHeader>>(stmt.t)
  58       .value();
  59 }
  60 template <typename T>
  61 static const std::list<parser::ConcurrentControl> &GetControls(const T &x) {
  62   return std::get<std::list<parser::ConcurrentControl>>(
  63       GetConcurrentHeader(x).t);
  64 }
  65
  66 static const Bounds &GetBounds(const parser::DoConstruct &doConstruct) {
  67   auto &loopControl{doConstruct.GetLoopControl().value()};
  68   return std::get<Bounds>(loopControl.u);
  69 }
  70
  71 static const parser::Name &GetDoVariable(
  72     const parser::DoConstruct &doConstruct) {
  73   const Bounds &bounds{GetBounds(doConstruct)};
  74   return bounds.name.thing;
  75 }
  76
  77 static parser::MessageFixedText GetEnclosingDoMsg() {
  78   return "Enclosing DO CONCURRENT statement"_en_US;
  79 }
  80
  81 static 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
  87 class DoConcurrentBodyEnforce {
  88 public:
  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{ResolveAssociations(original)};
 158     // Check the entity itself, no coarray exception here
 159     if (IsPolymorphicAllocatable(symbol)) {
 160       return true;
 161     }
 162     // Check the components
 163     if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
 164       if (const DeclTypeSpec * entityType{details->type()}) {
 165         if (const DerivedTypeSpec * derivedType{entityType->AsDerived()}) {
 166           UltimateComponentIterator ultimates{*derivedType};
 167           for (const auto &ultimate : ultimates) {
 168             if (WillDeallocatePolymorphic(ultimate, WillDeallocate)) {
 169               return true;
 170             }
 171           }
 172         }
 173       }
 174     }
 175     return false;
 176   }
 177
 178   void SayDeallocateWithImpureFinal(
 179       const Symbol &entity, const char *reason, const Symbol &impure) {
 180     context_.SayWithDecl(entity, currentStatementSourcePosition_,
 181         "Deallocation of an entity with an IMPURE FINAL procedure '%s' caused by %s not allowed in DO CONCURRENT"_err_en_US,
 182         impure.name(), reason);
 183   }
 184
 185   void SayDeallocateOfPolymorph(
 186       parser::CharBlock location, const Symbol &entity, const char *reason) {
 187     context_.SayWithDecl(entity, location,
 188         "Deallocation of a polymorphic entity caused by %s"
 189         " 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           SayDeallocateOfPolymorph(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         SayDeallocateOfPolymorph(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, reason, *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           SayDeallocateOfPolymorph(
 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
 337 private:
 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
 346 class DoConcurrentVariableEnforce {
 347 public:
 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
 373 private:
 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
 380 class DoContext {
 381 public:
 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
 491 private:
 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
 911 void 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
 920 void 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
 928 void 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 }
 934 void DoForallChecker::Leave(const parser::ForallConstruct &construct) {
 935   DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
 936   doContext.DeactivateIndexVars(GetControls(construct));
 937   nestedWithinConcurrent_.pop_back();
 938 }
 939
 940 void 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 }
 946 void DoForallChecker::Leave(const parser::ForallStmt &stmt) {
 947   DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
 948   doContext.DeactivateIndexVars(GetControls(stmt));
 949   nestedWithinConcurrent_.pop_back();
 950 }
 951 void DoForallChecker::Leave(const parser::ForallAssignmentStmt &stmt) {
 952   DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
 953   doContext.Check(stmt);
 954 }
 955
 956 template <typename A>
 957 static parser::CharBlock GetConstructPosition(const A &a) {
 958   return std::get<0>(a.t).source;
 959 }
 960
 961 static parser::CharBlock GetNodePosition(const ConstructNode &construct) {
 962   return common::visit(
 963       [&](const auto &x) { return GetConstructPosition(*x); }, construct);
 964 }
 965
 966 void 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
 974 static 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
 984 static 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.
 991 void 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
1014 static 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
1028 void 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.
1039 void 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
1062 void DoForallChecker::Enter(const parser::CycleStmt &cycleStmt) {
1063   CheckNesting(StmtType::CYCLE, common::GetPtrFromOptional(cycleStmt.v));
1064 }
1065
1066 // C1167 and C1168 -- Nesting for EXIT statements
1067 void DoForallChecker::Enter(const parser::ExitStmt &exitStmt) {
1068   CheckNesting(StmtType::EXIT, common::GetPtrFromOptional(exitStmt.v));
1069 }
1070
1071 void DoForallChecker::Leave(const parser::AssignmentStmt &stmt) {
1072   const auto &variable{std::get<parser::Variable>(stmt.t)};
1073   context_.CheckIndexVarRedefine(variable);
1074 }
1075
1076 static 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.
1100 void 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
1123 void 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
1131 using ActualArgumentSet = std::set<evaluate::ActualArgumentRef>;
1132
1133 struct 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
1145 template <typename A> ActualArgumentSet CollectActualArguments(const A &x) {
1146   return CollectActualArgumentsHelper{}(x);
1147 }
1148
1149 template ActualArgumentSet CollectActualArguments(const SomeExpr &);
1150
1151 void DoForallChecker::Enter(const parser::Expr &parsedExpr) { ++exprDepth_; }
1152
1153 void 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
1165 void 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
1173 void 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
1180 void 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
1186 void DoForallChecker::Leave(const parser::StatVariable &statVariable) {
1187   context_.CheckIndexVarRedefine(statVariable.v.thing.thing);
1188 }
1189
1190 } // namespace Fortran::semantics