[flang] Extension: Allow POINTER,INTENT(IN) passed objects

[klausler]

ISO Fortran now accepts a non-pointer actual argument to associate with a dummy argument with the POINTER attribute if it is also INTENT(IN), so long as the actual argument is a valid target for the pointer. But passed-object dummy arguments still have a blanket prohibition against being pointers in the ISO standard. Relax that constraint in the case of INTENT(IN) so that passed objects can also benefit from the feature.

Fixes #172157.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

ISO Fortran now accepts a non-pointer actual argument to associate with a dummy argument with the POINTER attribute if it is also INTENT(IN), so long as the actual argument is a valid target for the pointer. But passed-object dummy arguments still have a blanket prohibition against being pointers in the ISO standard. Relax that constraint in the case of INTENT(IN) so that passed objects can also benefit from the feature.

Fixes #172157.

---

Full diff: https://github.com/llvm/llvm-project/pull/172175.diff

5 Files Affected:

• (modified) flang/docs/Extensions.md (+2)
• (modified) flang/include/flang/Support/Fortran-features.h (+1-1)
• (modified) flang/lib/Semantics/check-declarations.cpp (+12-3)
• (added) flang/test/Semantics/bug172157.f90 (+29)
• (modified) flang/test/Semantics/resolve52.f90 (+1-1)

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 593cd99147515..64b066e922297 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -459,6 +459,8 @@ end
   with an optional compilation-time warning.  When executed, it
   is treated as an 'nX' positioning control descriptor that skips
   over the same number of characters, without comparison.
+* A passed-object dummy argument is allowed to be a pointer so long
+  as it is `INTENT(IN)`.
 
 ### Extensions supported when enabled by options
 
diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h
index c7d0b7fca1d59..ef5c1a84ba3d7 100644
--- a/flang/include/flang/Support/Fortran-features.h
+++ b/flang/include/flang/Support/Fortran-features.h
@@ -56,7 +56,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     IgnoreIrrelevantAttributes, Unsigned, AmbiguousStructureConstructor,
     ContiguousOkForSeqAssociation, ForwardRefExplicitTypeDummy,
     InaccessibleDeferredOverride, CudaWarpMatchFunction, DoConcurrentOffload,
-    TransferBOZ, Coarray)
+    TransferBOZ, Coarray, PointerPassObject)
 
 // Portability and suspicious usage warnings
 ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 9a6b3ff3cdc2c..2d6e2099878f5 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -2608,9 +2608,6 @@ void CheckHelper::CheckPassArg(
   if (!passArg.has<ObjectEntityDetails>()) {
     msg = "Passed-object dummy argument '%s' of procedure '%s'"
           " must be a data object"_err_en_US;
-  } else if (passArg.attrs().test(Attr::POINTER)) {
-    msg = "Passed-object dummy argument '%s' of procedure '%s'"
-          " may not have the POINTER attribute"_err_en_US;
   } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
     msg = "Passed-object dummy argument '%s' of procedure '%s'"
           " may not have the ALLOCATABLE attribute"_err_en_US;
@@ -2620,6 +2617,18 @@ void CheckHelper::CheckPassArg(
   } else if (passArg.Rank() > 0) {
     msg = "Passed-object dummy argument '%s' of procedure '%s'"
           " must be scalar"_err_en_US;
+  } else if (passArg.attrs().test(Attr::POINTER)) {
+    if (context_.IsEnabled(common::LanguageFeature::PointerPassObject) &&
+        IsIntentIn(passArg)) {
+      // Extension: allow a passed object to be an INTENT(IN) POINTER
+      Warn(common::LanguageFeature::PointerPassObject, name,
+          "Passed-object dummy argument '%s' of procedure '%s'"
+          " that is an INTENT(IN) POINTER is not standard"_port_en_US,
+          *passName, name);
+    } else {
+      msg = "Passed-object dummy argument '%s' of procedure '%s'"
+            " may not have the POINTER attribute unless INTENT(IN)"_err_en_US;
+    }
   }
   if (msg) {
     messages_.Say(name, std::move(*msg), passName.value(), name);
diff --git a/flang/test/Semantics/bug172157.f90 b/flang/test/Semantics/bug172157.f90
new file mode 100644
index 0000000000000..760df5e8918e9
--- /dev/null
+++ b/flang/test/Semantics/bug172157.f90
@@ -0,0 +1,29 @@
+!RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  type t
+    procedure(sub), pass, pointer :: goodpp => sub ! ok
+    !ERROR: Passed-object dummy argument 'that' of procedure 'badpp' may not have the POINTER attribute unless INTENT(IN)
+    procedure(sub), pass(that), pointer :: badpp => sub ! ok
+   contains
+    procedure :: goodtbp => sub
+    !ERROR: Passed-object dummy argument 'that' of procedure 'badtbp' may not have the POINTER attribute unless INTENT(IN)
+    procedure, pass(that) :: badtbp => sub
+  end type
+ contains
+  subroutine sub(this, that)
+    class(t), pointer, intent(in) :: this
+    class(t), pointer :: that
+  end
+end
+
+program test
+  use m
+  type(t) xnt
+  type(t), target :: xt
+  !ERROR: In assignment to object dummy argument 'this=', the target 'xnt' is not an object with POINTER or TARGET attributes
+  call xnt%goodpp(null())
+  !ERROR: In assignment to object dummy argument 'this=', the target 'xnt' is not an object with POINTER or TARGET attributes
+  call xnt%goodtbp(null())
+  call xt%goodpp(null()) ! ok
+  call xt%goodtbp(null()) ! ok
+end
diff --git a/flang/test/Semantics/resolve52.f90 b/flang/test/Semantics/resolve52.f90
index 9f89510652b2e..26d938fd093b2 100644
--- a/flang/test/Semantics/resolve52.f90
+++ b/flang/test/Semantics/resolve52.f90
@@ -59,7 +59,7 @@ subroutine test
 
 module m4
   type :: t
-    !ERROR: Passed-object dummy argument 'x' of procedure 'a' may not have the POINTER attribute
+    !ERROR: Passed-object dummy argument 'x' of procedure 'a' may not have the POINTER attribute unless INTENT(IN)
     procedure(s1), pointer :: a
     !ERROR: Passed-object dummy argument 'x' of procedure 'b' may not have the ALLOCATABLE attribute
     procedure(s2), pointer, pass(x) :: b