[flang] Fix spurious error on defined assignment in PURE

An assignment to a whole polymorphic object in a PURE subprogram
that is implemented by means of a defined assignment procedure
shouldn't be subjected to the same definability checks as it
would be for an intrinsic assignment (which would also require
it to be allocatable).

Fixes #139129.

flang/include/flang/Evaluate/tools.h

@@ -502,42 +502,31 @@ template <typename A> std::optional<Substring> ExtractSubstring(const A &x) {
 
 // If an expression is simply a whole symbol data designator,
 // extract and return that symbol, else null.
+const Symbol *UnwrapWholeSymbolDataRef(const DataRef &);
+const Symbol *UnwrapWholeSymbolDataRef(const std::optional<DataRef> &);
 template <typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {
-  if (auto dataRef{ExtractDataRef(x)}) {
-    if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
-      return &p->get();
-    }
-  }
-  return nullptr;
+  return UnwrapWholeSymbolDataRef(ExtractDataRef(x));
 }
 
 // If an expression is a whole symbol or a whole component desginator,
 // extract and return that symbol, else null.
+const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &);
+const Symbol *UnwrapWholeSymbolOrComponentDataRef(
+    const std::optional<DataRef> &);
 template <typename A>
 const Symbol *UnwrapWholeSymbolOrComponentDataRef(const A &x) {
-  if (auto dataRef{ExtractDataRef(x)}) {
-    if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
-      return &p->get();
-    } else if (const Component * c{std::get_if<Component>(&dataRef->u)}) {
-      if (c->base().Rank() == 0) {
-        return &c->GetLastSymbol();
-      }
-    }
-  }
-  return nullptr;
+  return UnwrapWholeSymbolOrComponentDataRef(ExtractDataRef(x));
 }
 
 // If an expression is a whole symbol or a whole component designator,
 // potentially followed by an image selector, extract and return that symbol,
 // else null.
 const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &);
+const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(
+    const std::optional<DataRef> &);
 template <typename A>
 const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const A &x) {
-  if (auto dataRef{ExtractDataRef(x)}) {
-    return UnwrapWholeSymbolOrComponentOrCoarrayRef(*dataRef);
-  } else {
-    return nullptr;
-  }
+  return UnwrapWholeSymbolOrComponentOrCoarrayRef(ExtractDataRef(x));
 }
 
 // GetFirstSymbol(A%B%C[I]%D) -> A

flang/lib/Evaluate/tools.cpp

@@ -1320,17 +1320,39 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
   return msg;
 }
 
+const Symbol *UnwrapWholeSymbolDataRef(const DataRef &dataRef) {
+  const SymbolRef *p{std::get_if<SymbolRef>(&dataRef.u)};
+  return p ? &p->get() : nullptr;
+}
+
+const Symbol *UnwrapWholeSymbolDataRef(const std::optional<DataRef> &dataRef) {
+  return dataRef ? UnwrapWholeSymbolDataRef(*dataRef) : nullptr;
+}
+
+const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &dataRef) {
+  if (const Component * c{std::get_if<Component>(&dataRef.u)}) {
+    return c->base().Rank() == 0 ? &c->GetLastSymbol() : nullptr;
+  } else {
+    return UnwrapWholeSymbolDataRef(dataRef);
+  }
+}
+
+const Symbol *UnwrapWholeSymbolOrComponentDataRef(
+    const std::optional<DataRef> &dataRef) {
+  return dataRef ? UnwrapWholeSymbolOrComponentDataRef(*dataRef) : nullptr;
+}
+
 const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &dataRef) {
-  if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef.u)}) {
-    return &p->get();
-  } else if (const Component * c{std::get_if<Component>(&dataRef.u)}) {
-    if (c->base().Rank() == 0) {
-      return &c->GetLastSymbol();
-    }
-  } else if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef.u)}) {
+  if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef.u)}) {
     return UnwrapWholeSymbolOrComponentOrCoarrayRef(c->base());
+  } else {
+    return UnwrapWholeSymbolOrComponentDataRef(dataRef);
   }
-  return nullptr;
+}
+
+const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(
+    const std::optional<DataRef> &dataRef) {
+  return dataRef ? UnwrapWholeSymbolOrComponentOrCoarrayRef(*dataRef) : nullptr;
 }
 
 // GetLastPointerSymbol()

flang/lib/Semantics/assignment.cpp

@@ -72,6 +72,11 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
         std::holds_alternative<evaluate::ProcedureRef>(assignment->u)};
     if (isDefinedAssignment) {
       flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);
