[flang] Don't check dummy vs. actual result rank for assumed-rank poi… (llvm#66237)

…nters

When associating a function result pointer as an actual argument with a
dummy pointer that is assumed-rank, don't emit a bogus error.

Author: klausler

flang/lib/Semantics/check-call.cpp

@@ -329,10 +329,11 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       typesCompatible = true;
     }
   }
+  bool dummyIsAssumedRank{dummy.type.attrs().test(
+      characteristics::TypeAndShape::Attr::AssumedRank)};
   if (typesCompatible) {
     if (isElemental) {
-    } else if (dummy.type.attrs().test(
-                   characteristics::TypeAndShape::Attr::AssumedRank)) {
+    } else if (dummyIsAssumedRank) {
     } else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
     } else if (dummyRank > 0 && !dummyIsAllocatableOrPointer &&
         !dummy.type.attrs().test(
@@ -462,8 +463,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           : nullptr};
   int actualRank{actualType.Rank()};
   bool actualIsPointer{evaluate::IsObjectPointer(actual, foldingContext)};
-  bool dummyIsAssumedRank{dummy.type.attrs().test(
-      characteristics::TypeAndShape::Attr::AssumedRank)};
   if (dummy.type.attrs().test(
           characteristics::TypeAndShape::Attr::AssumedShape)) {
     // 15.5.2.4(16)
@@ -682,8 +681,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   if (dummyIsPointer) {
     if (actualIsPointer || dummy.intent == common::Intent::In) {
       if (scope) {
-        semantics::CheckPointerAssignment(
-            context, messages.at(), dummyName, dummy, actual, *scope);
+        semantics::CheckPointerAssignment(context, messages.at(), dummyName,
+            dummy, actual, *scope,
+            /*isAssumedRank=*/dummyIsAssumedRank);
       }
     } else if (!actualIsPointer) {
       messages.Say(

flang/lib/Semantics/check-declarations.cpp

@@ -1067,7 +1067,8 @@ void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
           SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
           SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
           CheckPointerAssignment(context_, lhs, rhs,
-              GetProgramUnitOrBlockConstructContaining(symbol));
+              GetProgramUnitOrBlockConstructContaining(symbol),
+              /*isBoundsRemapping=*/false, /*isAssumedRank=*/false);
         }
       }
     }

flang/lib/Semantics/data-to-inits.cpp

@@ -384,8 +384,9 @@ bool DataInitializationCompiler<DSV>::InitElement(
       return true;
     } else if (isProcPointer) {
       if (evaluate::IsProcedure(*expr)) {
-        if (CheckPointerAssignment(
-                exprAnalyzer_.context(), designator, *expr, DEREF(scope_))) {
+        if (CheckPointerAssignment(exprAnalyzer_.context(), designator, *expr,
+                DEREF(scope_),
+                /*isBoundsRemapping=*/false, /*isAssumedRank=*/false)) {
           if (lastSymbol->has<ProcEntityDetails>()) {
             GetImage().AddPointer(offsetSymbol.offset(), *expr);
             return true;

flang/lib/Semantics/pointer-assignment.cpp

@@ -56,6 +56,7 @@ class PointerAssignmentChecker {
   PointerAssignmentChecker &set_isContiguous(bool);
   PointerAssignmentChecker &set_isVolatile(bool);
   PointerAssignmentChecker &set_isBoundsRemapping(bool);
+  PointerAssignmentChecker &set_isAssumedRank(bool);
   PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
   bool CheckLeftHandSide(const SomeExpr &);
   bool Check(const SomeExpr &);
@@ -88,6 +89,7 @@ class PointerAssignmentChecker {
   bool isContiguous_{false};
   bool isVolatile_{false};
   bool isBoundsRemapping_{false};
+  bool isAssumedRank_{false};
   const Symbol *pointerComponentLHS_{nullptr};
 };
 
@@ -115,6 +117,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
   return *this;
 }
 
+PointerAssignmentChecker &PointerAssignmentChecker::set_isAssumedRank(
+    bool isAssumedRank) {
+  isAssumedRank_ = isAssumedRank;
+  return *this;
+}
+
 PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS(
     const Symbol *symbol) {
   pointerComponentLHS_ = symbol;
@@ -263,7 +271,7 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
     CHECK(frTypeAndShape);
     if (!lhsType_->IsCompatibleWith(foldingContext_.messages(), *frTypeAndShape,
             "pointer", "function result",
-            isBoundsRemapping_ /*omit shape check*/,
+            /*omitShapeConformanceCheck=*/isBoundsRemapping_ || isAssumedRank_,
             evaluate::CheckConformanceFlags::BothDeferredShape)) {
       return false; // IsCompatibleWith() emitted message
     }
@@ -489,17 +497,20 @@ static bool CheckPointerBounds(
 bool CheckPointerAssignment(SemanticsContext &context,
     const evaluate::Assignment &assignment, const Scope &scope) {
   return CheckPointerAssignment(context, assignment.lhs, assignment.rhs, scope,
-      CheckPointerBounds(context.foldingContext(), assignment));
+      CheckPointerBounds(context.foldingContext(), assignment),
+      /*isAssumedRank=*/false);
 }
 
 bool CheckPointerAssignment(SemanticsContext &context, const SomeExpr &lhs,
-    const SomeExpr &rhs, const Scope &scope, bool isBoundsRemapping) {
+    const SomeExpr &rhs, const Scope &scope, bool isBoundsRemapping,
+    bool isAssumedRank) {
   const Symbol *pointer{GetLastSymbol(lhs)};
   if (!pointer) {
     return false; // error was reported
   }
   PointerAssignmentChecker checker{context, scope, *pointer};
   checker.set_isBoundsRemapping(isBoundsRemapping);
+  checker.set_isAssumedRank(isAssumedRank);
   bool lhsOk{checker.CheckLeftHandSide(lhs)};
   bool rhsOk{checker.Check(rhs)};
   return lhsOk && rhsOk; // don't short-circuit
@@ -514,19 +525,22 @@ bool CheckStructConstructorPointerComponent(SemanticsContext &context,
 
 bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
     const std::string &description, const DummyDataObject &lhs,
-    const SomeExpr &rhs, const Scope &scope) {
+    const SomeExpr &rhs, const Scope &scope, bool isAssumedRank) {
   return PointerAssignmentChecker{context, scope, source, description}
       .set_lhsType(common::Clone(lhs.type))
       .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
       .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
+      .set_isAssumedRank(isAssumedRank)
       .Check(rhs);
 }
 
 bool CheckInitialDataPointerTarget(SemanticsContext &context,
     const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) {
   return evaluate::IsInitialDataTarget(
              init, &context.foldingContext().messages()) &&
-      CheckPointerAssignment(context, pointer, init, scope);
+      CheckPointerAssignment(context, pointer, init, scope,
+          /*isBoundsRemapping=*/false,
+          /*isAssumedRank=*/false);
 }
 
 } // namespace Fortran::semantics

flang/lib/Semantics/pointer-assignment.h

@@ -26,11 +26,12 @@ class Symbol;
 bool CheckPointerAssignment(
     SemanticsContext &, const evaluate::Assignment &, const Scope &);
 bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs,
-    const SomeExpr &rhs, const Scope &, bool isBoundsRemapping = false);
+    const SomeExpr &rhs, const Scope &, bool isBoundsRemapping,
+    bool isAssumedRank);
 bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source,
     const std::string &description,
     const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs,
-    const Scope &);
+    const Scope &, bool isAssumedRank);
 
 bool CheckStructConstructorPointerComponent(
     SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);

flang/test/Semantics/call39.f90

@@ -0,0 +1,27 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
+! Tests actual/dummy pointer argument shape mismatches
+module m
+ contains
+  subroutine s0(p)
+    real, pointer, intent(in) :: p
+  end
+  subroutine s1(p)
+    real, pointer, intent(in) :: p(:)
+  end
+  subroutine sa(p)
+    real, pointer, intent(in) :: p(..)
+  end
+  subroutine test
+    real, pointer :: a0, a1(:)
+    call s0(null(a0)) ! ok
+    !ERROR: Rank of dummy argument is 0, but actual argument has rank 1
+    !ERROR: Rank of pointer is 0, but function result has rank 1
+    call s0(null(a1))
+    !ERROR: Rank of dummy argument is 1, but actual argument has rank 0
+    !ERROR: Rank of pointer is 1, but function result has rank 0
+    call s1(null(a0))
+    call s1(null(a1)) ! ok
+    call sa(null(a0)) ! ok
+    call sa(null(a1)) ! ok
+  end
+end