[flang-commits] [flang] [flang] Allow defined assignment to CLASS(*) (PR #124817)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/124817

An unlimited polymorphic left-hand side variable is acceptable in the definition of a defined assignment subroutine.

Fixes https://github.com/llvm/llvm-project/issues/124621.

>From 0a169eea7896583690ccdb37c9132ef1683052a5 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 28 Jan 2025 10:37:50 -0800
Subject: [PATCH] [flang] Allow defined assignment to CLASS(*)

An unlimited polymorphic left-hand side variable is acceptable in
the definition of a defined assignment subroutine.

Fixes https://github.com/llvm/llvm-project/issues/124621.
---
 flang/lib/Semantics/tools.cpp      |  6 ----
 flang/test/Semantics/bug124621.f90 | 46 ++++++++++++++++++++++++++++++
 2 files changed, 46 insertions(+), 6 deletions(-)
 create mode 100644 flang/test/Semantics/bug124621.f90

diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 013d006e614b4b..9ebfbbb5317b66 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -137,12 +137,6 @@ Tristate IsDefinedAssignment(
   if (!lhsType || !rhsType) {
     return Tristate::No; // error or rhs is untyped
   }
-  if (lhsType->IsUnlimitedPolymorphic()) {
-    return Tristate::No;
-  }
-  if (rhsType->IsUnlimitedPolymorphic()) {
-    return Tristate::Maybe;
-  }
   TypeCategory lhsCat{lhsType->category()};
   TypeCategory rhsCat{rhsType->category()};
   if (rhsRank > 0 && lhsRank != rhsRank) {
diff --git a/flang/test/Semantics/bug124621.f90 b/flang/test/Semantics/bug124621.f90
new file mode 100644
index 00000000000000..1106ed4a25c493
--- /dev/null
+++ b/flang/test/Semantics/bug124621.f90
@@ -0,0 +1,46 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  type t1
+   contains
+    procedure, pass(from) :: defAsst1
+    generic :: assignment(=) => defAsst1
+  end type
+  type t2
+  end type
+  type t3
+  end type
+  interface assignment(=)
+    module procedure defAsst2
+  end interface
+ contains
+  subroutine defAsst1(to,from)
+    class(*), intent(out) :: to
+    class(t1), intent(in) :: from
+  end
+  subroutine defAsst2(to,from)
+    class(*), intent(out) :: to
+    class(t2), intent(in) :: from
+  end
+end
+
+program test
+  use m
+  type(t1) x1
+  type(t2) x2
+  type(t3) x3
+  j = x1
+  j = x2
+  !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types INTEGER(4) and TYPE(t3)
+  j = x3
+  x1 = x1
+  x1 = x2
+  !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t1) and TYPE(t3)
+  x1 = x3
+  x2 = x1
+  x2 = x2
+  !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t2) and TYPE(t3)
+  x2 = x3
+  x3 = x1
+  x3 = x2
+  x3 = x3
+end