[flang-commits] [PATCH] D126151: [flang] Accept defined assignment with CLASS(*) RHS

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: vdonaldson.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
Herald added a project: All.
klausler requested review of this revision.

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.


https://reviews.llvm.org/D126151

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


Index: flang/test/Semantics/defined-ops.f90
===================================================================
--- flang/test/Semantics/defined-ops.f90
+++ flang/test/Semantics/defined-ops.f90
@@ -69,6 +69,10 @@
       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 @@
     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
-
Index: flang/lib/Semantics/tools.cpp
===================================================================
--- flang/lib/Semantics/tools.cpp
+++ flang/lib/Semantics/tools.cpp
@@ -103,9 +103,12 @@
   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) {


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D126151.431208.patch
Type: text/x-patch
Size: 1412 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20220522/7f8655f8/attachment.bin>