[flang] Don't apply intrinsic assignment check for PURE subprograms to defined assignment

[klausler]

Summary

A semantic constraint on assignments in PURE subprograms (C1594) applies
only to an intrinsic assignment and should not be checked in the case of
a defined assignment.

flang/lib/Semantics/assignment.cpp

public:
   template <typename A> void PushWhereContext(const A &);
   void PopWhereContext();
   void Analyze(const parser::AssignmentStmt &);
   void Analyze(const parser::PointerAssignmentStmt &);
   void Analyze(const parser::ConcurrentControl &);
 
 private:
   bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource,
-      bool isPointerAssignment);
+      bool isPointerAssignment, bool isDefinedAssignment);
   void CheckShape(parser::CharBlock, const SomeExpr *);
   template <typename... A>
   parser::Message *Say(parser::CharBlock at, A &&...args) {
     return &context_.Say(at, std::forward<A>(args)...);
   }
   evaluate::FoldingContext &foldingContext() {
     return context_.foldingContext();
   }
if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
     if (auto whyNot{WhyNotDefinable(lhsLoc, scope,
             DefinabilityFlags{DefinabilityFlag::VectorSubscriptIsOk}, lhs)}) {
       if (auto *msg{Say(lhsLoc,
               "Left-hand side of assignment is not definable"_err_en_US)}) {
         msg->Attach(std::move(*whyNot));
       }
     }
     auto rhsLoc{std::get<parser::Expr>(stmt.t).source};
-    CheckForPureContext(rhs, rhsLoc, false);
+    CheckForPureContext(rhs, rhsLoc, false /*not a pointer assignment*/,
+        std::holds_alternative<evaluate::ProcedureRef>(assignment->u));
     if (whereDepth_ > 0) {
       CheckShape(lhsLoc, &lhs);
     }
   }
 }
 
 void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
   CHECK(whereDepth_ == 0);
   if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
     const SomeExpr &rhs{assignment->rhs};
-    CheckForPureContext(rhs, std::get<parser::Expr>(stmt.t).source, true);
+    CheckForPureContext(rhs, std::get<parser::Expr>(stmt.t).source,
+        true /*this is a pointer assignment*/,
+        false /*not a defined assignment*/);
     parser::CharBlock at{context_.location().value()};
     auto restorer{foldingContext().messages().SetLocation(at)};
     const Scope &scope{context_.FindScope(at)};
     CheckPointerAssignment(foldingContext(), *assignment, scope);
   }
 }
 
 static std::optional<std::string> GetPointerComponentDesignatorName(
if (const char *why{
         return false;
       }
     }
   }
   return true;
 }
 
 bool AssignmentContext::CheckForPureContext(const SomeExpr &rhs,
-    parser::CharBlock rhsSource, bool isPointerAssignment) {
+    parser::CharBlock rhsSource, bool isPointerAssignment,
+    bool isDefinedAssignment) {
   const Scope &scope{context_.FindScope(rhsSource)};
   if (!FindPureProcedureContaining(scope)) {
     return true;
   }
   parser::ContextualMessages messages{
       context_.location().value(), &context_.messages()};
   if (isPointerAssignment) {
     if (const Symbol * base{GetFirstSymbol(rhs)}) {
       if (const char *why{WhyBaseObjectIsSuspicious(
               base->GetUltimate(), 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);
         return false;
       }
     }
-  } else {
+  } else if (!isDefinedAssignment) {
     return CheckCopyabilityInPureScope(messages, rhs, scope);
   }
   return true;
 }
 
 // 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape
 void AssignmentContext::CheckShape(parser::CharBlock at, const SomeExpr *expr) {
   if (auto shape{evaluate::GetShape(foldingContext(), expr)}) {

flang/test/Semantics/assign04.f90

subroutine s13()
   where ([1==1]) n='*' ! fine
   forall (j=1:1)
     !ERROR: The mask or variable must not be scalar
     where (j==1)
       !ERROR: Defined assignment in WHERE must be elemental, but 'ctor' is not
       !ERROR: The mask or variable must not be scalar
       x(j)='?'
       !ERROR: The mask or variable must not be scalar
-      n(j)='?' ! fine
+      n(j)='?'
     !ERROR: The mask or variable must not be scalar
     elsewhere (.false.)
       !ERROR: Defined assignment in WHERE must be elemental, but 'ctor' is not
       !ERROR: The mask or variable must not be scalar
       x(j)='1'
       !ERROR: The mask or variable must not be scalar
-      n(j)='1' ! fine
+      n(j)='1'
     elsewhere
       !ERROR: Defined assignment in WHERE must be elemental, but 'ctor' is not
       !ERROR: The mask or variable must not be scalar
       x(j)='9'
       !ERROR: The mask or variable must not be scalar
-      n(j)='9' ! fine
+      n(j)='9'
     end where
   end forall
   x='0' ! still fine
   n='0' ! still fine
  contains
   subroutine cToR(x, c)
     real, intent(out) :: x
     character, intent(in) :: c
   end subroutine
   subroutine cToRa(x, c)
     real, intent(out) :: x(:)
     character, intent(in) :: c
   end subroutine
   elemental subroutine cToI(n, c)
     integer, intent(out) :: n
     character, intent(in) :: c
   end subroutine
 end subroutine s13
+
+module m14
+  type t1
+    integer, pointer :: p
+   contains
+    procedure definedAsst1
+    generic :: assignment(=) => definedAsst1
+  end type
+  type t2
+    integer, pointer :: p
+  end type
+  interface assignment(=)
+    module procedure definedAsst2
+  end interface
+  type t3
+    integer, pointer :: p
+  end type
+ contains
+  pure subroutine definedAsst1(lhs,rhs)
+    class(t1), intent(in out) :: lhs
+    class(t1), intent(in) :: rhs
+  end subroutine
+  pure subroutine definedAsst2(lhs,rhs)
+    type(t2), intent(out) :: lhs
+    type(t2), intent(in) :: rhs
+  end subroutine
+  pure subroutine test(y1,y2,y3)
+    type(t1) x1
+    type(t1), intent(in) :: y1
+    type(t2) x2
+    type(t2), intent(in) :: y2
+    type(t3) x3
+    type(t3), intent(in) :: y3
+    x1 = y1 ! fine due to not being intrinsic assignment
+    x2 = y2 ! fine due to not being intrinsic assignment
+    !ERROR: A pure subprogram may not copy the value of 'y3' because it is an INTENT(IN) dummy argument and has the POINTER potential subobject component '%p'
+    x3 = y3
+  end subroutine
+end module m14