[flang] Allow modification of construct entities

[klausler]

Summary

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.

[jeanPerier]

LGTM

flang/include/flang/Semantics/tools.h

 inline bool IsAssumedSizeArray(const Symbol &symbol) {
   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
   return details && details->IsAssumedSize();
 }
 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 &);
 bool HasCoarray(const parser::Expr &);
 bool IsPolymorphicAllocatable(const Symbol &);
 // Return an error if component symbol is not accessible from scope (7.5.4.8(2))
 std::optional<parser::MessageFormattedText> CheckAccessibleComponent(
     const semantics::Scope &, const Symbol &);

flang/lib/Semantics/check-omp-structure.cpp

if (const auto *name{parser::Unwrap<parser::Name>(ompObject)}) {
           context_.Say(GetContext().clauseSource,
               "Pointer '%s' with the INTENT(IN) attribute may not appear "
               "in a %s clause"_err_en_US,
               symbol->name(),
               parser::ToUpperCaseLetters(getClauseName(clause).str()));
         }
         if (auto msg{
                 WhyNotModifiable(*symbol, context_.FindScope(name->source))}) {
-          context_.Say(GetContext().clauseSource,
+          context_
+              .Say(GetContext().clauseSource,
                   "Variable '%s' on the %s clause is not definable"_err_en_US,
                   symbol->name(),
-              parser::ToUpperCaseLetters(getClauseName(clause).str()));
+                  parser::ToUpperCaseLetters(getClauseName(clause).str()))
+              .Attach(std::move(*msg));
         }
       }
     }
   }
 }
 
 void OmpStructureChecker::CheckReductionArraySection(
     const parser::OmpObjectList &ompObjectList) {
for (auto it{symbols.begin()}; it != symbols.end(); ++it) {
     const auto *symbol{it->first};
     const auto source{it->second};
     if (auto msg{WhyNotModifiable(*symbol, context_.FindScope(source))}) {
       context_
           .Say(source,
               "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));
     }
   }
 }
 
 void OmpStructureChecker::CheckPrivateSymbolsInOuterCxt(
     SymbolSourceMap &currSymbols, DirectivesClauseTriple &dirClauseTriple,
     const llvm::omp::Clause currClause) {
   SymbolSourceMap enclosingSymbols;

flang/lib/Semantics/resolve-names.cpp

public:
   }
 
   // Special messages: already declared; referencing symbol's declaration;
   // about a type; two names & locations
   void SayAlreadyDeclared(const parser::Name &, Symbol &);
   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 &);
   void Say2(const SourceName &, MessageFixedText &&, const SourceName &,
       MessageFixedText &&);
   void Say2(
       const SourceName &, MessageFixedText &&, Symbol &, MessageFixedText &&);
   void Say2(
if (name1.begin() < name2.begin()) {
     SayAlreadyDeclared(name2, name1);
   } else {
     Say(name1, "'%s' is already declared in this scoping unit"_err_en_US)
         .Attach(name2, "Previous declaration of '%s'"_en_US, name2);
   }
 }
 
 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(
     const parser::Name &name, Symbol &symbol) {
   SayWithDecl(name, symbol,
       "The name '%s' must be a variable to appear"
       " in a locality-spec"_err_en_US);
 }
if (type->IsPolymorphic() && IsDummy(symbol) &&
       return false;
     }
   }
   if (IsAssumedSizeArray(symbol)) { // C1128
     SayWithDecl(name, symbol,
         "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,
         std::move(*msg));
     return false;
   }
   return PassesSharedLocalityChecks(name, symbol);
 }

flang/lib/Semantics/tools.cpp

 
 bool InProtectedContext(const Symbol &symbol, const Scope &currentScope) {
   return IsProtected(symbol) && !IsHostAssociated(symbol, 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;
   }
 }
 
 // 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;
   }
 }
 
 // Modifiability checks for a data-ref
 std::optional<parser::Message> WhyNotModifiable(parser::CharBlock at,
     const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) {
   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 &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)) {
     return parser::Message{
         at, "'%s' is not a variable"_en_US, expr.AsFortran()};
   } else {
     // reference to function returning POINTER
   }

flang/test/Semantics/modifiable01.f90

subroutine test1(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
+      !CHECK: Construct association has a vector subscript
       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: '666_4' is not a variable
     read(internal,*) j3

flang/test/Semantics/resolve57.f90

subroutine s6()
   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 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)
     end do
   end select
 
   contains
     function func()

flang/test/Semantics/selecttype03.f90

 ! A) associate with function, i.e (other than variables)
 select type ( y => fun(1) )
   type is (t1)
     print *, rank(y%i)
 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)
     !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
     call sub_with_in_and_inout_param(y,y) !VDC
 end select
 
 ! B) associated with a variable: