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

klausler · web-flow · commit bc99ce04262d · 2025-12-19T14:31:49.000-08:00
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.
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
@@ -474,6 +474,10 @@ 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 for a procedure binding is allowed
+  to be a pointer so long as it is `INTENT(IN)`.
+  (This extension is not yet supported for procedure pointer component
+  interfaces.)
 
 ### Extensions supported when enabled by options
 
diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h
@@ -401,11 +401,17 @@ class CallerInterface : public CallInterface<CallerInterface> {
     llvm_unreachable("getting host associated type in CallerInterface");
   }
 
+  std::optional<mlir::Value> getOriginalPassArg() const {
+    return originalPassArg;
+  }
+  void setOriginalPassArg(mlir::Value x) { originalPassArg = x; }
+
 private:
   /// Check that the input vector is complete.
   bool verifyActualInputs() const;
   const Fortran::evaluate::ProcedureRef &procRef;
   llvm::SmallVector<mlir::Value> actualInputs;
+  std::optional<mlir::Value> originalPassArg;
 };
 
 //===----------------------------------------------------------------------===//
diff --git 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/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
@@ -103,7 +103,7 @@ bool Fortran::lower::CallerInterface::requireDispatchCall() const {
       return true;
   }
   // calls with PASS attribute have the passed-object already set in its
