[flang] Accept pointer assignment w/ remapping to function result

When a pointer assignment with bounds remapping has a function
reference as its right-hand side, don't check for array conformance.

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

diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 098520c..4c9f946 100644 (file)
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -147,7 +147,7 @@ public:
   int Rank() const { return GetRank(shape_); }
   bool IsCompatibleWith(parser::ContextualMessages &, const TypeAndShape &that,
       const char *thisIs = "pointer", const char *thatIs = "target",
-      bool isElemental = false,
+      bool omitShapeConformanceCheck = false,
       enum CheckConformanceFlags::Flags = CheckConformanceFlags::None) const;
   std::optional<Expr<SubscriptInteger>> MeasureElementSizeInBytes(
       FoldingContext &, bool align) const;

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index c32c370..40263f6 100644 (file)
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -149,14 +149,15 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
 
 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
     const TypeAndShape &that, const char *thisIs, const char *thatIs,
-    bool isElemental, enum CheckConformanceFlags::Flags flags) const {
+    bool omitShapeConformanceCheck,
+    enum CheckConformanceFlags::Flags flags) const {
   if (!type_.IsTkCompatibleWith(that.type_)) {
     messages.Say(
         "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
         thatIs, that.AsFortran(), thisIs, AsFortran());
     return false;
   }
-  return isElemental ||
+  return omitShapeConformanceCheck ||
       CheckConformance(messages, shape_, that.shape_, flags, thisIs, thatIs)
           .value_or(true /*fail only when nonconformance is known now*/);
 }

diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 0fe8643..2b06525 100644 (file)
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -172,7 +172,8 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
     const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
     CHECK(frTypeAndShape);
     if (!lhsType_->IsCompatibleWith(context_.messages(), *frTypeAndShape,
-            "pointer", "function result", false /*elemental*/,
+            "pointer", "function result",
+            isBoundsRemapping_ /*omit shape check*/,
             evaluate::CheckConformanceFlags::BothDeferredShape)) {
       return false; // IsCompatibleWith() emitted message
     }

diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index 0c385b1..b743189 100644 (file)
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -218,6 +218,13 @@ contains
     p(1:5,1:5) => x(:,1:2)
     !OK - rhs has rank 1 and enough elements
     p(1:5,1:5) => y(1:100:2)
+    !OK - same, but from function result
+    p(1:5,1:5) => f()
+   contains
+    function f()
+      real, pointer :: f(:)
+      f => y
+    end function
   end
 
   subroutine s10