[flang] Better handling of weird pointer assignment case (#120628)

F'2023 C1017 permits the assignment of an unlimited polymorphic data
target to a monomorphic LHS pointer when the LHS pointer has a sequence
derived type (BIND(C) or SEQUENCE attribute). We allowed for this in
pointer assignments that don't have a function reference as their RHS.
Extend this support to function references, and also ensure that rank
compatibility is still checked.

Author: klausler

flang/lib/Semantics/pointer-assignment.cpp

@@ -76,6 +76,7 @@ class PointerAssignmentChecker {
       const Procedure * = nullptr,
       const evaluate::SpecificIntrinsic *specific = nullptr);
   bool LhsOkForUnlimitedPoly() const;
+  std::optional<MessageFormattedText> CheckRanks(const TypeAndShape &rhs) const;
   template <typename... A> parser::Message *Say(A &&...);
   template <typename FeatureOrUsageWarning, typename... A>
   parser::Message *Warn(FeatureOrUsageWarning, A &&...);
@@ -278,10 +279,19 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
   } else if (lhsType_) {
     const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
     CHECK(frTypeAndShape);
-    if (!lhsType_->IsCompatibleWith(foldingContext_.messages(), *frTypeAndShape,
-            "pointer", "function result",
-            /*omitShapeConformanceCheck=*/isBoundsRemapping_ || isAssumedRank_,
-            evaluate::CheckConformanceFlags::BothDeferredShape)) {
+    if (frTypeAndShape->type().IsUnlimitedPolymorphic() &&
+        LhsOkForUnlimitedPoly()) {
+      // Special case exception to type checking (F'2023 C1017);
+      // still check rank compatibility.
+      if (auto msg{CheckRanks(*frTypeAndShape)}) {
+        Say(*msg);
+        return false;
+      }
+    } else if (!lhsType_->IsCompatibleWith(foldingContext_.messages(),
+                   *frTypeAndShape, "pointer", "function result",
+                   /*omitShapeConformanceCheck=*/isBoundsRemapping_ ||
+                       isAssumedRank_,
+                   evaluate::CheckConformanceFlags::BothDeferredShape)) {
       return false; // IsCompatibleWith() emitted message
     }
   }
@@ -324,27 +334,17 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
         msg = "Pointer must be VOLATILE when target is a"
               " VOLATILE coarray"_err_en_US;
       }
+    } else if (auto m{CheckRanks(*rhsType)}) {
+      msg = std::move(*m);
     } else if (rhsType->type().IsUnlimitedPolymorphic()) {
       if (!LhsOkForUnlimitedPoly()) {
         msg = "Pointer type must be unlimited polymorphic or non-extensible"
               " derived type when target is unlimited polymorphic"_err_en_US;
       }
-    } else {
-      if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) {
-        msg = MessageFormattedText{
-            "Target type %s is not compatible with pointer type %s"_err_en_US,
-            rhsType->type().AsFortran(), lhsType_->type().AsFortran()};
-
-      } else if (!isBoundsRemapping_ &&
-          !lhsType_->attrs().test(TypeAndShape::Attr::AssumedRank)) {
-        int lhsRank{lhsType_->Rank()};
-        int rhsRank{rhsType->Rank()};
-        if (lhsRank != rhsRank) {
-          msg = MessageFormattedText{
-              "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank,
-              rhsRank};
-        }
-      }
+    } else if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) {
+      msg = MessageFormattedText{
+          "Target type %s is not compatible with pointer type %s"_err_en_US,
+          rhsType->type().AsFortran(), lhsType_->type().AsFortran()};
     }
   }
   if (msg) {
@@ -434,6 +434,21 @@ bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const {
   }
 }
 
+std::optional<MessageFormattedText> PointerAssignmentChecker::CheckRanks(
+    const TypeAndShape &rhs) const {
+  if (!isBoundsRemapping_ &&
+      !lhsType_->attrs().test(TypeAndShape::Attr::AssumedRank)) {
+    int lhsRank{lhsType_->Rank()};
+    int rhsRank{rhs.Rank()};
+    if (lhsRank != rhsRank) {
+      return MessageFormattedText{
+          "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank,
+          rhsRank};
+    }
+  }
+  return std::nullopt;
+}
+
 template <typename... A>
 parser::Message *PointerAssignmentChecker::Say(A &&...x) {
   auto *msg{foldingContext_.messages().Say(std::forward<A>(x)...)};

flang/test/Semantics/assign16.f90

@@ -0,0 +1,46 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! The RHS of a pointer assignment can be unlimited polymorphic
+! if the LHS is a sequence type.
+program main
+  type nonSeqType
+    integer j
+  end type
+  type seqType
+    sequence
+    integer j
+  end type
+  type(nonSeqType), target :: xNonSeq = nonSeqType(1)
+  type(nonSeqType), pointer :: pNonSeq
+  type(seqType), target :: xSeq = seqType(1), aSeq(1)
+  type(seqType), pointer :: pSeq, paSeq(:)
+  !ERROR: function result type 'CLASS(*)' is not compatible with pointer type 'nonseqtype'
+  pNonSeq => polyPtr(xNonSeq)
+  pSeq => polyPtr(xSeq) ! ok
+  !ERROR: Pointer has rank 1 but target has rank 0
+  paSeq => polyPtr(xSeq)
+  !ERROR: Pointer has rank 0 but target has rank 1
+  pSeq => polyPtrArr(aSeq)
+ contains
+  function polyPtr(target)
+    class(*), intent(in), target :: target
+    class(*), pointer :: polyPtr
+    polyPtr => target
+  end
+  function polyPtrArr(target)
+    class(*), intent(in), target :: target(:)
+    class(*), pointer :: polyPtrArr(:)
+    polyPtrArr => target
+  end
+  function err1(target)
+    class(*), intent(in), target :: target(:)
+    class(*), pointer :: err1
+    !ERROR: Pointer has rank 0 but target has rank 1
+    err1 => target
+  end
+  function err2(target)
+    class(*), intent(in), target :: target
+    class(*), pointer :: err2(:)
+    !ERROR: Pointer has rank 1 but target has rank 0
+    err2 => target
+  end
+end