+    } else if (const Symbol *
+        whole{evaluate::UnwrapWholeSymbolOrComponentDataRef(lhs)}) {
+      if (IsAllocatable(whole->GetUltimate())) {
+        flags.set(DefinabilityFlag::PotentialDeallocation);
+      }
     }
     if (auto whyNot{WhyNotDefinable(lhsLoc, scope, flags, lhs)}) {
       if (whyNot->IsFatal()) {

flang/lib/Semantics/check-deallocate.cpp

@@ -36,7 +36,8 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
               } else if (auto whyNot{WhyNotDefinable(name.source,
                              context_.FindScope(name.source),
                              {DefinabilityFlag::PointerDefinition,
-                                 DefinabilityFlag::AcceptAllocatable},
+                                 DefinabilityFlag::AcceptAllocatable,
+                                 DefinabilityFlag::PotentialDeallocation},
                              *symbol)}) {
                 // Catch problems with non-definability of the
                 // pointer/allocatable
@@ -74,7 +75,8 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
                 } else if (auto whyNot{WhyNotDefinable(source,
                                context_.FindScope(source),
                                {DefinabilityFlag::PointerDefinition,
-                                   DefinabilityFlag::AcceptAllocatable},
+                                   DefinabilityFlag::AcceptAllocatable,
+                                   DefinabilityFlag::PotentialDeallocation},
                                *expr)}) {
                   context_
                       .Say(source,

flang/lib/Semantics/check-declarations.cpp

@@ -949,8 +949,8 @@ void CheckHelper::CheckObjectEntity(
       !IsFunctionResult(symbol) /*ditto*/) {
     // Check automatically deallocated local variables for possible
     // problems with finalization in PURE.
-    if (auto whyNot{
-            WhyNotDefinable(symbol.name(), symbol.owner(), {}, symbol)}) {
+    if (auto whyNot{WhyNotDefinable(symbol.name(), symbol.owner(),
+            {DefinabilityFlag::PotentialDeallocation}, symbol)}) {
       if (auto *msg{messages_.Say(
               "'%s' may not be a local variable in a pure subprogram"_err_en_US,
               symbol.name())}) {

flang/lib/Semantics/definable.cpp

@@ -193,6 +193,15 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
       return WhyNotDefinableLast(at, scope, flags, dataRef->GetLastSymbol());
     }
   }
+  auto dyType{evaluate::DynamicType::From(ultimate)};
+  const auto *inPure{FindPureProcedureContaining(scope)};
+  if (inPure && !flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
+      flags.test(DefinabilityFlag::PotentialDeallocation) && dyType &&
+      dyType->IsPolymorphic()) {
+    return BlameSymbol(at,
+        "'%s' is a whole polymorphic object in a pure subprogram"_en_US,
+        original);
+  }
   if (flags.test(DefinabilityFlag::PointerDefinition)) {
     if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
       if (!IsAllocatableOrObjectPointer(&ultimate)) {
@@ -210,26 +219,17 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
         "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
         original);
   }
-  if (FindPureProcedureContaining(scope)) {
-    if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
-      if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
-        if (dyType->IsPolymorphic()) { // C1596
-          return BlameSymbol(
-              at, "'%s' is polymorphic in a pure subprogram"_en_US, original);
-        }
-      }
-      if (const Symbol * impure{HasImpureFinal(ultimate)}) {
-        return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
-            original, impure->name());
-      }
+  if (dyType && inPure) {
+    if (const Symbol * impure{HasImpureFinal(ultimate)}) {
+      return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
+          original, impure->name());
+    }
+    if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
       if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
-        if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
-          if (auto bad{
-                  FindPolymorphicAllocatablePotentialComponent(*derived)}) {
-            return BlameSymbol(at,
-                "'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
-                original, bad.BuildResultDesignatorName());
-          }
+        if (auto bad{FindPolymorphicAllocatablePotentialComponent(*derived)}) {
+          return BlameSymbol(at,
+              "'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
+              original, bad.BuildResultDesignatorName());
         }
       }
     }
@@ -243,7 +243,7 @@ static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
     const evaluate::DataRef &dataRef) {
   auto whyNotBase{
       WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
-          std::holds_alternative<evaluate::SymbolRef>(dataRef.u),
+          evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
           DefinesComponentPointerTarget(dataRef, flags))};
   if (!whyNotBase || !whyNotBase->IsFatal()) {
     if (auto whyNotLast{

flang/lib/Semantics/definable.h

@@ -33,7 +33,7 @@ ENUM_CLASS(DefinabilityFlag,
     SourcedAllocation, // ALLOCATE(a,SOURCE=)
     PolymorphicOkInPure, // don't check for polymorphic type in pure subprogram
     DoNotNoteDefinition, // context does not imply definition
-    AllowEventLockOrNotifyType)
+    AllowEventLockOrNotifyType, PotentialDeallocation)
 
 using DefinabilityFlags =
     common::EnumSet<DefinabilityFlag, DefinabilityFlag_enumSize>;

flang/lib/Semantics/expression.cpp

@@ -3391,15 +3391,15 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
             const Symbol *lastWhole{
                 lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
             if (!lastWhole || !IsAllocatable(*lastWhole)) {
-              Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
+              Say("Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
             } else if (evaluate::IsCoarray(*lastWhole)) {
-              Say("Left-hand side of assignment may not be polymorphic if it is a coarray"_err_en_US);
+              Say("Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray"_err_en_US);
             }
           }
           if (auto *derived{GetDerivedTypeSpec(*dyType)}) {
             if (auto iter{FindAllocatableUltimateComponent(*derived)}) {
               if (ExtractCoarrayRef(lhs)) {
-                Say("Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
+                Say("Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
                     iter.BuildResultDesignatorName());
               }
             }

flang/test/Semantics/assign11.f90

@@ -9,10 +9,10 @@ program test
   end type
   type(t) auc[*]
   pa = 1 ! ok
-  !ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable
+  !ERROR: Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable
   pp = 1
-  !ERROR: Left-hand side of assignment may not be polymorphic if it is a coarray
+  !ERROR: Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray
   pac = 1
-  !ERROR: Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%a'
+  !ERROR: Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%a'
   auc[1] = t()
 end

flang/test/Semantics/bug139129.f90

@@ -0,0 +1,17 @@
+!RUN: %flang_fc1 -fsyntax-only %s
+module m
+  type t
+   contains
+    procedure asst
+    generic :: assignment(=) => asst
+  end type
+ contains
+  pure subroutine asst(lhs, rhs)
+    class(t), intent(in out) :: lhs
+    class(t), intent(in) :: rhs
+  end
+  pure subroutine test(x, y)
+    class(t), intent(in out) :: x, y
+    x = y ! spurious definability error
+  end
+end

flang/test/Semantics/call28.f90

@@ -11,9 +11,7 @@ pure subroutine s1(x)
   end subroutine
   pure subroutine s2(x)
     class(t), intent(in out) :: x
-    !ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable
-    !ERROR: Left-hand side of assignment is not definable
-    !BECAUSE: 'x' is polymorphic in a pure subprogram
+    !ERROR: Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable
     x = t()
   end subroutine
   pure subroutine s3(x)

flang/test/Semantics/deallocate07.f90

@@ -19,11 +19,11 @@ pure subroutine subr(pp1, pp2, mp2)
     !ERROR: Name in DEALLOCATE statement is not definable
     !BECAUSE: 'mv1' may not be defined in pure subprogram 'subr' because it is host-associated
     deallocate(mv1%pc)
-    !ERROR: Object in DEALLOCATE statement is not deallocatable
-    !BECAUSE: 'pp1' is polymorphic in a pure subprogram
+    !ERROR: Name in DEALLOCATE statement is not definable
+    !BECAUSE: 'pp1' is a whole polymorphic object in a pure subprogram
     deallocate(pp1)
-    !ERROR: Object in DEALLOCATE statement is not deallocatable
-    !BECAUSE: 'pc' is polymorphic in a pure subprogram
+    !ERROR: Name in DEALLOCATE statement is not definable
+    !BECAUSE: 'pc' is a whole polymorphic object in a pure subprogram
     deallocate(pp2%pc)
     !ERROR: Object in DEALLOCATE statement is not deallocatable
     !BECAUSE: 'mp2' has polymorphic component '%pc' in a pure subprogram

flang/test/Semantics/declarations05.f90

@@ -22,7 +22,7 @@ impure subroutine final(x)
   end
   pure subroutine test
     !ERROR: 'x0' may not be a local variable in a pure subprogram
-    !BECAUSE: 'x0' is polymorphic in a pure subprogram
+    !BECAUSE: 'x0' is a whole polymorphic object in a pure subprogram
     class(t0), allocatable :: x0
     !ERROR: 'x1' may not be a local variable in a pure subprogram
     !BECAUSE: 'x1' has an impure FINAL procedure 'final'