[flang] Allow modification of construct entities

Construct entities from ASSOCIATE, SELECT TYPE, and SELECT RANK
are modifiable if the are associated with modifiable variables
without vector subscripts.  Update WhyNotModifiable() to accept
construct entities that are appropriate.

A need for more general error reporting from one overload of
WhyNotModifiable() caused its result type to change to
std::optional<parser::Message> instead of ::MessageFixedText,
and this change had some consequences that rippled through
call sites.

Some test results that didn't allow for modifiable construct
entities needed to be updated.

Differential Revision: https://reviews.llvm.org/D123722

diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 90d8d1d..b84afe5 100644 (file)
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -175,8 +175,7 @@ bool IsAssumedLengthCharacter(const Symbol &);
 bool IsExternal(const Symbol &);
 bool IsModuleProcedure(const Symbol &);
 // Is the symbol modifiable in this scope
-std::optional<parser::MessageFixedText> WhyNotModifiable(
-    const Symbol &, const Scope &);
+std::optional<parser::Message> WhyNotModifiable(const Symbol &, const Scope &);
 std::optional<parser::Message> WhyNotModifiable(SourceName, const SomeExpr &,
     const Scope &, bool vectorSubscriptIsOk = false);
 const Symbol *IsExternalInPureContext(const Symbol &, const Scope &);

diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 47a8608..d06a79b 100644 (file)
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -1901,10 +1901,12 @@ void OmpStructureChecker::CheckIntentInPointerAndDefinable(
         }
         if (auto msg{
                 WhyNotModifiable(*symbol, context_.FindScope(name->source))}) {
-          context_.Say(GetContext().clauseSource,
-              "Variable '%s' on the %s clause is not definable"_err_en_US,
-              symbol->name(),
-              parser::ToUpperCaseLetters(getClauseName(clause).str()));
+          context_
+              .Say(GetContext().clauseSource,
+                  "Variable '%s' on the %s clause is not definable"_err_en_US,
+                  symbol->name(),
+                  parser::ToUpperCaseLetters(getClauseName(clause).str()))
+              .Attach(std::move(*msg));
         }
       }
     }
@@ -2473,7 +2475,7 @@ void OmpStructureChecker::CheckDefinableObjects(
               "Variable '%s' on the %s clause is not definable"_err_en_US,
               symbol->name(),
               parser::ToUpperCaseLetters(getClauseName(clause).str()))
-          .Attach(source, std::move(*msg), symbol->name());
+          .Attach(std::move(*msg));
     }
   }
 }

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 9f73381..15cc773 100644 (file)
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -523,7 +523,7 @@ public:
   void SayAlreadyDeclared(const SourceName &, Symbol &);
   void SayAlreadyDeclared(const SourceName &, const SourceName &);
   void SayWithReason(
-      const parser::Name &, Symbol &, MessageFixedText &&, MessageFixedText &&);
+      const parser::Name &, Symbol &, MessageFixedText &&, Message &&);
   void SayWithDecl(const parser::Name &, Symbol &, MessageFixedText &&);
   void SayLocalMustBeVariable(const parser::Name &, Symbol &);
   void SayDerivedType(const SourceName &, MessageFixedText &&, const Scope &);
@@ -2056,16 +2056,20 @@ void ScopeHandler::SayAlreadyDeclared(
 }
 
 void ScopeHandler::SayWithReason(const parser::Name &name, Symbol &symbol,
-    MessageFixedText &&msg1, MessageFixedText &&msg2) {
-  Say2(name, std::move(msg1), symbol, std::move(msg2));
+    MessageFixedText &&msg1, Message &&msg2) {
+  Say(name, std::move(msg1), symbol.name()).Attach(std::move(msg2));
   context().SetError(symbol, msg1.isFatal());
 }
 
 void ScopeHandler::SayWithDecl(
     const parser::Name &name, Symbol &symbol, MessageFixedText &&msg) {
-  SayWithReason(name, symbol, std::move(msg),
-      symbol.test(Symbol::Flag::Implicit) ? "Implicit declaration of '%s'"_en_US
-                                          : "Declaration of '%s'"_en_US);
+  Say(name, std::move(msg), symbol.name())
+      .Attach(Message{name.source,
+          symbol.test(Symbol::Flag::Implicit)
+              ? "Implicit declaration of '%s'"_en_US
+              : "Declaration of '%s'"_en_US,
+          name.source});
+  context().SetError(symbol, msg.isFatal());
 }
 
 void ScopeHandler::SayLocalMustBeVariable(
@@ -5379,8 +5383,7 @@ bool DeclarationVisitor::PassesLocalityChecks(
         "Assumed size array '%s' not allowed in a locality-spec"_err_en_US);
     return false;
   }
-  if (std::optional<MessageFixedText> msg{
-          WhyNotModifiable(symbol, currScope())}) {
+  if (std::optional<Message> msg{WhyNotModifiable(symbol, currScope())}) {
     SayWithReason(name, symbol,
         "'%s' may not appear in a locality-spec because it is not "
         "definable"_err_en_US,

diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 9bad51d..e0cb86e 100644 (file)
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -773,25 +773,42 @@ bool InProtectedContext(const Symbol &symbol, const Scope &currentScope) {
 // C1101 and C1158
 // 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;
+static std::optional<parser::Message> WhyNotModifiableFirst(
+    parser::CharBlock at, const Symbol &symbol, const Scope &scope) {
+  if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
+    if (assoc->rank().has_value()) {
+      return std::nullopt; // SELECT RANK always modifiable variable
+    } else if (IsVariable(assoc->expr())) {
+      if (evaluate::HasVectorSubscript(assoc->expr().value())) {
+        return parser::Message{
+            at, "Construct association has a vector subscript"_en_US};
+      } else {
+        return WhyNotModifiable(at, *assoc->expr(), scope);
+      }
+    } else {
+      return parser::Message{at,
+          "'%s' is construct associated with an expression"_en_US,
+          symbol.name()};
+    }
   } else if (IsExternalInPureContext(symbol, scope)) {
-    return "'%s' is externally visible and referenced in a pure"
-           " procedure"_en_US;
+    return parser::Message{at,
+        "'%s' is externally visible and referenced in a pure"
+        " procedure"_en_US,
+        symbol.name()};
   } else if (!IsVariableName(symbol)) {
-    return "'%s' is not a variable"_en_US;
+    return parser::Message{at, "'%s' is not a variable"_en_US, symbol.name()};
   } 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) {
+static std::optional<parser::Message> WhyNotModifiableLast(
+    parser::CharBlock at, const Symbol &symbol, const Scope &scope) {
   if (IsOrContainsEventOrLockComponent(symbol)) {
-    return "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US;
+    return parser::Message{at,
+        "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
+        symbol.name()};
   } else {
     return std::nullopt;
   }
@@ -800,27 +817,29 @@ std::optional<parser::MessageFixedText> WhyNotModifiableLast(
 // 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) {
+static std::optional<parser::Message> WhyNotModifiableIfNoPtr(
+    parser::CharBlock at, const Symbol &symbol, const Scope &scope) {
   if (InProtectedContext(symbol, scope)) {
-    return "'%s' is protected in this scope"_en_US;
+    return parser::Message{
+        at, "'%s' is protected in this scope"_en_US, symbol.name()};
   } else if (IsIntentIn(symbol)) {
-    return "'%s' is an INTENT(IN) dummy argument"_en_US;
+    return parser::Message{
+        at, "'%s' is an INTENT(IN) dummy argument"_en_US, symbol.name()};
   } else {
     return std::nullopt;
   }
 }
 
 // Apply all modifiability checks to a single symbol
-std::optional<parser::MessageFixedText> WhyNotModifiable(
+std::optional<parser::Message> WhyNotModifiable(
     const Symbol &original, const Scope &scope) {
   const Symbol &symbol{GetAssociationRoot(original)};
-  if (auto first{WhyNotModifiableFirst(symbol, scope)}) {
+  if (auto first{WhyNotModifiableFirst(symbol.name(), symbol, scope)}) {
     return first;
-  } else if (auto last{WhyNotModifiableLast(symbol, scope)}) {
+  } else if (auto last{WhyNotModifiableLast(symbol.name(), symbol, scope)}) {
     return last;
   } else if (!IsPointer(symbol)) {
-    return WhyNotModifiableIfNoPtr(symbol, scope);
+    return WhyNotModifiableIfNoPtr(symbol.name(), symbol, scope);
   } else {
     return std::nullopt;
   }
@@ -834,21 +853,16 @@ std::optional<parser::Message> WhyNotModifiable(parser::CharBlock at,
       return parser::Message{at, "Variable has a vector subscript"_en_US};
     }
     const Symbol &first{GetAssociationRoot(dataRef->GetFirstSymbol())};
-    if (auto maybeWhyFirst{WhyNotModifiableFirst(first, scope)}) {
-      return parser::Message{first.name(),
-          parser::MessageFormattedText{
-              std::move(*maybeWhyFirst), first.name()}};
+    if (auto maybeWhyFirst{WhyNotModifiableFirst(at, first, scope)}) {
+      return maybeWhyFirst;
     }
     const Symbol &last{dataRef->GetLastSymbol()};
-    if (auto maybeWhyLast{WhyNotModifiableLast(last, scope)}) {
-      return parser::Message{last.name(),
-          parser::MessageFormattedText{std::move(*maybeWhyLast), last.name()}};
+    if (auto maybeWhyLast{WhyNotModifiableLast(at, last, scope)}) {
+      return maybeWhyLast;
     }
     if (!GetLastPointerSymbol(*dataRef)) {
-      if (auto maybeWhyFirst{WhyNotModifiableIfNoPtr(first, scope)}) {
-        return parser::Message{first.name(),
-            parser::MessageFormattedText{
-                std::move(*maybeWhyFirst), first.name()}};
+      if (auto maybeWhyFirst{WhyNotModifiableIfNoPtr(at, first, scope)}) {
+        return maybeWhyFirst;
       }
     }
   } else if (!evaluate::IsVariable(expr)) {

diff --git a/flang/test/Semantics/modifiable01.f90 b/flang/test/Semantics/modifiable01.f90
index f7bfded..fc5b749 100644 (file)
--- a/flang/test/Semantics/modifiable01.f90
+++ b/flang/test/Semantics/modifiable01.f90
@@ -39,7 +39,7 @@ module m
     end associate
     associate (a => arr([1])) ! vector subscript
       !CHECK: error: Input variable 'a' must be definable
-      !CHECK: 'a' is construct associated with an expression
+      !CHECK: Construct association has a vector subscript
       read(internal,*) a
     end associate
     associate (a => arr(2:1:-1))

diff --git a/flang/test/Semantics/resolve57.f90 b/flang/test/Semantics/resolve57.f90
index 526bdc5..6fa698c 100644 (file)
--- a/flang/test/Semantics/resolve57.f90
+++ b/flang/test/Semantics/resolve57.f90
@@ -86,6 +86,13 @@ subroutine s6()
 
   select type ( a => func() )
   type is ( point )
+    ! C1158 This is OK because 'a' is associated with a variable
+    do concurrent (i=1:5) local(a)
+    end do
+  end select
+
+  select type ( a => (func()) )
+  type is ( point )
     ! C1158 This is not OK because 'a' is not associated with a variable
 !ERROR: 'a' may not appear in a locality-spec because it is not definable
     do concurrent (i=1:5) local(a)

diff --git a/flang/test/Semantics/selecttype03.f90 b/flang/test/Semantics/selecttype03.f90
index 45ecf51..bfb1bd4 100644 (file)
--- a/flang/test/Semantics/selecttype03.f90
+++ b/flang/test/Semantics/selecttype03.f90
@@ -30,6 +30,13 @@ end select
 
 select type ( y => fun(1) )
   type is (t1)
+    y%i = 1 !VDC
+  type is (t2)
+    call sub_with_in_and_inout_param(y,y) !VDC
+end select
+
+select type ( y => (fun(1)) )
+  type is (t1)
     !ERROR: Left-hand side of assignment is not modifiable
     y%i = 1 !VDC
   type is (t2)