diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index 7f867813b2bc..2d2a46fc3eb1 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -64,9 +64,10 @@ struct IsVariableHelper IsVariableHelper() : Base{*this} {} using Base::operator(); Result operator()(const StaticDataObject &) const { return false; } - Result operator()(const Symbol &) const { return true; } - Result operator()(const Component &) const { return true; } - Result operator()(const ArrayRef &) const { return true; } + Result operator()(const Symbol &) const; + Result operator()(const Component &) const; + Result operator()(const ArrayRef &) const; + Result operator()(const Substring &) const; Result operator()(const CoarrayRef &) const { return true; } Result operator()(const ComplexPart &) const { return true; } Result operator()(const ProcedureDesignator &) const; @@ -218,6 +219,9 @@ std::optional ExtractDataRef(const Designator &d) { if constexpr (common::HasMember) { return DataRef{x}; } + if constexpr (std::is_same_v, Substring>) { + return ExtractDataRef(x); + } return std::nullopt; // w/o "else" to dodge bogus g++ 8.1 warning }, d.u); @@ -234,6 +238,7 @@ std::optional ExtractDataRef(const std::optional &x) { return std::nullopt; } } +std::optional ExtractDataRef(const Substring &); // Predicate: is an expression is an array element reference? template bool IsArrayElement(const Expr &expr) { diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 624fb352a59e..e9e2c4f0bd5c 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -11,6 +11,7 @@ #include "flang/Evaluate/characteristics.h" #include "flang/Evaluate/traverse.h" #include "flang/Parser/message.h" +#include "flang/Semantics/tools.h" #include #include @@ -37,7 +38,31 @@ Expr Parenthesize(Expr &&expr) { std::move(expr.u)); } +std::optional ExtractDataRef(const Substring &substring) { + return std::visit( + common::visitors{ + [&](const DataRef &x) -> std::optional { return x; }, + [&](const StaticDataObject::Pointer &) -> std::optional { + return std::nullopt; + }, + }, + substring.parent()); +} + // IsVariable() + +auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result { + return !symbol.attrs().test(semantics::Attr::PARAMETER); +} +auto IsVariableHelper::operator()(const Component &x) const -> Result { + return (*this)(x.base()); +} +auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result { + return (*this)(x.base()); +} +auto IsVariableHelper::operator()(const Substring &x) const -> Result { + return (*this)(x.GetBaseObject()); +} auto IsVariableHelper::operator()(const ProcedureDesignator &x) const -> Result { const Symbol *symbol{x.GetSymbol()}; diff --git a/flang/lib/Semantics/assignment.cpp b/flang/lib/Semantics/assignment.cpp index b309433e68f8..bd8fe2cf0311 100644 --- a/flang/lib/Semantics/assignment.cpp +++ b/flang/lib/Semantics/assignment.cpp @@ -66,10 +66,23 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) { const SomeExpr &rhs{assignment->rhs}; auto lhsLoc{std::get(stmt.t).GetSource()}; auto rhsLoc{std::get(stmt.t).source}; + auto shape{evaluate::GetShape(foldingContext(), lhs)}; + if (shape && !shape->empty() && !shape->back().has_value()) { // C1014 + Say(lhsLoc, + "Left-hand side of assignment may not be a whole assumed-size array"_err_en_US); + } + if (CheckForPureContext(lhs, rhs, rhsLoc, false)) { + const Scope &scope{context_.FindScope(lhsLoc)}; + if (auto whyNot{WhyNotModifiable(lhsLoc, lhs, scope)}) { + if (auto *msg{Say(lhsLoc, + "Left-hand side of assignment is not modifiable"_err_en_US)}) { + msg->Attach(*whyNot); + } + } + } if (whereDepth_ > 0) { CheckShape(lhsLoc, &lhs); } - CheckForPureContext(lhs, rhs, rhsLoc, false); } } @@ -169,7 +182,8 @@ bool AssignmentContext::CheckForPureContext(const SomeExpr &lhs, // ASSOCIATE(a=>x) -- check x, not a, for "a=..." base = dataRef ? &dataRef->GetFirstSymbol() : nullptr; } - if (!CheckDefinabilityInPureScope(messages, *base, scope, *pure)) { + if (base && + !CheckDefinabilityInPureScope(messages, *base, scope, *pure)) { return false; } } diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 1b7dd988e5b1..63d36e342cdb 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -333,10 +333,10 @@ void CheckHelper::CheckAssumedTypeEntity( // C709 "Assumed-type argument '%s' cannot be a coarray"_err_en_US, symbol.name()); } - if (details.IsArray() && - !(details.IsAssumedShape() || details.IsAssumedSize())) { - messages_.Say("Assumed-type argument '%s' must be assumed shape" - " or assumed size array"_err_en_US, + if (details.IsArray() && details.shape().IsExplicitShape()) { + messages_.Say( + "Assumed-type array argument 'arg8' must be assumed shape," + " assumed size, or assumed rank"_err_en_US, symbol.name()); } } diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index dd016f9433d3..302ef7fdcaf8 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2588,10 +2588,16 @@ MaybeExpr ExpressionAnalyzer::MakeFunctionRef( void ArgumentAnalyzer::Analyze(const parser::Variable &x) { source_.ExtendToCover(x.GetSource()); if (MaybeExpr expr{context_.Analyze(x)}) { - actuals_.emplace_back(std::move(*expr)); - } else { - fatalErrors_ = true; + if (!IsConstantExpr(*expr)) { + actuals_.emplace_back(std::move(*expr)); + return; + } + const Symbol *symbol{GetFirstSymbol(*expr)}; + context_.Say(x.GetSource(), + "Assignment to constant '%s' is not allowed"_err_en_US, + symbol ? symbol->name() : x.GetSource()); } + fatalErrors_ = true; } void ArgumentAnalyzer::Analyze( diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp index 47158c7af4ab..49bd618e3637 100644 --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -353,13 +353,13 @@ bool ArraySpec::IsDeferredShape() const { }); } bool ArraySpec::IsImpliedShape() const { - return CheckAll([](const ShapeSpec &x) { return x.ubound().isAssumed(); }); + return !IsAssumedRank() && + CheckAll([](const ShapeSpec &x) { return x.ubound().isAssumed(); }); } bool ArraySpec::IsAssumedSize() const { - return !empty() && + return !empty() && !IsAssumedRank() && back().ubound().isAssumed() && std::all_of(begin(), end() - 1, - [](const ShapeSpec &x) { return x.ubound().isExplicit(); }) && - back().ubound().isAssumed(); + [](const ShapeSpec &x) { return x.ubound().isExplicit(); }); } bool ArraySpec::IsAssumedRank() const { return Rank() == 1 && front().lbound().isAssumed(); diff --git a/flang/test/Semantics/CMakeLists.txt b/flang/test/Semantics/CMakeLists.txt index 7144ff9cffd1..7c826d82b961 100644 --- a/flang/test/Semantics/CMakeLists.txt +++ b/flang/test/Semantics/CMakeLists.txt @@ -115,6 +115,7 @@ set(ERROR_TESTS assign01.f90 assign02.f90 assign03.f90 + assign04.f90 if_arith02.f90 if_arith03.f90 if_arith04.f90 diff --git a/flang/test/Semantics/assign04.f90 b/flang/test/Semantics/assign04.f90 new file mode 100644 index 000000000000..e0a02160cba5 --- /dev/null +++ b/flang/test/Semantics/assign04.f90 @@ -0,0 +1,110 @@ +! 9.4.5 +subroutine s1 + type :: t(k, l) + integer, kind :: k + integer, len :: l + end type + type(t(1, 2)) :: x + !ERROR: Assignment to constant 'x%k' is not allowed + x%k = 4 + !ERROR: Left-hand side of assignment is not modifiable + x%l = 3 +end + +! C901 +subroutine s2(x) + real, parameter :: x = 0.0 + real, parameter :: a(*) = [1, 2, 3] + character, parameter :: c(2) = "ab" + integer :: i + !ERROR: Assignment to constant 'x' is not allowed + x = 2.0 + i = 2 + !ERROR: Left-hand side of assignment is not modifiable + a(i) = 3.0 + !ERROR: Left-hand side of assignment is not modifiable + a(i:i+1) = [4, 5] + !ERROR: Left-hand side of assignment is not modifiable + c(i:2) = "cd" +end + +! C901 +subroutine s3 + type :: t + integer :: a(2) + integer :: b + end type + type(t) :: x + type(t), parameter :: y = t([1,2], 3) + integer :: i = 1 + x%a(i) = 1 + !ERROR: Left-hand side of assignment is not modifiable + y%a(i) = 2 + x%b = 4 + !ERROR: Left-hand side of assignment is not modifiable + y%b = 5 +end + +! C844 +subroutine s4 + type :: t + integer :: a(2) + end type +contains + subroutine s(x, c) + type(t), intent(in) :: x + character(10), intent(in) :: c + type(t) :: y + !ERROR: Left-hand side of assignment is not modifiable + x = y + !ERROR: Left-hand side of assignment is not modifiable + x%a(1) = 2 + !ERROR: Left-hand side of assignment is not modifiable + c(2:3) = "ab" + end +end + +! 8.5.15(2) +module m5 + real :: x + real, protected :: y + real, private :: z + type :: t + real :: a + end type + type(t), protected :: b +end +subroutine s5() + use m5 + implicit none + x = 1.0 + !ERROR: Left-hand side of assignment is not modifiable + y = 2.0 + !ERROR: No explicit type declared for 'z' + z = 3.0 + !ERROR: Left-hand side of assignment is not modifiable + b%a = 1.0 +end + +subroutine s6(x) + integer :: x(*) + x(1:3) = [1, 2, 3] + x(:3) = [1, 2, 3] + !ERROR: Assumed-size array 'x' must have explicit final subscript upper bound value + x(:) = [1, 2, 3] + !ERROR: Left-hand side of assignment may not be a whole assumed-size array + x = [1, 2, 3] +end + +module m7 + type :: t + integer :: i + end type +contains + subroutine s7(x) + type(t) :: x(*) + x(:3)%i = [1, 2, 3] + !ERROR: Left-hand side of assignment may not be a whole assumed-size array + x%i = [1, 2, 3] + end +end diff --git a/flang/test/Semantics/resolve72.f90 b/flang/test/Semantics/resolve72.f90 index fdead88c8fe8..6ff2603b2129 100644 --- a/flang/test/Semantics/resolve72.f90 +++ b/flang/test/Semantics/resolve72.f90 @@ -19,7 +19,7 @@ subroutine s() type(*), pointer :: arg6 !ERROR: Assumed-type argument 'arg7' cannot have the VALUE attribute type(*), value :: arg7 - !ERROR: Assumed-type argument 'arg8' must be assumed shape or assumed size array + !ERROR: Assumed-type array argument 'arg8' must be assumed shape, assumed size, or assumed rank type(*), dimension(3) :: arg8 end subroutine inner1 end subroutine s