[flang] Revert Symbol::operator=() changes

Rearrange "if" nest for clarity

Pass call12.f90 test.

Original-commit: flang-compiler/f18@69a1a2b
Reviewed-on: flang-compiler/f18#835
Tree-same-pre-rewrite: false

flang/lib/evaluate/common.h

@@ -195,11 +195,14 @@ using HostUnsignedInt =
   t() = delete; \
   DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(t)
 
-#define EVALUATE_UNION_CLASS_BOILERPLATE(t) \
-  CLASS_BOILERPLATE(t) \
+#define UNION_CONSTRUCTORS(t) \
   template<typename _A> explicit t(const _A &x) : u{x} {} \
   template<typename _A, typename = common::NoLvalue<_A>> \
-  explicit t(_A &&x) : u(std::move(x)) {} \
+  explicit t(_A &&x) : u(std::move(x)) {}
+
+#define EVALUATE_UNION_CLASS_BOILERPLATE(t) \
+  CLASS_BOILERPLATE(t) \
+  UNION_CONSTRUCTORS(t) \
   bool operator==(const t &that) const { return u == that.u; }
 
 // Forward definition of Expr<> so that it can be indirectly used in its own

flang/lib/evaluate/variable.cc

@@ -599,15 +599,34 @@ NamedEntity CoarrayRef::GetBase() const { return AsNamedEntity(base_); }
 
 // Equality testing
 
