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

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
 

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,

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);

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

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