[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/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp

@@ -473,7 +473,7 @@ class DesignateOpConversion
     if (designate.getComponent()) {
       mlir::Type baseRecordType = baseEntity.getFortranElementType();
       if (fir::isRecordWithTypeParameters(baseRecordType))
-        TODO(loc, "hlfir.designate with a parametrized derived type base");
+        TODO(loc, "hlfir.designate with a parameterized derived type base");
       fieldIndex = fir::FieldIndexOp::create(
           builder, loc, fir::FieldType::get(builder.getContext()),
           designate.getComponent().value(), baseRecordType,
@@ -499,7 +499,7 @@ class DesignateOpConversion
             return mlir::success();
           }
           TODO(loc,
-               "addressing parametrized derived type automatic components");
+               "addressing parameterized derived type automatic components");
         }
         baseEleTy = hlfir::getFortranElementType(componentType);
         shape = designate.getComponentShape();

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,23 @@ 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)) {
+      if (proc.has<ProcBindingDetails>()) {
+        // Extension: allow a passed object to be an INTENT(IN) POINTER.
+        // Only works for TBPs, needs lowering work for proc ptr components.
+        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' used as procedure pointer component interface may not have the POINTER attribute"_err_en_US;
+      }
+    } 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-1.f90

@@ -0,0 +1,27 @@
+!RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  type t
+    !ERROR: Passed-object dummy argument 'this' of procedure 'pp1' used as procedure pointer component interface may not have the POINTER attribute
+    procedure(sub), pass, pointer :: pp1 => sub
+    !ERROR: Passed-object dummy argument 'that' of procedure 'pp2' may not have the POINTER attribute unless INTENT(IN)
+    procedure(sub), pass(that), pointer :: pp2 => sub
+   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%goodtbp(null())
+  call xt%goodtbp(null()) ! ok
+end

flang/test/Semantics/bug172157-2.f90

@@ -0,0 +1,33 @@
+!RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+module m
+  type t
+    integer :: n = 0
+   contains
+    procedure :: tbp => f
+  end type
+ contains
+  function f(this)
+    class(t), pointer, intent(in) :: this
+    integer, pointer :: f
+    f => this%n
+  end
+end
+
+program test
+  use m
+  type(t), target :: xt
+  type(t), pointer :: xp
+  xt%n = 1
+!CHECK: PRINT *, f(xt)
+  print *, xt%tbp()
+!CHECK: f(xt)=2_4
+  xt%tbp() = 2
+  print *, xt%n
+  xp => xt
+!CHECK: PRINT *, f(xp)
+  print *, xp%tbp()
+!CHECK: f(xp)=3_4
+  xp%tbp() = 3
+  print *, xp%n
+  print *, xt%n
+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