[flang-commits] [flang] 0363a16 - [flang] Fix bogus error from assignment to CLASS(*)

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-03-25T11:17:01-07:00
New Revision: 0363a164b6962eaab2784106f2d92c9e75fbeecc

URL: https://github.com/llvm/llvm-project/commit/0363a164b6962eaab2784106f2d92c9e75fbeecc
DIFF: https://github.com/llvm/llvm-project/commit/0363a164b6962eaab2784106f2d92c9e75fbeecc.diff

LOG: [flang] Fix bogus error from assignment to CLASS(*)

Assignment semantics was coughing up bad errors and crashes for
intrinsic assignments to unlimited polymorphic entities while
looking for any (impossible) user defined ASSIGNMENT(=) generic
or intrinsic type conversion.

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

Added: 
    

Modified: 
    flang/lib/Semantics/expression.cpp
    flang/lib/Semantics/tools.cpp
    flang/test/Semantics/resolve63.f90
    flang/test/Semantics/selecttype03.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index fcfe98ef90ac6..342f34164f176 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -3595,7 +3595,8 @@ const Symbol *ArgumentAnalyzer::FindBoundOp(
 void ArgumentAnalyzer::AddAssignmentConversion(
     const DynamicType &lhsType, const DynamicType &rhsType) {
   if (lhsType.category() == rhsType.category() &&
-      lhsType.kind() == rhsType.kind()) {
+      (lhsType.category() == TypeCategory::Derived ||
+          lhsType.kind() == rhsType.kind())) {
     // no conversion necessary
   } else if (auto rhsExpr{evaluate::ConvertToType(lhsType, MoveExpr(1))}) {
     std::optional<parser::CharBlock> source;
@@ -3684,7 +3685,10 @@ std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
   if (i >= actuals_.size() || !actuals_[i]) {
     return "missing argument";
   } else if (std::optional<DynamicType> type{GetType(i)}) {
-    return type->category() == TypeCategory::Derived
+    return type->IsAssumedType()         ? "TYPE(*)"s
+        : type->IsUnlimitedPolymorphic() ? "CLASS(*)"s
+        : type->IsPolymorphic()          ? "CLASS("s + type->AsFortran() + ')'
+        : type->category() == TypeCategory::Derived
         ? "TYPE("s + type->AsFortran() + ')'
         : type->category() == TypeCategory::Character
         ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'

diff  --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 1a2d931825bf4..9bad51dd4371b 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -103,6 +103,9 @@ Tristate IsDefinedAssignment(
   if (!lhsType || !rhsType) {
     return Tristate::No; // error or rhs is untyped
   }
+  if (lhsType->IsUnlimitedPolymorphic() || rhsType->IsUnlimitedPolymorphic()) {
+    return Tristate::No;
+  }
   TypeCategory lhsCat{lhsType->category()};
   TypeCategory rhsCat{rhsType->category()};
   if (rhsRank > 0 && lhsRank != rhsRank) {

diff  --git a/flang/test/Semantics/resolve63.f90 b/flang/test/Semantics/resolve63.f90
index fa3ab84fc0b99..af6c2e4d94d16 100644
--- a/flang/test/Semantics/resolve63.f90
+++ b/flang/test/Semantics/resolve63.f90
@@ -265,9 +265,9 @@ subroutine test(x, y, z)
     i = x + y
     i = x + i
     i = y + i
-    !ERROR: No intrinsic or user-defined OPERATOR(+) matches operand types TYPE(t2) and TYPE(t1)
+    !ERROR: No intrinsic or user-defined OPERATOR(+) matches operand types CLASS(t2) and CLASS(t1)
     i = y + x
-    !ERROR: No intrinsic or user-defined OPERATOR(+) matches operand types INTEGER(4) and TYPE(t1)
+    !ERROR: No intrinsic or user-defined OPERATOR(+) matches operand types INTEGER(4) and CLASS(t1)
     i = i + x
   end
 end
@@ -344,3 +344,18 @@ subroutine test
     call generic(null(), null())
   end subroutine
 end
+
+! Ensure no bogus errors for assignments to CLASS(*) allocatable
+module m10
+  type :: t1
+    integer :: n
+  end type
+ contains
+  subroutine test
+    class(*), allocatable :: poly
+    poly = 1
+    poly = 3.14159
+    poly = 'Il faut imaginer Sisyphe heureux'
+    poly = t1(1)
+  end subroutine
+end module

diff  --git a/flang/test/Semantics/selecttype03.f90 b/flang/test/Semantics/selecttype03.f90
index 73274e214e47d..45ecf51164fe9 100644
--- a/flang/test/Semantics/selecttype03.f90
+++ b/flang/test/Semantics/selecttype03.f90
@@ -99,11 +99,11 @@ function foo(i)
     integer :: i
     class(t1),DIMENSION(:),allocatable :: foo
     integer, dimension(2) :: U
-    U = (/ 1,2 /)  
+    U = (/ 1,2 /)
     if (i>0) then
       foo = array1(2,U)
     else if (i<0) then
-      !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t1) and TYPE(t2)
+      !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types CLASS(t1) and CLASS(t2)
       foo = array2(2,U)
     end if
   end function