+// For the purposes of comparing type parameter expressions while
+// testing the compatibility of procedure characteristics, two
+// object dummy arguments with the same name are considered equal.
+bool AreSameSymbol(const Symbol &x, const Symbol &y) {
+  if (&x == &y) {
+    return true;
+  }
+  if (x.name() == y.name()) {
+    if (const auto *xObject{
+                 x.detailsIf<semantics::ObjectEntityDetails>()}) {
+      if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
+        return xObject->isDummy() && yObject->isDummy();
+      }
+    }
+  }
+  return false;
+}
+
 bool BaseObject::operator==(const BaseObject &that) const {
-  return u == that.u;
+  return TestVariableEquality(*this, that);
 }
 bool Component::operator==(const Component &that) const {
   return base_ == that.base_ && &*symbol_ == &*that.symbol_;
 }
 bool NamedEntity::operator==(const NamedEntity &that) const {
   if (IsSymbol()) {
-    return that.IsSymbol() && GetLastSymbol() == that.GetLastSymbol();
+    return that.IsSymbol() &&
+        AreSameSymbol(GetFirstSymbol(), that.GetFirstSymbol());
   } else {
     return !that.IsSymbol() && GetComponent() == that.GetComponent();
   }
@@ -629,6 +648,9 @@ bool CoarrayRef::operator==(const CoarrayRef &that) const {
       cosubscript_ == that.cosubscript_ && stat_ == that.stat_ &&
       team_ == that.team_ && teamIsTeamNumber_ == that.teamIsTeamNumber_;
 }
+bool DataRef::operator==(const DataRef &that) const {
+  return TestVariableEquality(*this, that);
+}
 bool Substring::operator==(const Substring &that) const {
   return parent_ == that.parent_ && lower_ == that.lower_ &&
       upper_ == that.upper_;

flang/lib/evaluate/variable.h

@@ -47,14 +47,26 @@ using SymbolVector = std::vector<SymbolRef>;
 
 // Forward declarations
 struct DataRef;
-template<typename A> struct Variable;
+template<typename T> struct Variable;
+
+bool AreSameSymbol(const Symbol &, const Symbol &);
+
+// Implements operator=() for a union type, using special case handling
+// for Symbol references.
+template<typename A> bool TestVariableEquality(const A &x, const A &y) {
+  const SymbolRef *xSymbol{std::get_if<SymbolRef>(&x.u)};
+  if (const SymbolRef * ySymbol{std::get_if<SymbolRef>(&y.u)}) {
+    return xSymbol && AreSameSymbol(*xSymbol, *ySymbol);
+  } else {
+    return x.u == y.u;
+  }
+}
 
 // Reference a base object in memory.  This can be a Fortran symbol,
 // static data (e.g., CHARACTER literal), or compiler-created temporary.
 struct BaseObject {
   CLASS_BOILERPLATE(BaseObject)
-  explicit BaseObject(const Symbol &symbol) : u{symbol} {}
-  explicit BaseObject(StaticDataObject::Pointer &&p) : u{std::move(p)} {}
+  UNION_CONSTRUCTORS(BaseObject)
   int Rank() const;
   std::optional<Expr<SubscriptInteger>> LEN() const;
   bool operator==(const BaseObject &) const;
@@ -288,9 +300,10 @@ class CoarrayRef {
 // a terminal substring range or complex component designator; use
 // R901 designator for that.
 struct DataRef {
-  EVALUATE_UNION_CLASS_BOILERPLATE(DataRef)
-  explicit DataRef(const Symbol &n) : u{n} {}
+  CLASS_BOILERPLATE(DataRef)
+  UNION_CONSTRUCTORS(DataRef)
 
+  bool operator==(const DataRef &) const;
   int Rank() const;
   const Symbol &GetFirstSymbol() const;
   const Symbol &GetLastSymbol() const;
@@ -386,12 +399,15 @@ template<typename T> class Designator {
   using Result = T;
   static_assert(
       IsSpecificIntrinsicType<Result> || std::is_same_v<Result, SomeDerived>);
-  EVALUATE_UNION_CLASS_BOILERPLATE(Designator)
-
+  CLASS_BOILERPLATE(Designator)
+  UNION_CONSTRUCTORS(Designator)
   Designator(const DataRef &that) : u{common::CopyVariant<Variant>(that.u)} {}
   Designator(DataRef &&that)
     : u{common::MoveVariant<Variant>(std::move(that.u))} {}
 
+  bool operator==(const Designator &that) const {
+    return TestVariableEquality(*this, that);
+  }
   std::optional<DynamicType> GetType() const;
   int Rank() const;
   BaseObject GetBaseObject() const;

flang/lib/semantics/assignment.cc

@@ -338,11 +338,13 @@ class AssignmentContext {
   void Analyze(const parser::WhereConstruct::Elsewhere &);
   void Analyze(const parser::ForallAssignmentStmt &stmt) { Analyze(stmt.u); }
 
-  const Symbol *FindPureProcedureContaining(parser::CharBlock) const;
   int GetIntegerKind(const std::optional<parser::IntegerTypeSpec> &);
   void CheckForImpureCall(const evaluate::Expr<evaluate::SomeType> &);
   void CheckForImpureCall(
       const std::optional<evaluate::Expr<evaluate::SomeType>> &);
+  void CheckForPureContext(const evaluate::Expr<evaluate::SomeType> &lhs,
+      const evaluate::Expr<evaluate::SomeType> &rhs,
+      parser::CharBlock rhsSource, bool isPointerAssignment);
 
   MaskExpr GetMask(const parser::LogicalExpr &, bool defaultValue = true);
 
@@ -369,38 +371,31 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
     // TODO: Warn if some name in forall_->activeNames or its outer
     // contexts does not appear on LHS
   }
+  if (lhsExpr && rhsExpr) {
+    CheckForPureContext(*lhsExpr, *rhsExpr, rhs.source, false /* not => */);
+  }
   // TODO: Fortran 2003 ALLOCATABLE assignment semantics (automatic
   // (re)allocation of LHS array when unallocated or nonconformable)
-
-  // C1596 checks for polymorphic deallocation in a PURE subprogram
-  // due to automatic reallocation on assignment
-  if (lhsExpr) {
-    if (auto type{evaluate::DynamicType::From(*lhsExpr)}) {
-      if (type->IsPolymorphic() && FindPureProcedureContaining(rhs.source)) {
-        Say(at_,
-            "Deallocation of polymorphic object is not permitted in a PURE subprogram"_err_en_US);
-      }
-      if (type->category() == TypeCategory::Derived &&
-          !type->IsUnlimitedPolymorphic() &&
-          FindPureProcedureContaining(rhs.source)) {
-        if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
-                type->GetDerivedTypeSpec())}) {
-          evaluate::SayWithDeclaration(context_.messages(), &*bad, at_,
-              "Deallocation of polymorphic non-coarray component '%s' is not permitted in a PURE subprogram"_err_en_US,
-              bad.BuildResultDesignatorName());
-        }
-      }
-    }
-  }
 }
 
-void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &) {
+void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
   CHECK(!where_);
+  const auto &lhs{std::get<parser::DataRef>(stmt.t)};
+  const auto &rhs{std::get<parser::Expr>(stmt.t)};
+  auto lhsExpr{AnalyzeExpr(context_, lhs)};
+  auto rhsExpr{AnalyzeExpr(context_, rhs)};
+  CheckForImpureCall(lhsExpr);
+  CheckForImpureCall(rhsExpr);
+  // TODO: CheckForImpureCall() in the bounds / bounds remappings
   if (forall_) {
     // TODO: Warn if some name in forall_->activeNames or its outer
     // contexts does not appear on LHS
   }
+  if (lhsExpr && rhsExpr) {
+    CheckForPureContext(*lhsExpr, *rhsExpr, rhs.source, true /* => */);
+  }
   // TODO continue here, using CheckPointerAssignment()
+  // TODO: analyze the bounds / bounds remappings
 }
 
 void AssignmentContext::Analyze(const parser::WhereStmt &stmt) {
@@ -563,6 +558,117 @@ void AssignmentContext::CheckForImpureCall(
   }
 }
 
+// C1594 checks
+static bool IsPointerDummyOfPureFunction(const Symbol &x) {
+  return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) &&
+      x.owner().symbol() && IsFunction(*x.owner().symbol());
+}
+
+static const char *WhyBaseObjectIsSuspicious(
+    const Symbol &x, const Scope &scope) {
+  // See C1594, first paragraph.  These conditions enable checks on both
+  // left-hand and right-hand sides in various circumstances.
+  if (IsHostAssociated(x, scope)) {
+    return "host-associated";
+  } else if (IsUseAssociated(x, scope)) {
+    return "USE-associated";
+  } else if (IsPointerDummyOfPureFunction(x)) {
+    return "a POINTER dummy argument of a PURE function";
+  } else if (IsIntentIn(x)) {
+    return "an INTENT(IN) dummy argument";
+  } else if (FindCommonBlockContaining(x)) {
+    return "in a COMMON block";
+  } else {
+    return nullptr;
+  }
+}
+
+// Checks C1594(1,2)
+void CheckDefinabilityInPureScope(parser::ContextualMessages &messages,
+    const Symbol &lhs, const Scope &scope) {
+  if (const char *why{WhyBaseObjectIsSuspicious(lhs, scope)}) {
+    evaluate::SayWithDeclaration(messages, &lhs,
+        "A PURE subprogram may not define '%s' because it is %s"_err_en_US,
+        lhs.name(), why);
+  }
+}
+
+static std::optional<std::string> GetPointerComponentDesignatorName(
+    const evaluate::Expr<evaluate::SomeType> &expr) {
+  if (auto type{evaluate::DynamicType::From(expr)}) {
+    if (type->category() == TypeCategory::Derived &&
+        !type->IsUnlimitedPolymorphic()) {
+      UltimateComponentIterator ultimates{type->GetDerivedTypeSpec()};
+      if (auto pointer{
+              std::find_if(ultimates.begin(), ultimates.end(), IsPointer)}) {
+        return pointer.BuildResultDesignatorName();
+      }
+    }
+  }
+  return std::nullopt;
+}
+
+// Checks C1594(5,6)
+void CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
+    const evaluate::Expr<evaluate::SomeType> &expr, const Scope &scope) {
+  if (const Symbol * base{GetFirstSymbol(expr)}) {
+    if (const char *why{WhyBaseObjectIsSuspicious(*base, scope)}) {
+      if (auto pointer{GetPointerComponentDesignatorName(expr)}) {
+        evaluate::SayWithDeclaration(messages, base,
+            "A PURE subprogram may not copy the value of '%s' because it is %s and has the POINTER component '%s'"_err_en_US,
+            base->name(), why, *pointer);
+      }
+    }
+  }
+}
+
+void AssignmentContext::CheckForPureContext(
+    const evaluate::Expr<evaluate::SomeType> &lhs,
+    const evaluate::Expr<evaluate::SomeType> &rhs, parser::CharBlock source,
+    bool isPointerAssignment) {
+  const Scope &scope{context_.FindScope(source)};
+  if (FindPureProcedureContaining(scope)) {
+    parser::ContextualMessages messages{at_, &context_.messages()};
+    if (evaluate::ExtractCoarrayRef(lhs)) {
+      messages.Say(
+          "A PURE subprogram may not define a coindexed object"_err_en_US);
+    } else if (const Symbol * base{GetFirstSymbol(lhs)}) {
+      CheckDefinabilityInPureScope(messages, *base, scope);
+    }
+    if (isPointerAssignment) {
+      if (const Symbol * base{GetFirstSymbol(rhs)}) {
+        if (const char *why{
+                WhyBaseObjectIsSuspicious(*base, scope)}) {  // C1594(3)
+          evaluate::SayWithDeclaration(messages, base,
+              "A PURE subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
+              base->name(), why);
+        }
+      }
+    } else {
+      if (auto type{evaluate::DynamicType::From(lhs)}) {
+        // C1596 checks for polymorphic deallocation in a PURE subprogram
+        // due to automatic reallocation on assignment
+        if (type->IsPolymorphic()) {
+          Say(at_,
+              "Deallocation of polymorphic object is not permitted in a PURE subprogram"_err_en_US);
+        }
+        if (type->category() == TypeCategory::Derived &&
+            !type->IsUnlimitedPolymorphic()) {
+          const DerivedTypeSpec &derived{type->GetDerivedTypeSpec()};
+          if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
+                  derived)}) {
+            evaluate::SayWithDeclaration(messages, &*bad,
+                "Deallocation of polymorphic non-coarray component '%s' is not permitted in a PURE subprogram"_err_en_US,
+                bad.BuildResultDesignatorName());
+          } else {
+            CheckCopyabilityInPureScope(messages, rhs, scope);
+          }
+        }
+      }
+    }
+  }
+}
+
 MaskExpr AssignmentContext::GetMask(
     const parser::LogicalExpr &expr, bool defaultValue) {
   MaskExpr mask{defaultValue};
@@ -576,18 +682,6 @@ MaskExpr AssignmentContext::GetMask(
   return mask;
 }
 
-const Symbol *AssignmentContext::FindPureProcedureContaining(
-    parser::CharBlock source) const {
-
-  if (const semantics::Scope *
-      pure{semantics::FindPureProcedureContaining(
-          &context_.FindScope(source))}) {
-    return pure->symbol();
-  } else {
-    return nullptr;
-  }
-}
-
 void AnalyzeConcurrentHeader(
     SemanticsContext &context, const parser::ConcurrentHeader &header) {
   AssignmentContext{context}.Analyze(header);

flang/lib/semantics/assignment.h

@@ -55,6 +55,13 @@ extern template class Fortran::common::Indirection<
     Fortran::semantics::AssignmentContext>;
 
 namespace Fortran::semantics {
+// Applies checks from C1594(1-2) on definitions in PURE subprograms
+void CheckDefinabilityInPureScope(
+    parser::ContextualMessages &, const Symbol &, const Scope &);
+// Applies checks from C1594(5-6) on copying pointers in PURE subprograms
+void CheckCopyabilityInPureScope(parser::ContextualMessages &,
+    const evaluate::Expr<evaluate::SomeType> &, const Scope &);
+
 class AssignmentChecker : public virtual BaseChecker {
 public:
   explicit AssignmentChecker(SemanticsContext &);