[flang] Refine WhyNotModifiable()

[klausler]

Summary

The utility routine WhyNotModifiable() needed to become more
aware of the use of pointers in data-refs; the targets of
pointer components are sometimes modifiable even when the
leftmost ("base") symbol of a data-ref is not.

Added a new unit test for WhyNotModifiable() that uses internal
READ statements (mostly), since I/O semantic checking uses
WhyNotModifiable() for all its definability checking.

[PeteSteinfeld]

All builds, tests, and looks good.

flang/include/flang/Evaluate/tools.h

 template <typename A> const Symbol *GetFirstSymbol(const A &x) {
   if (auto dataRef{ExtractDataRef(x, true)}) {
     return &dataRef->GetFirstSymbol();
   } else {
     return nullptr;
   }
 }
 
+// GetLastPointerSymbol(A%PTR1%B%PTR2%C) -> PTR2
+const Symbol *GetLastPointerSymbol(const evaluate::DataRef &);
+
 // Creation of conversion expressions can be done to either a known
 // specific intrinsic type with ConvertToType<T>(x) or by converting
 // one arbitrary expression to the type of another with ConvertTo(to, from).
 
 template <typename TO, TypeCategory FROMCAT>
 Expr<TO> ConvertToType(Expr<SomeKind<FROMCAT>> &&x) {
   static_assert(IsSpecificIntrinsicType<TO>);
   if constexpr (FROMCAT == TO::category) {

flang/lib/Evaluate/tools.cpp

msg = "Procedure %s with implicit interface may not be associated with"
           " procedure designator '%s' with explicit interface"_err_en_US;
   } else {
     msg = "Procedure %s associated with incompatible procedure"
           " designator '%s'"_err_en_US;
   }
   return msg;
 }
 
