[flang-commits] [flang] 48a8a3e - [flang] Accept defined assignment with CLASS(*) RHS

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-05-24T13:41:28-07:00
New Revision: 48a8a3eb2f5646c9ac847a07f42316a81e025c23

URL: https://github.com/llvm/llvm-project/commit/48a8a3eb2f5646c9ac847a07f42316a81e025c23
DIFF: https://github.com/llvm/llvm-project/commit/48a8a3eb2f5646c9ac847a07f42316a81e025c23.diff

LOG: [flang] Accept defined assignment with CLASS(*) RHS

A utility predicate in semantics was incorrectly determining that
an INTERFACE ASSIGNMENT(=) (or other form of generic) could not have
a specific procedure with an unlimited polymorphic second argument.
This led to a crash later in expression analysis.  Fix, and
extend tests.

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

Added: 
    

Modified: 
    flang/lib/Semantics/tools.cpp
    flang/test/Semantics/defined-ops.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 7e6d1d0aecb3..807c0152eb9a 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -103,9 +103,12 @@ Tristate IsDefinedAssignment(
   if (!lhsType || !rhsType) {
     return Tristate::No; // error or rhs is untyped
   }
-  if (lhsType->IsUnlimitedPolymorphic() || rhsType->IsUnlimitedPolymorphic()) {
+  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/defined-ops.f90 b/flang/test/Semantics/defined-ops.f90
index e46caeb82b94..18ed40364246 100644
--- a/flang/test/Semantics/defined-ops.f90
+++ b/flang/test/Semantics/defined-ops.f90
@@ -69,6 +69,10 @@ subroutine s1(x, y)
       class(t), intent(out) :: x
       integer, intent(in) :: y
     end
+    subroutine s2(x, y)
+      real, intent(out) :: x
+      class(*), intent(in) :: y
+    end
   end interface
   interface operator(+)
     integer function f(x, y)
@@ -77,12 +81,15 @@ integer function f(x, y)
     end
   end interface
 contains
-  subroutine test(x, y)
+  subroutine test(x, y, z)
     class(t) :: x, y
+    class(*), intent(in) :: z
+    real :: a
     !CHECK: CALL s1(x,2_4)
     x = 2
     !CHECK: i=f(x,y)
     i = x + y
+    !CHECK: CALL s2(a,z)
+    a = z
   end
 end
-