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

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.

Differential Revision: https://reviews.llvm.org/D142748

diff --git a/flang/lib/Semantics/assignment.cpp b/flang/lib/Semantics/assignment.cpp
index 3c3f263..efe68be 100644 (file)
--- a/flang/lib/Semantics/assignment.cpp
+++ b/flang/lib/Semantics/assignment.cpp
@@ -45,7 +45,7 @@ public:
 
 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) {
@@ -75,7 +75,8 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
       }
     }
     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);
     }
@@ -86,7 +87,9 @@ 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)};
@@ -126,7 +129,8 @@ bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
 }
 
 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;
@@ -143,7 +147,7 @@ bool AssignmentContext::CheckForPureContext(const SomeExpr &rhs,
         return false;
       }
     }
-  } else {
+  } else if (!isDefinedAssignment) {
     return CheckCopyabilityInPureScope(messages, rhs, scope);
   }
   return true;

diff --git a/flang/test/Semantics/assign04.f90 b/flang/test/Semantics/assign04.f90
index f1ec238..a00ca52 100644 (file)
--- a/flang/test/Semantics/assign04.f90
+++ b/flang/test/Semantics/assign04.f90
@@ -207,20 +207,20 @@ subroutine s13()
       !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
@@ -239,3 +239,42 @@ subroutine s13()
     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