+// GetLastPointerSymbol()
+static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {
+  return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;
+}
+static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) {
+  return GetLastPointerSymbol(*symbol);
+}
+static const Symbol *GetLastPointerSymbol(const Component &x) {
+  const Symbol &c{x.GetLastSymbol()};
+  return IsPointer(c) ? &c : GetLastPointerSymbol(x.base());
+}
+static const Symbol *GetLastPointerSymbol(const NamedEntity &x) {
+  const auto *c{x.UnwrapComponent()};
+  return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol());
+}
+static const Symbol *GetLastPointerSymbol(const ArrayRef &x) {
+  return GetLastPointerSymbol(x.base());
+}
+static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) {
+  return nullptr;
+}
+const Symbol *GetLastPointerSymbol(const DataRef &x) {
+  return std::visit([](const auto &y) { return GetLastPointerSymbol(y); }, x.u);
+}
+
 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {
 
 const Symbol &ResolveAssociations(const Symbol &original) {
   const Symbol &symbol{original.GetUltimate()};
   if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
     if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {

flang/lib/Semantics/check-io.cpp

void IoChecker::CheckForProhibitedSpecifier(
   }
 }
 
 template <typename A>
 void IoChecker::CheckForDefinableVariable(
     const A &var, const std::string &s) const {
   const Symbol *sym{
       GetFirstName(*parser::Unwrap<parser::Variable>(var)).symbol};
-  if (WhyNotModifiable(*sym, context_.FindScope(*context_.location()))) {
-    context_.Say(parser::FindSourceLocation(var),
-        "%s variable '%s' must be definable"_err_en_US, s, sym->name());
+  if (auto whyNot{
+          WhyNotModifiable(*sym, context_.FindScope(*context_.location()))}) {
+    auto at{parser::FindSourceLocation(var)};
+    context_
+        .Say(at, "%s variable '%s' must be definable"_err_en_US, s, sym->name())
+        .Attach(at, std::move(*whyNot), sym->name());
   }
 }
 
 void IoChecker::CheckForPureSubprogram() const { // C1597
   CHECK(context_.location());
   if (FindPureProcedureContaining(context_.FindScope(*context_.location()))) {
     context_.Say("External I/O is not allowed in a pure subprogram"_err_en_US);
   }
 }
 
 } // namespace Fortran::semantics

flang/lib/Semantics/tools.cpp

bool IsOrContainsPolymorphicComponent(const Symbol &original) {
   return false;
 }
 
 bool InProtectedContext(const Symbol &symbol, const Scope &currentScope) {
   return IsProtected(symbol) && !IsHostAssociated(symbol, currentScope);
 }
 
 // C1101 and C1158
-std::optional<parser::MessageFixedText> WhyNotModifiable(
-    const Symbol &original, const Scope &scope) {
-  const Symbol &symbol{GetAssociationRoot(original)};
+// Modifiability checks on the leftmost symbol ("base object")
+// of a data-ref
+std::optional<parser::MessageFixedText> WhyNotModifiableFirst(
+    const Symbol &symbol, const Scope &scope) {
   if (symbol.has<AssocEntityDetails>()) {
     return "'%s' is construct associated with an expression"_en_US;
-  } else if (InProtectedContext(symbol, scope)) {
-    return "'%s' is protected in this scope"_en_US;
   } else if (IsExternalInPureContext(symbol, scope)) {
     return "'%s' is externally visible and referenced in a pure"
            " procedure"_en_US;
-  } else if (IsOrContainsEventOrLockComponent(symbol)) {
+  } else if (!IsVariableName(symbol)) {
+    return "'%s' is not a variable"_en_US;
+  } else {
+    return std::nullopt;
+  }
+}
+
+// Modifiability checks on the rightmost symbol of a data-ref
+std::optional<parser::MessageFixedText> WhyNotModifiableLast(
+    const Symbol &symbol, const Scope &scope) {
+  if (IsOrContainsEventOrLockComponent(symbol)) {
     return "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US;
+  } else {
+    return std::nullopt;
+  }
+}
+
+// Modifiability checks on the leftmost (base) symbol of a data-ref
+// that apply only when there are no pointer components or a base
+// that is a pointer.
+std::optional<parser::MessageFixedText> WhyNotModifiableIfNoPtr(
+    const Symbol &symbol, const Scope &scope) {
+  if (InProtectedContext(symbol, scope)) {
+    return "'%s' is protected in this scope"_en_US;
   } else if (IsIntentIn(symbol)) {
     return "'%s' is an INTENT(IN) dummy argument"_en_US;
-  } else if (!IsVariableName(symbol)) {
-    return "'%s' is not a variable"_en_US;
   } else {
     return std::nullopt;
   }
 }
 
+// Apply all modifiability checks to a single symbol
+std::optional<parser::MessageFixedText> WhyNotModifiable(
+    const Symbol &original, const Scope &scope) {
+  const Symbol &symbol{GetAssociationRoot(original)};
+  if (auto first{WhyNotModifiableFirst(symbol, scope)}) {
+    return first;
+  } else if (auto last{WhyNotModifiableLast(symbol, scope)}) {
+    return last;
+  } else if (!IsPointer(symbol)) {
+    return WhyNotModifiableIfNoPtr(symbol, scope);
+  } else {
+    return std::nullopt;
+  }
+}
+
+// Modifiability checks for a data-ref
 std::optional<parser::Message> WhyNotModifiable(parser::CharBlock at,
     const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) {
   if (!evaluate::IsVariable(expr)) {
     return parser::Message{at, "Expression is not a variable"_en_US};
   } else if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) {
     if (!vectorSubscriptIsOk && evaluate::HasVectorSubscript(expr)) {
       return parser::Message{at, "Variable has a vector subscript"_en_US};
     }
-    const Symbol &symbol{dataRef->GetFirstSymbol()};
-    if (auto maybeWhy{WhyNotModifiable(symbol, scope)}) {
-      return parser::Message{symbol.name(),
-          parser::MessageFormattedText{std::move(*maybeWhy), symbol.name()}};
+    const Symbol &first{GetAssociationRoot(dataRef->GetFirstSymbol())};
+    if (auto maybeWhyFirst{WhyNotModifiableFirst(first, scope)}) {
+      return parser::Message{first.name(),
+          parser::MessageFormattedText{
+              std::move(*maybeWhyFirst), first.name()}};
+    }
+    const Symbol &last{dataRef->GetLastSymbol()};
+    if (auto maybeWhyLast{WhyNotModifiableLast(last, scope)}) {
+      return parser::Message{last.name(),
+          parser::MessageFormattedText{std::move(*maybeWhyLast), last.name()}};
+    }
+    if (!GetLastPointerSymbol(*dataRef)) {
+      if (auto maybeWhyFirst{WhyNotModifiableIfNoPtr(first, scope)}) {
+        return parser::Message{first.name(),
+            parser::MessageFormattedText{
+                std::move(*maybeWhyFirst), first.name()}};
+      }
     }
   } else {
     // reference to function returning POINTER
   }
   return std::nullopt;
 }
 
 class ImageControlStmtHelper {

flang/test/Semantics/modifiable01.f90

+! RUN: not %f18 -fparse-only %s 2>&1 | FileCheck %s
+! Test WhyNotModifiable() explanations
+
+module prot
+  real, protected :: prot
+  type :: ptype
+    real, pointer :: ptr
+    real :: x
+  end type
+  type(ptype), protected :: protptr
+ contains
+  subroutine ok
+    prot = 0. ! ok
+  end subroutine
+end module
+
+module m
+  use iso_fortran_env
+  use prot
+  type :: t1
+    type(lock_type) :: lock
+  end type
+  type :: t2
+    type(t1) :: x1
+    real :: x2
+  end type
+  type(t2) :: t2static
+  character(*), parameter :: internal = '0'
+ contains
+  subroutine test1(dummy)
+    real :: arr(2)
+    integer, parameter :: j3 = 666
+    type(ptype), intent(in) :: dummy
+    type(t2) :: t2var
+    associate (a => 3+4)
+      !CHECK: error: Input variable 'a' must be definable
+      !CHECK: 'a' is construct associated with an expression
+      read(internal,*) a
+    end associate
+    associate (a => arr([1])) ! vector subscript
+      !CHECK: error: Input variable 'a' must be definable
+      !CHECK: 'a' is construct associated with an expression
+      read(internal,*) a
+    end associate
+    associate (a => arr(2:1:-1))
+      read(internal,*) a ! ok
+    end associate
+    !CHECK: error: Input variable 'j3' must be definable
+    !CHECK: 'j3' is not a variable
+    read(internal,*) j3
+    !CHECK: error: Left-hand side of assignment is not modifiable
+    !CHECK: 't2var' is an entity with either an EVENT_TYPE or LOCK_TYPE
+    t2var = t2static
+    t2var%x2 = 0. ! ok
+    !CHECK: error: Left-hand side of assignment is not modifiable
+    !CHECK: 'prot' is protected in this scope
+    prot = 0.
+    protptr%ptr = 0. ! ok
+    !CHECK: error: Left-hand side of assignment is not modifiable
+    !CHECK: 'dummy' is an INTENT(IN) dummy argument
+    dummy%x = 0.
+    dummy%ptr = 0. ! ok
+  end subroutine
+  pure subroutine test2(ptr)
+    integer, pointer, intent(in) :: ptr
+    !CHECK: error: Input variable 'ptr' must be definable
+    !CHECK: 'ptr' is externally visible and referenced in a pure procedure
+    read(internal,*) ptr
+  end subroutine
+end module