[flang-commits] [flang] [flang] Correct definability checking for INTENT(IN) pointers (PR #74158)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/74158

An INTENT(IN) attribute on a pointer dummy argument prevents modification of the pointer itself only, not modification of any component of its target.  Fix this case without breaking definability checking for pointer components of non-pointer INTENT(IN) dummy arguments.

>From aa35454a3d186ffa01fe9958bdf6bef7de2488b3 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 1 Dec 2023 15:29:52 -0800
Subject: [PATCH] [flang] Correct definability checking for INTENT(IN) pointers

An INTENT(IN) attribute on a pointer dummy argument prevents
modification of the pointer itself only, not modification of
any component of its target.  Fix this case without breaking
definability checking for pointer components of non-pointer
INTENT(IN) dummy arguments.
---
 flang/lib/Semantics/definable.cpp      | 14 ++++++++++++--
 flang/test/Semantics/definable01.f90   | 11 ++++++++++-
 flang/test/Semantics/select-rank03.f90 |  8 ++++----
 3 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index d5ffcabc7233ca9..270fecdcc30ab34 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -112,7 +112,8 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
     return BlameSymbol(at, "'%s' is not a variable"_en_US, original);
   } else if (IsProtected(ultimate) && IsUseAssociated(original, scope)) {
     return BlameSymbol(at, "'%s' is protected in this scope"_en_US, original);
-  } else if (IsIntentIn(ultimate)) {
+  } else if (IsIntentIn(ultimate) && !isPointerDefinition &&
+      !IsPointer(ultimate)) {
     return BlameSymbol(
         at, "'%s' is an INTENT(IN) dummy argument"_en_US, original);
   }
@@ -165,8 +166,17 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
 static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
   const Symbol &ultimate{original.GetUltimate()};
+  if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()}) {
+    if (auto dataRef{
+            evaluate::ExtractDataRef(*association->expr(), true, true)}) {
+      return WhyNotDefinableLast(at, scope, flags, dataRef->GetLastSymbol());
+    }
+  }
   if (flags.test(DefinabilityFlag::PointerDefinition)) {
-    if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
+    if (IsIntentIn(ultimate)) {
+      return BlameSymbol(
+          at, "'%s' is an INTENT(IN) pointer dummy argument"_en_US, original);
+    } else if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
       if (!IsAllocatableOrObjectPointer(&ultimate)) {
         return BlameSymbol(
             at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
diff --git a/flang/test/Semantics/definable01.f90 b/flang/test/Semantics/definable01.f90
index fff493fe7a4152f..f3975571f7ffcac 100644
--- a/flang/test/Semantics/definable01.f90
+++ b/flang/test/Semantics/definable01.f90
@@ -71,7 +71,7 @@ subroutine test3(objp, procp)
     real, intent(in), pointer :: objp
     procedure(sin), pointer, intent(in) :: procp
     !CHECK: error: Actual argument associated with INTENT(IN OUT) dummy argument 'op=' is not definable
-    !CHECK: because: 'objp' is an INTENT(IN) dummy argument
+    !CHECK: because: 'objp' is an INTENT(IN) pointer dummy argument
     call test3a(objp)
     !CHECK: error: Actual argument associated with procedure pointer dummy argument 'pp=' may not be INTENT(IN)
     call test3b(procp)
@@ -82,4 +82,13 @@ subroutine test3a(op)
   subroutine test3b(pp)
     procedure(sin), pointer, intent(in out) :: pp
   end subroutine
+  subroutine test4(p)
+    type(ptype), pointer, intent(in) :: p
+    p%x = 1.
+    p%ptr = 1. ! ok
+    nullify(p%ptr) ! ok
+    !CHECK: error: 'p' may not appear in NULLIFY
+    !CHECK: because: 'p' is an INTENT(IN) pointer dummy argument
+    nullify(p)
+  end
 end module
diff --git a/flang/test/Semantics/select-rank03.f90 b/flang/test/Semantics/select-rank03.f90
index 8a965e950d38513..7716659ef172dfd 100644
--- a/flang/test/Semantics/select-rank03.f90
+++ b/flang/test/Semantics/select-rank03.f90
@@ -136,20 +136,20 @@ subroutine undefinable(p)
     select rank(p)
     rank (0)
       !ERROR: The left-hand side of a pointer assignment is not definable
-      !BECAUSE: 'p' is an INTENT(IN) dummy argument
+      !BECAUSE: 'p' is an INTENT(IN) pointer dummy argument
       p => t
       !ERROR: Name in DEALLOCATE statement is not definable
-      !BECAUSE: 'p' is an INTENT(IN) dummy argument
+      !BECAUSE: 'p' is an INTENT(IN) pointer dummy argument
       deallocate(p)
     !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
     rank (*)
       !ERROR: Whole assumed-size array 'p' may not appear here without subscripts
       !ERROR: Name in DEALLOCATE statement is not definable
-      !BECAUSE: 'p' is an INTENT(IN) dummy argument
+      !BECAUSE: 'p' is an INTENT(IN) pointer dummy argument
       deallocate(p)
     rank default
       !ERROR: Name in DEALLOCATE statement is not definable
-      !BECAUSE: 'p' is an INTENT(IN) dummy argument
+      !BECAUSE: 'p' is an INTENT(IN) pointer dummy argument
       deallocate(p)
     end select
   end