-  // arguments. Just check if their is one.
+  // arguments. Just check if there is one.
   std::optional<unsigned> passArg = getPassArgIndex();
   if (passArg)
     return true;
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
@@ -673,10 +673,13 @@ Fortran::lower::genCallOpAndResult(
       // passed object because interface mismatch issues may have inserted a
       // cast to the operand with a different declared type, which would break
       // later type bound call resolution in the FIR to FIR pass.
+      mlir::Value passActual = caller.getInputs()[*passArg];
+      if (std::optional<mlir::Value> original = caller.getOriginalPassArg())
+        passActual = *original;
       dispatch = fir::DispatchOp::create(
           builder, loc, funcType.getResults(), builder.getStringAttr(procName),
-          caller.getInputs()[*passArg], operands,
-          builder.getI32IntegerAttr(*passArg), /*arg_attrs=*/nullptr,
+          passActual, operands, builder.getI32IntegerAttr(*passArg),
+          /*arg_attrs=*/nullptr,
           /*res_attrs=*/nullptr, procAttrs);
     } else {
       // NOPASS
@@ -1636,8 +1639,12 @@ void prepareUserCallArguments(
   mlir::Location loc = callContext.loc;
   bool mustRemapActualToDummyDescriptors = false;
   fir::FirOpBuilder &builder = callContext.getBuilder();
+  std::optional<unsigned> passArg = caller.getPassArgIndex();
+  int argIndex = -1;
   for (auto [preparedActual, arg] :
        llvm::zip(loweredActuals, caller.getPassedArguments())) {
+    ++argIndex;
+    bool thisIsPassArg = passArg && argIndex == static_cast<int>(*passArg);
     mlir::Type argTy = callSiteType.getInput(arg.firArgument);
     if (!preparedActual) {
       // Optional dummy argument for which there is no actual argument.
@@ -1750,14 +1757,16 @@ void prepareUserCallArguments(
         continue;
       }
       if (fir::isPointerType(argTy) &&
-          !Fortran::evaluate::IsObjectPointer(*expr)) {
+          (!Fortran::evaluate::IsObjectPointer(*expr) || thisIsPassArg)) {
         // Passing a non POINTER actual argument to a POINTER dummy argument.
         // Create a pointer of the dummy argument type and assign the actual
         // argument to it.
         auto dataTy = llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(argTy));
         fir::ExtendedValue actualExv = Fortran::lower::convertToAddress(
             loc, callContext.converter, actual, callContext.stmtCtx,
             hlfir::getFortranElementType(dataTy));
+        if (thisIsPassArg)
+          caller.setOriginalPassArg(fir::getBase(actualExv));
         // If the dummy is an assumed-rank pointer, allocate a pointer
         // descriptor with the actual argument rank (if it is not assumed-rank
         // itself).
diff --git a/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp b/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();
diff --git 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,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);
diff --git a/flang/test/Lower/bug172157-3.f90 b/flang/test/Lower/bug172157-3.f90
@@ -0,0 +1,62 @@
+!RUN: bbc -emit-fir %s -o - 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
+
+subroutine test
+  use m
+  type(t), target :: xt
+  class(t), pointer :: xp
+  xp => xt
+  xt%tbp() = 1
+  xp%tbp() = 2
+end
+
+! CHECK-LABEL: func @_QPtest(
+! CHECK:  %[[C2_I32:.*]] = arith.constant 2 : i32
+! CHECK:  %[[C1_I32:.*]] = arith.constant 1 : i32
+! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.box<!fir.ptr<i32>> {bindc_name = ".result"}
+! CHECK:  %[[VAL_1:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>
+! CHECK:  %[[VAL_2:.*]] = fir.alloca !fir.box<!fir.ptr<i32>> {bindc_name = ".result"}
+! CHECK:  %[[VAL_3:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>
+! CHECK:  %{{.*}} = fir.dummy_scope : !fir.dscope
+! CHECK:  %[[VAL_5:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>> {bindc_name = "xp", uniq_name = "_QFtestExp"}
+! CHECK:  %[[VAL_6:.*]] = fir.zero_bits !fir.ptr<!fir.type<_QMmTt{n:i32}>>
+! CHECK:  %[[VAL_7:.*]] = fir.embox %[[VAL_6]] : (!fir.ptr<!fir.type<_QMmTt{n:i32}>>) -> !fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>
+! CHECK:  fir.store %[[VAL_7]] to %[[VAL_5]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>
+! CHECK:  %[[VAL_8:.*]] = fir.declare %[[VAL_5]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtestExp"} : (!fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>) -> !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>
+! CHECK:  %[[VAL_9:.*]] = fir.alloca !fir.type<_QMmTt{n:i32}> {bindc_name = "xt", fir.target, uniq_name = "_QFtestExt"}
+! CHECK:  %[[VAL_10:.*]] = fir.declare %[[VAL_9]] {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFtestExt"} : (!fir.ref<!fir.type<_QMmTt{n:i32}>>) -> !fir.ref<!fir.type<_QMmTt{n:i32}>>
+! CHECK:  %[[VAL_11:.*]] = fir.address_of(@_QQ_QMmTt.DerivedInit) : !fir.ref<!fir.type<_QMmTt{n:i32}>>
+! CHECK:  fir.copy %[[VAL_11]] to %[[VAL_10]] no_overlap : !fir.ref<!fir.type<_QMmTt{n:i32}>>, !fir.ref<!fir.type<_QMmTt{n:i32}>>
+! CHECK:  %[[VAL_12:.*]] = fir.embox %[[VAL_10]] : (!fir.ref<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>
+! CHECK:  %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (!fir.box<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>) -> !fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>
+! CHECK:  fir.store %[[VAL_13]] to %[[VAL_8]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>
+! CHECK:  %[[VAL_14:.*]] = fir.embox %[[VAL_10]] : (!fir.ref<!fir.type<_QMmTt{n:i32}>>) -> !fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>
+! CHECK:  fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>
+! CHECK:  %[[VAL_15:.*]] = fir.call @_QMmPf(%[[VAL_3]]) fastmath<contract> : (!fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>) -> !fir.box<!fir.ptr<i32>>
+! CHECK:  fir.save_result %[[VAL_15]] to %[[VAL_2]] : !fir.box<!fir.ptr<i32>>, !fir.ref<!fir.box<!fir.ptr<i32>>>
+! CHECK:  %[[VAL_16:.*]] = fir.declare %[[VAL_2]] {uniq_name = ".tmp.func_result"} : (!fir.ref<!fir.box<!fir.ptr<i32>>>) -> !fir.ref<!fir.box<!fir.ptr<i32>>>
+! CHECK:  %[[VAL_17:.*]] = fir.load %[[VAL_16]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
+! CHECK:  %[[VAL_18:.*]] = fir.box_addr %[[VAL_17]] : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
+! CHECK:  fir.store %[[C1_I32]] to %[[VAL_18]] : !fir.ptr<i32>
+! CHECK:  %[[VAL_19:.*]] = fir.load %[[VAL_8]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>
+! CHECK:  %[[VAL_20:.*]] = fir.rebox %[[VAL_19]] : (!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>) -> !fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>
+! CHECK:  fir.store %[[VAL_20]] to %[[VAL_1]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>
+! CHECK:  %[[VAL_21:.*]] = fir.dispatch "tbp"(%[[VAL_19]] : !fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>) (%[[VAL_1]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMmTt{n:i32}>>>>) -> !fir.box<!fir.ptr<i32>> {pass_arg_pos = 0 : i32}
+! CHECK:  fir.save_result %[[VAL_21]] to %[[VAL_0]] : !fir.box<!fir.ptr<i32>>, !fir.ref<!fir.box<!fir.ptr<i32>>>
+! CHECK:  %[[VAL_22:.*]] = fir.declare %[[VAL_0]] {uniq_name = ".tmp.func_result"} : (!fir.ref<!fir.box<!fir.ptr<i32>>>) -> !fir.ref<!fir.box<!fir.ptr<i32>>>
+! CHECK:  %[[VAL_23:.*]] = fir.load %[[VAL_22]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
+! CHECK:  %[[VAL_24:.*]] = fir.box_addr %[[VAL_23]] : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
+! CHECK:  fir.store %[[C2_I32]] to %[[VAL_24]] : !fir.ptr<i32>
diff --git a/flang/test/Semantics/bug172157-1.f90 b/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
diff --git a/flang/test/Semantics/bug172157-2.f90 b/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
diff --git 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

Original file line number	Diff line number	Diff line change
`@@ -103,7 +103,7 @@ bool Fortran::lower::CallerInterface::requireDispatchCall() const {`
`103`	`103`	`return true;`
`104`	`104`	`}`
`105`	`105`	`// calls with PASS attribute have the passed-object already set in its`
`106`		`- // arguments. Just check if their is one.`
	`106`	`+ // arguments. Just check if there is one.`
`107`	`107`	`std::optional<unsigned> passArg = getPassArgIndex();`
`108`	`108`	`if (passArg)`
`109`	`109`	`return true;`