[flang] Catch obscure error in defined assignment

A subroutine that implements a defined assignment cannot have
a dummy argument for its second operand (the RHS of the assignment)
with the POINTER or ALLOCATABLE attributes, since the RHS of
an assignment is always an expression.  This problem is flagged
as a fatal error in other compilers, so let's make it fatal here
as well.

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

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index d9c13df..6746d47 100644 (file)
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1565,6 +1565,12 @@ bool CheckHelper::CheckDefinedAssignmentArg(
         msg =
             "In defined assignment subroutine '%s', second dummy"
             " argument '%s' must have INTENT(IN) or VALUE attribute"_err_en_US;
+      } else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {
+        msg =
+            "In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;
+      } else if (dataObject->attrs.test(DummyDataObject::Attr::Allocatable)) {
+        msg =
+            "In defined assignment subroutine '%s', second dummy argument '%s' must not be an allocatable"_err_en_US;
       }
     } else {
       DIE("pos must be 0 or 1");

diff --git a/flang/test/Semantics/resolve65.f90 b/flang/test/Semantics/resolve65.f90
index d1fb26d..f4a8d6b 100644 (file)
--- a/flang/test/Semantics/resolve65.f90
+++ b/flang/test/Semantics/resolve65.f90
@@ -65,6 +65,18 @@ module m2
         end
       end interface
     end
+    !ERROR: In defined assignment subroutine 's3', second dummy argument 'y' must not be a pointer
+    subroutine s3(x, y)
+      import t
+      type(t), intent(out) :: x
+      type(t), intent(in), pointer :: y
+    end
+    !ERROR: In defined assignment subroutine 's4', second dummy argument 'y' must not be an allocatable
+    subroutine s4(x, y)
+      import t
+      type(t), intent(out) :: x
+      type(t), intent(in), allocatable :: y
+    end
   end interface
 end