[flang] Perform definability checks on LHS of assignment

If the pure context check succeeds, call `WhyNotModifiable` to verify
the LHS can be modified.

Detect assignment to whole assumed-size array.

Change `IsVariable` to return false for a parameter or a component or
array reference whose base it a parameter.

When analyzing an assignment statement, report an error if the LHS is
a constant expression. Otherwise it might get folded and when we detect
the problem later the error will be confusing.

Handle Substring on LHS of assignment. Change ExtractDataRef and IsVariable
to work on a Substring.

Fix IsImpliedShape and IsAssumedSize predicates in ArraySpec.

Fix C709 check in check-declarations.cpp.

Original-commit: flang-compiler/f18@f2d2657aab
Reviewed-on: https://github.com/flang-compiler/f18/pull/1050

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 Symbol &) const;
-  Result operator()(const Component &) const { return true; }
+  Result operator()(const Component &) const;
-  Result operator()(const ArrayRef &) const { return true; }
+  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<DataRef> ExtractDataRef(const Designator<T> &d) {
         if constexpr (common::HasMember<decltype(x), decltype(DataRef::u)>) {
           return DataRef{x};
         }
+        if constexpr (std::is_same_v<std::decay_t<decltype(x)>, 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<DataRef> ExtractDataRef(const std::optional<A> &x) {
     return std::nullopt;
   }
 }
+std::optional<DataRef> ExtractDataRef(const Substring &);
 
 // Predicate: is an expression is an array element reference?
 template<typename T> bool IsArrayElement(const Expr<T> &expr) {

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 <algorithm>
 #include <variant>
 
@@ -37,7 +38,31 @@ Expr<SomeType> Parenthesize(Expr<SomeType> &&expr) {
       std::move(expr.u));
 }
 
+std::optional<DataRef> ExtractDataRef(const Substring &substring) {
+  return std::visit(
+      common::visitors{
+          [&](const DataRef &x) -> std::optional<DataRef> { return x; },
+          [&](const StaticDataObject::Pointer &) -> std::optional<DataRef> {
+            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()};

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<parser::Variable>(stmt.t).GetSource()};
     auto rhsLoc{std::get<parser::Expr>(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;
       }
     }

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() &&
+      if (details.IsArray() && details.shape().IsExplicitShape()) {
-          !(details.IsAssumedShape() || details.IsAssumedSize())) {
+        messages_.Say(
-        messages_.Say("Assumed-type argument '%s' must be assumed shape"
+            "Assumed-type array argument 'arg8' must be assumed shape,"
-                      " or assumed size array"_err_en_US,
+            " assumed size, or assumed rank"_err_en_US,
             symbol.name());
       }
     }

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));
+    if (!IsConstantExpr(*expr)) {
-  } else {
+      actuals_.emplace_back(std::move(*expr));
-    fatalErrors_ = true;
+      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(

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(); }) &&
+          [](const ShapeSpec &x) { return x.ubound().isExplicit(); });
-      back().ubound().isAssumed();
 }
 bool ArraySpec::IsAssumedRank() const {
   return Rank() == 1 && front().lbound().isAssumed();

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

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

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