// of one to complain about, if any exist.
std::optional<std::string> FindImpureCall(
const IntrinsicProcTable &, const Expr<SomeType> &);
+std::optional<std::string> FindImpureCall(
+ const IntrinsicProcTable &, const ProcedureRef &);
+
}
#endif // FORTRAN_EVALUATE_TOOLS_H_
}
void PopConstruct();
- // Check to see if a variable being redefined is a DO variable. If so, emit
- // a message
- void WarnDoVarRedefine(const parser::CharBlock &, const Symbol &);
- void CheckDoVarRedefine(const parser::CharBlock &, const Symbol &);
- void CheckDoVarRedefine(const parser::Variable &);
- void CheckDoVarRedefine(const parser::Name &);
- void ActivateDoVariable(const parser::Name &);
- void DeactivateDoVariable(const parser::Name &);
- bool IsActiveDoVariable(const Symbol &);
+ ENUM_CLASS(IndexVarKind, DO, FORALL)
+ // Check to see if a variable being redefined is a DO or FORALL index.
+ // If so, emit a message.
+ void WarnIndexVarRedefine(const parser::CharBlock &, const Symbol &);
+ void CheckIndexVarRedefine(const parser::CharBlock &, const Symbol &);
+ void CheckIndexVarRedefine(const parser::Variable &);
+ void CheckIndexVarRedefine(const parser::Name &);
+ void ActivateIndexVar(const parser::Name &, IndexVarKind);
+ void DeactivateIndexVar(const parser::Name &);
private:
- parser::CharBlock GetDoVariableLocation(const Symbol &);
- void CheckDoVarRedefine(
+ void CheckIndexVarRedefine(
const parser::CharBlock &, const Symbol &, parser::MessageFixedText &&);
const common::IntrinsicTypeDefaultKinds &defaultKinds_;
const common::LanguageFeatureControl languageFeatures_;
bool CheckError(bool);
ConstructStack constructStack_;
- std::map<SymbolRef, const parser::CharBlock> activeDoVariables_;
+ struct IndexVarInfo {
+ parser::CharBlock location;
+ IndexVarKind kind;
+ };
+ std::map<SymbolRef, const IndexVarInfo> activeIndexVars_;
};
class Semantics {
const IntrinsicProcTable &intrinsics, const Expr<SomeType> &expr) {
return FindImpureCallHelper{intrinsics}(expr);
}
+std::optional<std::string> FindImpureCall(
+ const IntrinsicProcTable &intrinsics, const ProcedureRef &proc) {
+ return FindImpureCallHelper{intrinsics}(proc);
+}
}
struct ForallContext {
explicit ForallContext(const ForallContext *that) : outer{that} {}
- std::optional<int> GetActiveIntKind(const parser::CharBlock &name) const {
- const auto iter{activeNames.find(name)};
- if (iter != activeNames.cend()) {
- return {integerKind};
- } else if (outer) {
- return outer->GetActiveIntKind(name);
- } else {
- return std::nullopt;
- }
- }
-
const ForallContext *outer{nullptr};
std::optional<parser::CharBlock> constructName;
- int integerKind;
std::vector<Control> control;
std::optional<MaskExpr> maskExpr;
std::set<parser::CharBlock> activeNames;
void Analyze(const parser::PointerAssignmentStmt &);
void Analyze(const parser::WhereStmt &);
void Analyze(const parser::WhereConstruct &);
- void Analyze(const parser::ForallStmt &);
void Analyze(const parser::ForallConstruct &);
- void Analyze(const parser::ForallConstructStmt &);
- void Analyze(const parser::ConcurrentHeader &);
template<typename A> void Analyze(const parser::UnlabeledStatement<A> &stmt) {
context_.set_location(stmt.source);
void Analyze(const parser::MaskedElsewhereStmt &);
void Analyze(const parser::WhereConstruct::Elsewhere &);
- int GetIntegerKind(const std::optional<parser::IntegerTypeSpec> &);
- void CheckForImpureCall(const SomeExpr &);
- void CheckForImpureCall(const SomeExpr *);
void CheckForPureContext(const SomeExpr &lhs, const SomeExpr &rhs,
parser::CharBlock rhsSource, bool isPointerAssignment);
// Assignment statement analysis is in expression.cpp where user-defined
// assignments can be recognized and replaced.
if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
- CheckForImpureCall(assignment->lhs);
- CheckForImpureCall(assignment->rhs);
if (forall_) {
// TODO: Warn if some name in forall_->activeNames or its outer
// contexts does not appear on LHS
}
const SomeExpr &lhs{assignment->lhs};
const SomeExpr &rhs{assignment->rhs};
- CheckForImpureCall(lhs);
- CheckForImpureCall(rhs);
- std::visit(
- common::visitors{[&](const evaluate::Assignment::BoundsSpec &bounds) {
- for (const auto &bound : bounds) {
- CheckForImpureCall(SomeExpr{bound});
- }
- },
- [&](const evaluate::Assignment::BoundsRemapping &bounds) {
- for (const auto &bound : bounds) {
- CheckForImpureCall(SomeExpr{bound.first});
- CheckForImpureCall(SomeExpr{bound.second});
- }
- },
- [](const auto &) { DIE("not valid for pointer assignment"); }},
- assignment->u);
if (forall_) {
// TODO: Warn if some name in forall_->activeNames or its outer
// contexts does not appear on LHS
std::get<std::optional<parser::WhereConstruct::Elsewhere>>(construct.t));
}
-void AssignmentContext::Analyze(const parser::ForallStmt &stmt) {
- CHECK(!where_);
- ForallContext forall{forall_};
- AssignmentContext nested{*this, forall};
- nested.Analyze(
- std::get<common::Indirection<parser::ConcurrentHeader>>(stmt.t));
- nested.Analyze(
- std::get<parser::UnlabeledStatement<parser::ForallAssignmentStmt>>(
- stmt.t));
-}
-
-// N.B. Construct name matching is checked during label resolution;
-// index name distinction is checked during name resolution.
-void AssignmentContext::Analyze(const parser::ForallConstruct &construct) {
- CHECK(!where_);
- ForallContext forall{forall_};
- AssignmentContext nested{*this, forall};
- nested.Analyze(
- std::get<parser::Statement<parser::ForallConstructStmt>>(construct.t));
- nested.Analyze(std::get<std::list<parser::ForallBodyConstruct>>(construct.t));
-}
-
-void AssignmentContext::Analyze(const parser::ForallConstructStmt &stmt) {
- Analyze(std::get<common::Indirection<parser::ConcurrentHeader>>(stmt.t));
-}
-
void AssignmentContext::Analyze(
const parser::WhereConstruct::MaskedElsewhere &elsewhere) {
CHECK(where_);
Analyze(std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t));
}
-void AssignmentContext::Analyze(const parser::ConcurrentHeader &header) {
- DEREF(forall_).integerKind = GetIntegerKind(
- std::get<std::optional<parser::IntegerTypeSpec>>(header.t));
- for (const auto &control :
- std::get<std::list<parser::ConcurrentControl>>(header.t)) {
- const parser::Name &name{std::get<parser::Name>(control.t)};
- bool inserted{forall_->activeNames.insert(name.source).second};
- CHECK(inserted || context_.HasError(name));
- CheckForImpureCall(GetExpr(std::get<1>(control.t)));
- CheckForImpureCall(GetExpr(std::get<2>(control.t)));
- if (const auto &stride{std::get<3>(control.t)}) {
- CheckForImpureCall(GetExpr(*stride));
- }
- }
- if (const auto &mask{
- std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)}) {
- CheckForImpureCall(GetExpr(*mask));
- }
-}
-
-int AssignmentContext::GetIntegerKind(
- const std::optional<parser::IntegerTypeSpec> &spec) {
- std::optional<parser::KindSelector> empty;
- evaluate::Expr<evaluate::SubscriptInteger> kind{AnalyzeKindSelector(
- context_, TypeCategory::Integer, spec ? spec->v : empty)};
- if (auto value{evaluate::ToInt64(kind)}) {
- return static_cast<int>(*value);
- } else {
- context_.Say("Kind of INTEGER type must be a constant value"_err_en_US);
- return context_.GetDefaultKind(TypeCategory::Integer);
- }
-}
-
-void AssignmentContext::CheckForImpureCall(const SomeExpr &expr) {
- if (forall_) {
- const auto &intrinsics{context_.foldingContext().intrinsics()};
- if (auto bad{FindImpureCall(intrinsics, expr)}) {
- context_.Say(
- "Impure procedure '%s' may not be referenced in a FORALL"_err_en_US,
- *bad);
- }
- }
-}
-
-void AssignmentContext::CheckForImpureCall(const SomeExpr *expr) {
- if (expr) {
- CheckForImpureCall(*expr);
- }
-}
-
// C1594 checks
static bool IsPointerDummyOfPureFunction(const Symbol &x) {
return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) &&
const parser::LogicalExpr &logicalExpr, bool defaultValue) {
MaskExpr mask{defaultValue};
if (const SomeExpr * expr{GetExpr(logicalExpr)}) {
- CheckForImpureCall(*expr);
auto *logical{std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&expr->u)};
mask = evaluate::ConvertTo(mask, common::Clone(DEREF(logical)));
}
return mask;
}
-void AnalyzeConcurrentHeader(
- SemanticsContext &context, const parser::ConcurrentHeader &header) {
- AssignmentContext{context}.Analyze(header);
-}
-
AssignmentChecker::~AssignmentChecker() {}
AssignmentChecker::AssignmentChecker(SemanticsContext &context)
void AssignmentChecker::Enter(const parser::WhereConstruct &x) {
context_.value().Analyze(x);
}
-void AssignmentChecker::Enter(const parser::ForallStmt &x) {
- context_.value().Analyze(x);
-}
-void AssignmentChecker::Enter(const parser::ForallConstruct &x) {
- context_.value().Analyze(x);
-}
}
template class Fortran::common::Indirection<
#include "flang/common/indirection.h"
#include "flang/evaluate/expression.h"
#include "flang/semantics/semantics.h"
-#include "flang/semantics/tools.h"
-#include <string>
namespace Fortran::parser {
-template<typename> struct Statement;
+class ContextualMessages;
struct AssignmentStmt;
-struct ConcurrentHeader;
-struct ForallStmt;
struct PointerAssignmentStmt;
-struct Program;
struct WhereStmt;
struct WhereConstruct;
-struct ForallConstruct;
}
namespace Fortran::semantics {
class AssignmentContext;
+class Scope;
+class Symbol;
// Applies checks from C1594(1-2) on definitions in pure subprograms
void CheckDefinabilityInPureScope(parser::ContextualMessages &, const Symbol &,
void Enter(const parser::PointerAssignmentStmt &);
void Enter(const parser::WhereStmt &);
void Enter(const parser::WhereConstruct &);
- void Enter(const parser::ForallStmt &);
- void Enter(const parser::ForallConstruct &);
private:
common::Indirection<AssignmentContext> context_;
};
-// R1125 concurrent-header is used in FORALL statements & constructs as
-// well as in DO CONCURRENT loops.
-void AnalyzeConcurrentHeader(
- SemanticsContext &, const parser::ConcurrentHeader &);
-
}
extern template class Fortran::common::Indirection<
"Allocatable object declared here with rank %d"_en_US, rank_);
return false;
}
- context.CheckDoVarRedefine(name_);
+ context.CheckIndexVarRedefine(name_);
return RunCoarrayRelatedChecks(context);
}
context_.Say(name.source,
"name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
} else {
- context_.CheckDoVarRedefine(name);
+ context_.CheckIndexVarRedefine(name);
}
},
[&](const parser::StructureComponent &structureComponent) {
using namespace parser::literals;
using Bounds = parser::LoopControl::Bounds;
+using IndexVarKind = SemanticsContext::IndexVarKind;
-static const std::list<parser::ConcurrentControl> &GetControls(
+static const parser::ConcurrentHeader &GetConcurrentHeader(
const parser::LoopControl &loopControl) {
const auto &concurrent{
std::get<parser::LoopControl::Concurrent>(loopControl.u)};
- const auto &header{std::get<parser::ConcurrentHeader>(concurrent.t)};
- return std::get<std::list<parser::ConcurrentControl>>(header.t);
+ return std::get<parser::ConcurrentHeader>(concurrent.t);
+}
+static const parser::ConcurrentHeader &GetConcurrentHeader(
+ const parser::ForallConstruct &construct) {
+ const auto &stmt{
+ std::get<parser::Statement<parser::ForallConstructStmt>>(construct.t)};
+ return std::get<common::Indirection<parser::ConcurrentHeader>>(
+ stmt.statement.t)
+ .value();
+}
+static const parser::ConcurrentHeader &GetConcurrentHeader(
+ const parser::ForallStmt &stmt) {
+ return std::get<common::Indirection<parser::ConcurrentHeader>>(stmt.t)
+ .value();
+}
+template<typename T>
+static const std::list<parser::ConcurrentControl> &GetControls(const T &x) {
+ return std::get<std::list<parser::ConcurrentControl>>(
+ GetConcurrentHeader(x).t);
}
static const Bounds &GetBounds(const parser::DoConstruct &doConstruct) {
const Scope &blockScope_;
}; // class DoConcurrentVariableEnforce
-// Find a DO statement and enforce semantics checks on its body
+// Find a DO or FORALL and enforce semantics checks on its body
class DoContext {
public:
- DoContext(SemanticsContext &context) : context_{context} {}
+ DoContext(SemanticsContext &context, IndexVarKind kind)
+ : context_{context}, kind_{kind} {}
// Mark this DO construct as a point of definition for the DO variables
// or index-names it contains. If they're already defined, emit an error
// the DO construct and use its location in error messages.
void DefineDoVariables(const parser::DoConstruct &doConstruct) {
if (doConstruct.IsDoNormal()) {
- context_.ActivateDoVariable(GetDoVariable(doConstruct));
+ context_.ActivateIndexVar(GetDoVariable(doConstruct), IndexVarKind::DO);
} else if (doConstruct.IsDoConcurrent()) {
if (const auto &loopControl{doConstruct.GetLoopControl()}) {
- const auto &controls{GetControls(*loopControl)};
- for (const parser::ConcurrentControl &control : controls) {
- context_.ActivateDoVariable(std::get<parser::Name>(control.t));
- }
+ ActivateIndexVars(GetControls(*loopControl));
}
}
}
// Called at the end of a DO construct to deactivate the DO construct
void ResetDoVariables(const parser::DoConstruct &doConstruct) {
if (doConstruct.IsDoNormal()) {
- context_.DeactivateDoVariable(GetDoVariable(doConstruct));
+ context_.DeactivateIndexVar(GetDoVariable(doConstruct));
} else if (doConstruct.IsDoConcurrent()) {
if (const auto &loopControl{doConstruct.GetLoopControl()}) {
- const auto &controls{GetControls(*loopControl)};
- for (const parser::ConcurrentControl &control : controls) {
- context_.DeactivateDoVariable(std::get<parser::Name>(control.t));
- }
+ DeactivateIndexVars(GetControls(*loopControl));
}
}
}
+ void ActivateIndexVars(const std::list<parser::ConcurrentControl> &controls) {
+ for (const auto &control : controls) {
+ context_.ActivateIndexVar(std::get<parser::Name>(control.t), kind_);
+ }
+ }
+ void DeactivateIndexVars(
+ const std::list<parser::ConcurrentControl> &controls) {
+ for (const auto &control : controls) {
+ context_.DeactivateIndexVar(std::get<parser::Name>(control.t));
+ }
+ }
+
void Check(const parser::DoConstruct &doConstruct) {
if (doConstruct.IsDoConcurrent()) {
CheckDoConcurrent(doConstruct);
// TODO: handle the other cases
}
+ void Check(const parser::ForallStmt &stmt) {
+ CheckConcurrentHeader(GetConcurrentHeader(stmt));
+ }
+ void Check(const parser::ForallConstruct &construct) {
+ CheckConcurrentHeader(GetConcurrentHeader(construct));
+ }
+
+ void Check(const parser::ForallAssignmentStmt &stmt) {
+ const evaluate::Assignment *assignment{std::visit(
+ common::visitors{[&](const auto &x) { return GetAssignment(x); }},
+ stmt.u)};
+ if (assignment) {
+ CheckForImpureCall(assignment->lhs);
+ CheckForImpureCall(assignment->rhs);
+ if (const auto *proc{
+ std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {
+ CheckForImpureCall(*proc);
+ }
+ std::visit(
+ common::visitors{
+ [](const evaluate::Assignment::Intrinsic &) {},
+ [&](const evaluate::ProcedureRef &proc) {
+ CheckForImpureCall(proc);
+ },
+ [&](const evaluate::Assignment::BoundsSpec &bounds) {
+ for (const auto &bound : bounds) {
+ CheckForImpureCall(SomeExpr{bound});
+ }
+ },
+ [&](const evaluate::Assignment::BoundsRemapping &bounds) {
+ for (const auto &bound : bounds) {
+ CheckForImpureCall(SomeExpr{bound.first});
+ CheckForImpureCall(SomeExpr{bound.second});
+ }
+ },
+ },
+ assignment->u);
+ }
+ }
+
private:
void SayBadDoControl(parser::CharBlock sourceLocation) {
context_.Say(sourceLocation, "DO controls should be INTEGER"_err_en_US);
"DO CONCURRENT"};
parser::Walk(block, doConcurrentLabelEnforce);
- const auto &loopControl{
- std::get<std::optional<parser::LoopControl>>(doStmt.statement.t)};
- const auto &concurrent{
- std::get<parser::LoopControl::Concurrent>(loopControl->u)};
- CheckConcurrentLoopControl(concurrent, block);
+ const auto &loopControl{doConstruct.GetLoopControl()};
+ CheckConcurrentLoopControl(*loopControl);
+ CheckLocalitySpecs(*loopControl, block);
}
// Return a set of symbols whose names are in a Local locality-spec. Look
SymbolSet references{GatherSymbolsFromExpression(mask.thing.thing.value())};
for (const Symbol &ref : references) {
if (IsProcedure(ref) && !IsPureProcedure(ref)) {
- context_.SayWithDecl(ref, currentStatementSourcePosition_,
- "Concurrent-header mask expression cannot reference an impure"
- " procedure"_err_en_US);
+ context_.SayWithDecl(ref, parser::Unwrap<parser::Expr>(mask)->source,
+ "%s mask expression may not reference impure procedure '%s'"_err_en_US,
+ LoopKindName(), ref.name());
return;
}
}
const parser::CharBlock &refPosition) const {
for (const Symbol &ref : refs) {
if (uses.find(ref) != uses.end()) {
- context_.SayWithDecl(
- ref, refPosition, std::move(errorMessage), ref.name());
+ context_.SayWithDecl(ref, refPosition, std::move(errorMessage),
+ LoopKindName(), ref.name());
return;
}
}
const SymbolSet &indexNames, const parser::ScalarIntExpr &expr) const {
CheckNoCollisions(GatherSymbolsFromExpression(expr.thing.thing.value()),
indexNames,
- "concurrent-control expression references index-name '%s'"_err_en_US,
+ "%s limit expression may not reference index variable '%s'"_err_en_US,
expr.thing.thing.value().source);
}
const parser::ScalarLogicalExpr &mask, const SymbolSet &localVars) const {
CheckNoCollisions(GatherSymbolsFromExpression(mask.thing.thing.value()),
localVars,
- "concurrent-header mask-expr references variable '%s'"
+ "%s mask expression references variable '%s'"
" in LOCAL locality-spec"_err_en_US,
mask.thing.thing.value().source);
}
const parser::ScalarIntExpr &expr, const SymbolSet &localVars) const {
CheckNoCollisions(GatherSymbolsFromExpression(expr.thing.thing.value()),
localVars,
- "concurrent-header expression references variable '%s'"
+ "%s expression references variable '%s'"
" in LOCAL locality-spec"_err_en_US,
expr.thing.thing.value().source);
}
// C1123, concurrent limit or step expressions can't reference index-names
void CheckConcurrentHeader(const parser::ConcurrentHeader &header) const {
+ if (const auto &mask{
+ std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)}) {
+ CheckMaskIsPure(*mask);
+ }
auto &controls{std::get<std::list<parser::ConcurrentControl>>(header.t)};
SymbolSet indexNames;
- for (const auto &c : controls) {
- const auto &indexName{std::get<parser::Name>(c.t)};
+ for (const parser::ConcurrentControl &control : controls) {
+ const auto &indexName{std::get<parser::Name>(control.t)};
if (indexName.symbol) {
indexNames.insert(*indexName.symbol);
}
}
if (!indexNames.empty()) {
- for (const auto &c : controls) {
- HasNoReferences(indexNames, std::get<1>(c.t));
- HasNoReferences(indexNames, std::get<2>(c.t));
- if (const auto &expr{
- std::get<std::optional<parser::ScalarIntExpr>>(c.t)}) {
- HasNoReferences(indexNames, *expr);
- if (IsZero(*expr)) {
- context_.Say(expr->thing.thing.value().source,
- "DO CONCURRENT step expression should not be zero"_err_en_US);
+ for (const parser::ConcurrentControl &control : controls) {
+ HasNoReferences(indexNames, std::get<1>(control.t));
+ HasNoReferences(indexNames, std::get<2>(control.t));
+ if (const auto &intExpr{
+ std::get<std::optional<parser::ScalarIntExpr>>(control.t)}) {
+ const parser::Expr &expr{intExpr->thing.thing.value()};
+ CheckNoCollisions(GatherSymbolsFromExpression(expr), indexNames,
+ "%s step expression may not reference index variable '%s'"_err_en_US,
+ expr.source);
+ if (IsZero(expr)) {
+ context_.Say(expr.source,
+ "%s step expression may not be zero"_err_en_US, LoopKindName());
}
}
}
}
}
- void CheckLocalitySpecs(const parser::LoopControl::Concurrent &concurrent,
- const parser::Block &block) const {
+ void CheckLocalitySpecs(
+ const parser::LoopControl &control, const parser::Block &block) const {
+ const auto &concurrent{
+ std::get<parser::LoopControl::Concurrent>(control.u)};
const auto &header{std::get<parser::ConcurrentHeader>(concurrent.t)};
- const auto &controls{
- std::get<std::list<parser::ConcurrentControl>>(header.t)};
const auto &localitySpecs{
std::get<std::list<parser::LocalitySpec>>(concurrent.t)};
if (!localitySpecs.empty()) {
const SymbolSet &localVars{GatherLocals(localitySpecs)};
- for (const auto &c : controls) {
+ for (const auto &c : GetControls(control)) {
CheckExprDoesNotReferenceLocal(std::get<1>(c.t), localVars);
CheckExprDoesNotReferenceLocal(std::get<2>(c.t), localVars);
if (const auto &expr{
}
// check constraints [C1121 .. C1130]
- void CheckConcurrentLoopControl(
- const parser::LoopControl::Concurrent &concurrent,
- const parser::Block &block) const {
+ void CheckConcurrentLoopControl(const parser::LoopControl &control) const {
+ const auto &concurrent{
+ std::get<parser::LoopControl::Concurrent>(control.u)};
+ CheckConcurrentHeader(std::get<parser::ConcurrentHeader>(concurrent.t));
+ }
- const auto &header{std::get<parser::ConcurrentHeader>(concurrent.t)};
- const auto &mask{
- std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)};
- if (mask) {
- CheckMaskIsPure(*mask);
+ template<typename T> void CheckForImpureCall(const T &x) {
+ const auto &intrinsics{context_.foldingContext().intrinsics()};
+ if (auto bad{FindImpureCall(intrinsics, x)}) {
+ context_.Say(
+ "Impure procedure '%s' may not be referenced in a %s"_err_en_US, *bad,
+ LoopKindName());
}
- CheckConcurrentHeader(header);
- CheckLocalitySpecs(concurrent, block);
+ }
+
+ // For messages where the DO loop must be DO CONCURRENT, make that explicit.
+ const char *LoopKindName() const {
+ return kind_ == IndexVarKind::DO ? "DO CONCURRENT" : "FORALL";
}
SemanticsContext &context_;
+ const IndexVarKind kind_;
parser::CharBlock currentStatementSourcePosition_;
}; // class DoContext
void DoChecker::Enter(const parser::DoConstruct &doConstruct) {
- DoContext doContext{context_};
+ DoContext doContext{context_, IndexVarKind::DO};
doContext.DefineDoVariables(doConstruct);
}
void DoChecker::Leave(const parser::DoConstruct &doConstruct) {
- DoContext doContext{context_};
+ DoContext doContext{context_, IndexVarKind::DO};
doContext.Check(doConstruct);
doContext.ResetDoVariables(doConstruct);
}
+void DoChecker::Enter(const parser::ForallConstruct &construct) {
+ DoContext doContext{context_, IndexVarKind::FORALL};
+ doContext.ActivateIndexVars(GetControls(construct));
+}
+void DoChecker::Leave(const parser::ForallConstruct &construct) {
+ DoContext doContext{context_, IndexVarKind::FORALL};
+ doContext.Check(construct);
+ doContext.DeactivateIndexVars(GetControls(construct));
+}
+
+void DoChecker::Enter(const parser::ForallStmt &stmt) {
+ DoContext doContext{context_, IndexVarKind::FORALL};
+ doContext.ActivateIndexVars(GetControls(stmt));
+}
+void DoChecker::Leave(const parser::ForallStmt &stmt) {
+ DoContext doContext{context_, IndexVarKind::FORALL};
+ doContext.Check(stmt);
+ doContext.DeactivateIndexVars(GetControls(stmt));
+}
+void DoChecker::Leave(const parser::ForallAssignmentStmt &stmt) {
+ DoContext doContext{context_, IndexVarKind::FORALL};
+ doContext.Check(stmt);
+}
+
// Return the (possibly null) name of the ConstructNode
static const parser::Name *MaybeGetNodeName(const ConstructNode &construct) {
return std::visit(
void DoChecker::Leave(const parser::AssignmentStmt &stmt) {
const auto &variable{std::get<parser::Variable>(stmt.t)};
- context_.CheckDoVarRedefine(variable);
+ context_.CheckIndexVarRedefine(variable);
}
static void CheckIfArgIsDoVar(const evaluate::ActualArgument &arg,
if (const SomeExpr * argExpr{arg.UnwrapExpr()}) {
if (const Symbol * var{evaluate::UnwrapWholeSymbolDataRef(*argExpr)}) {
if (intent == common::Intent::Out) {
- context.CheckDoVarRedefine(location, *var);
+ context.CheckIndexVarRedefine(location, *var);
} else {
- context.WarnDoVarRedefine(location, *var); // INTENT(INOUT)
+ context.WarnIndexVarRedefine(location, *var); // INTENT(INOUT)
}
}
}
const auto *newunit{
std::get_if<parser::ConnectSpec::Newunit>(&connectSpec.u)};
if (newunit) {
- context_.CheckDoVarRedefine(newunit->v.thing.thing);
+ context_.CheckIndexVarRedefine(newunit->v.thing.thing);
}
}
const auto *intVar{std::get_if<parser::InquireSpec::IntVar>(&inquireSpec.u)};
if (intVar) {
const auto &scalar{std::get<parser::ScalarIntVariable>(intVar->t)};
- context_.CheckDoVarRedefine(scalar.thing.thing);
+ context_.CheckIndexVarRedefine(scalar.thing.thing);
}
}
void DoChecker::Leave(const parser::IoControlSpec &ioControlSpec) {
const auto *size{std::get_if<parser::IoControlSpec::Size>(&ioControlSpec.u)};
if (size) {
- context_.CheckDoVarRedefine(size->v.thing.thing);
+ context_.CheckIndexVarRedefine(size->v.thing.thing);
}
}
void DoChecker::Leave(const parser::OutputImpliedDo &outputImpliedDo) {
const auto &control{std::get<parser::IoImpliedDoControl>(outputImpliedDo.t)};
const parser::Name &name{control.name.thing.thing};
- context_.CheckDoVarRedefine(name.source, *name.symbol);
+ context_.CheckIndexVarRedefine(name.source, *name.symbol);
}
void DoChecker::Leave(const parser::StatVariable &statVariable) {
- context_.CheckDoVarRedefine(statVariable.v.thing.thing);
+ context_.CheckIndexVarRedefine(statVariable.v.thing.thing);
}
} // namespace Fortran::semantics
struct DoConstruct;
struct ExitStmt;
struct Expr;
+struct ForallAssignmentStmt;
+struct ForallConstruct;
+struct ForallStmt;
struct InquireSpec;
struct IoControlSpec;
struct OutputImpliedDo;
void Enter(const parser::CycleStmt &);
void Enter(const parser::DoConstruct &);
void Leave(const parser::DoConstruct &);
+ void Enter(const parser::ForallConstruct &);
+ void Leave(const parser::ForallConstruct &);
+ void Enter(const parser::ForallStmt &);
+ void Leave(const parser::ForallStmt &);
+ void Leave(const parser::ForallAssignmentStmt &s);
void Enter(const parser::ExitStmt &);
void Leave(const parser::Expr &);
void Leave(const parser::InquireSpec &);
SemanticsContext &context, parser::CharBlock namelistLocation) {
const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
for (const Symbol &object : details.objects()) {
- context.CheckDoVarRedefine(namelistLocation, object);
+ context.CheckIndexVarRedefine(namelistLocation, object);
}
}
for (const auto &item : items) {
if (const parser::Variable *
variable{std::get_if<parser::Variable>(&item.u)}) {
- context.CheckDoVarRedefine(*variable);
+ context.CheckIndexVarRedefine(*variable);
}
}
}
constructStack_.pop_back();
}
-void SemanticsContext::CheckDoVarRedefine(const parser::CharBlock &location,
+void SemanticsContext::CheckIndexVarRedefine(const parser::CharBlock &location,
const Symbol &variable, parser::MessageFixedText &&message) {
if (const Symbol * root{GetAssociationRoot(variable)}) {
- if (IsActiveDoVariable(*root)) {
- parser::CharBlock doLoc{GetDoVariableLocation(*root)};
- CHECK(doLoc != parser::CharBlock{});
- Say(location, std::move(message), root->name())
- .Attach(doLoc, "Enclosing DO construct"_en_US);
+ auto it{activeIndexVars_.find(*root)};
+ if (it != activeIndexVars_.end()) {
+ std::string kind{EnumToString(it->second.kind)};
+ Say(location, std::move(message), kind, root->name())
+ .Attach(it->second.location, "Enclosing %s construct"_en_US, kind);
}
}
}
-void SemanticsContext::WarnDoVarRedefine(
+void SemanticsContext::WarnIndexVarRedefine(
const parser::CharBlock &location, const Symbol &variable) {
- CheckDoVarRedefine(
- location, variable, "Possible redefinition of DO variable '%s'"_en_US);
+ CheckIndexVarRedefine(
+ location, variable, "Possible redefinition of %s variable '%s'"_en_US);
}
-void SemanticsContext::CheckDoVarRedefine(
+void SemanticsContext::CheckIndexVarRedefine(
const parser::CharBlock &location, const Symbol &variable) {
- CheckDoVarRedefine(
- location, variable, "Cannot redefine DO variable '%s'"_err_en_US);
+ CheckIndexVarRedefine(
+ location, variable, "Cannot redefine %s variable '%s'"_err_en_US);
}
-void SemanticsContext::CheckDoVarRedefine(const parser::Variable &variable) {
+void SemanticsContext::CheckIndexVarRedefine(const parser::Variable &variable) {
if (const Symbol * entity{GetLastName(variable).symbol}) {
- const parser::CharBlock &sourceLocation{variable.GetSource()};
- CheckDoVarRedefine(sourceLocation, *entity);
+ CheckIndexVarRedefine(variable.GetSource(), *entity);
}
}
-void SemanticsContext::CheckDoVarRedefine(const parser::Name &name) {
- const parser::CharBlock &sourceLocation{name.source};
+void SemanticsContext::CheckIndexVarRedefine(const parser::Name &name) {
if (const Symbol * entity{name.symbol}) {
- CheckDoVarRedefine(sourceLocation, *entity);
+ CheckIndexVarRedefine(name.source, *entity);
}
}
-void SemanticsContext::ActivateDoVariable(const parser::Name &name) {
- CheckDoVarRedefine(name);
- if (const Symbol * doVariable{name.symbol}) {
- if (const Symbol * root{GetAssociationRoot(*doVariable)}) {
- if (!IsActiveDoVariable(*root)) {
- activeDoVariables_.emplace(*root, name.source);
- }
+void SemanticsContext::ActivateIndexVar(
+ const parser::Name &name, IndexVarKind kind) {
+ CheckIndexVarRedefine(name);
+ if (const Symbol * indexVar{name.symbol}) {
+ if (const Symbol * root{GetAssociationRoot(*indexVar)}) {
+ activeIndexVars_.emplace(*root, IndexVarInfo{name.source, kind});
}
}
}
-void SemanticsContext::DeactivateDoVariable(const parser::Name &name) {
- if (Symbol * doVariable{name.symbol}) {
- if (const Symbol * root{GetAssociationRoot(*doVariable)}) {
- if (name.source == GetDoVariableLocation(*root)) {
- activeDoVariables_.erase(*root);
+void SemanticsContext::DeactivateIndexVar(const parser::Name &name) {
+ if (Symbol * indexVar{name.symbol}) {
+ if (const Symbol * root{GetAssociationRoot(*indexVar)}) {
+ auto it{activeIndexVars_.find(*root)};
+ if (it != activeIndexVars_.end() && it->second.location == name.source) {
+ activeIndexVars_.erase(it);
}
}
}
}
-bool SemanticsContext::IsActiveDoVariable(const Symbol &variable) {
- return activeDoVariables_.find(variable) != activeDoVariables_.end();
-}
-
-parser::CharBlock SemanticsContext::GetDoVariableLocation(
- const Symbol &variable) {
- if (IsActiveDoVariable(variable)) {
- return activeDoVariables_[variable];
- } else {
- return parser::CharBlock{};
- }
-}
-
bool Semantics::Perform() {
return ValidateLabels(context_, program_) &&
parser::CanonicalizeDo(program_) && // force line break
!ERROR: Impure procedure 'impure' may not be referenced in a FORALL
a(j) = pure(impure(j)) ! C1037
end forall
- !ERROR: Concurrent-header mask expression cannot reference an impure procedure
+ !ERROR: DO CONCURRENT mask expression may not reference impure procedure 'impure'
do concurrent (j=1:1, impure(j) /= 0) ! C1121
!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
a(j) = impure(j) ! C1139
do concurrent (j=1:1, x%tbp_pure(j) /= 0) ! ok
a(j) = x%tbp_pure(j) ! ok
end do
- !ERROR: Concurrent-header mask expression cannot reference an impure procedure
+ !ERROR: DO CONCURRENT mask expression may not reference impure procedure 'impure'
do concurrent (j=1:1, x%tbp_impure(j) /= 0) ! C1121
!ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
a(j) = x%tbp_impure(j) ! C1139
SUBROUTINE do_concurrent_c1121(i,n)
IMPLICIT NONE
INTEGER :: i, n, flag
-!ERROR: Concurrent-header mask expression cannot reference an impure procedure
+ !ERROR: DO CONCURRENT mask expression may not reference impure procedure 'random'
DO CONCURRENT (i = 1:n, random() < 3)
flag = 3
END DO
20 CONTINUE
! Error, no compatibility requirement for DO CONCURRENT
-!ERROR: DO CONCURRENT step expression should not be zero
+ !ERROR: DO CONCURRENT step expression may not be zero
DO CONCURRENT (I = 1 : 10 : 0)
END DO
! Error, this time with an integer constant
-!ERROR: DO CONCURRENT step expression should not be zero
+ !ERROR: DO CONCURRENT step expression may not be zero
DO CONCURRENT (I = 1 : 10 : constInt)
END DO
end subroutine s1
IMPLICIT NONE
INTEGER :: a, i, j, k, n
-!ERROR: concurrent-header mask-expr references variable 'n' in LOCAL locality-spec
+ !ERROR: DO CONCURRENT mask expression references variable 'n' in LOCAL locality-spec
DO CONCURRENT (INTEGER *2 :: i = 1:10, i < j + n) LOCAL(n)
PRINT *, "hello"
END DO
-!ERROR: concurrent-header mask-expr references variable 'a' in LOCAL locality-spec
+ !ERROR: DO CONCURRENT mask expression references variable 'a' in LOCAL locality-spec
DO 30 CONCURRENT (i = 1:n:1, j=1:n:2, k=1:n:3, a<3) LOCAL (a)
PRINT *, "hello"
30 END DO
! Initial expression
-!ERROR: concurrent-control expression references index-name 'j'
+ !ERROR: DO CONCURRENT limit expression may not reference index variable 'j'
DO CONCURRENT (i = j:3, j=1:3)
END DO
! Final expression
-!ERROR: concurrent-control expression references index-name 'j'
+ !ERROR: DO CONCURRENT limit expression may not reference index variable 'j'
DO CONCURRENT (i = 1:j, j=1:3)
END DO
! Step expression
-!ERROR: concurrent-control expression references index-name 'j'
+ !ERROR: DO CONCURRENT step expression may not reference index variable 'j'
DO CONCURRENT (i = 1:3:j, j=1:3)
END DO
-!ERROR: concurrent-control expression references index-name 'i'
+ !ERROR: DO CONCURRENT limit expression may not reference index variable 'i'
DO CONCURRENT (INTEGER*2 :: i = 1:3, j=i:3)
END DO
end associate
associate (avar => ivar)
-!ERROR: DO CONCURRENT step expression should not be zero
+!ERROR: DO CONCURRENT step expression may not be zero
do concurrent (i = 1:2:0) default(none) shared(jvar) local(kvar)
!ERROR: Variable 'ivar' from an enclosing scope referenced in DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
ivar = &
end subroutine s2
subroutine s4()
-!ERROR: concurrent-header expression references variable 'i' in LOCAL locality-spec
+!ERROR: DO CONCURRENT expression references variable 'i' in LOCAL locality-spec
do concurrent (j=i:10) local(i)
end do
end subroutine s4
end subroutine s6
subroutine s7()
-!ERROR: concurrent-header expression references variable 'i' in LOCAL locality-spec
+!ERROR: DO CONCURRENT expression references variable 'i' in LOCAL locality-spec
do concurrent (j=1:i) local(i)
end do
end subroutine s7
end subroutine s9
subroutine s10()
-!ERROR: concurrent-header expression references variable 'i' in LOCAL locality-spec
+!ERROR: DO CONCURRENT expression references variable 'i' in LOCAL locality-spec
do concurrent (j=1:10:i) local(i)
end do
end subroutine s10
! Test construct-association, in this case, established by the "shared"
integer :: ivar
associate (avar => ivar)
-!ERROR: concurrent-header expression references variable 'ivar' in LOCAL locality-spec
+!ERROR: DO CONCURRENT expression references variable 'ivar' in LOCAL locality-spec
do concurrent (j=1:10:avar) local(avar)
end do
end associate
! Test use-association, in this case, established by the "shared"
use m1
-!ERROR: concurrent-header expression references variable 'mvar' in LOCAL locality-spec
+!ERROR: DO CONCURRENT expression references variable 'mvar' in LOCAL locality-spec
do concurrent (k=mvar:10) local(mvar)
end do
end subroutine s14
! locality-spec
ivar = 3
do concurrent (j=ivar:10) shared(ivar)
-!ERROR: concurrent-header expression references variable 'ivar' in LOCAL locality-spec
+!ERROR: DO CONCURRENT expression references variable 'ivar' in LOCAL locality-spec
do concurrent (k=ivar:10) local(ivar)
end do
end do
subroutine forall1
real :: a(9)
!ERROR: 'i' is already declared in this scoping unit
+ !ERROR: Cannot redefine FORALL variable 'i'
forall (i=1:8, i=1:9) a(i) = i
+ !ERROR: 'i' is already declared in this scoping unit
+ !ERROR: Cannot redefine FORALL variable 'i'
+ forall (i=1:8, i=1:9)
+ a(i) = i
+ end forall
forall (j=1:8)
!ERROR: 'j' is already declared in this scoping unit
+ !ERROR: Cannot redefine FORALL variable 'j'
forall (j=1:9)
end forall
end forall
end
+
subroutine forall2
integer, pointer :: a(:)
integer, target :: b(10,10)
!ERROR: Impure procedure 'f_impure' may not be referenced in a FORALL
a(f_impure(i):) => b(i,:)
end forall
+ !ERROR: FORALL mask expression may not reference impure procedure 'f_impure'
+ forall (j=1:10, f_impure(1)>2)
+ end forall
contains
impure integer function f_impure(i)
f_impure = i
end
end
+
+subroutine forall3
+ real :: x
+ forall(i=1:10)
+ !ERROR: Cannot redefine FORALL variable 'i'
+ i = 1
+ end forall
+ forall(i=1:10)
+ forall(j=1:10)
+ !ERROR: Cannot redefine FORALL variable 'i'
+ i = 1
+ end forall
+ end forall
+ !ERROR: Cannot redefine FORALL variable 'i'
+ forall(i=1:10) i = 1
+end
+
+subroutine forall4
+ integer, parameter :: zero = 0
+ integer :: a(10)
+
+ !ERROR: FORALL limit expression may not reference index variable 'i'
+ forall(i=1:i)
+ a(i) = i
+ end forall
+ !ERROR: FORALL step expression may not reference index variable 'i'
+ forall(i=1:10:i)
+ a(i) = i
+ end forall
+ !ERROR: FORALL step expression may not be zero
+ forall(i=1:10:zero)
+ a(i) = i
+ end forall
+
+ !ERROR: FORALL limit expression may not reference index variable 'i'
+ forall(i=1:i) a(i) = i
+ !ERROR: FORALL step expression may not reference index variable 'i'
+ forall(i=1:10:i) a(i) = i
+ !ERROR: FORALL step expression may not be zero
+ forall(i=1:10:zero) a(i) = i
+end
end forall
end
-subroutine s5
- real :: a(10), b(10)
- !ERROR: 'i' is already declared in this scoping unit
- forall(i=1:10, i=1:10)
- a(i) = b(i)
- end forall
-end
-
subroutine s6
integer, parameter :: n = 4
real, dimension(n) :: x
projects / platform / upstream / llvm.git / commitdiff