[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

 
 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) {

       }
     }
     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);
     }

   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)};

 }
 
 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;

         return false;
       }
     }
-  } else {
+  } else if (!isDefinedAssignment) {
     return CheckCopyabilityInPureScope(messages, rhs, scope);
   }
   return true;

flang/test/Semantics/assign04.f90

       !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

     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