[flang-commits] [flang] [flang] Extension: Allow POINTER, INTENT(IN) passed objects (PR #172175)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Dec 17 08:21:10 PST 2025
https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/172175
>From 476a9084709553e2500911f3d28e94c126732a84 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Sat, 13 Dec 2025 12:28:41 -0800
Subject: [PATCH] [flang] Extension: Allow POINTER,INTENT(IN) passed objects
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 https://github.com/llvm/llvm-project/issues/172157.
---
flang/docs/Extensions.md | 2 +
flang/include/flang/Lower/CallInterface.h | 6 ++
.../include/flang/Support/Fortran-features.h | 2 +-
flang/lib/Lower/CallInterface.cpp | 2 +-
flang/lib/Lower/ConvertCall.cpp | 15 ++++-
.../HLFIR/Transforms/ConvertToFIR.cpp | 4 +-
flang/lib/Semantics/check-declarations.cpp | 20 +++++-
flang/test/Lower/bug172157-3.f90 | 62 +++++++++++++++++++
flang/test/Semantics/bug172157-1.f90 | 27 ++++++++
flang/test/Semantics/bug172157-2.f90 | 33 ++++++++++
flang/test/Semantics/resolve52.f90 | 2 +-
11 files changed, 164 insertions(+), 11 deletions(-)
create mode 100644 flang/test/Lower/bug172157-3.f90
create mode 100644 flang/test/Semantics/bug172157-1.f90
create mode 100644 flang/test/Semantics/bug172157-2.f90
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/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h
index 926a42756c6ef..9ccfb684510a1 100644
--- 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
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/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index c3284cd936f8f..f5ae2de5cad8b 100644
--- 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
index cd5218e760ea3..2cbb6f20d34d7 100644
--- 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,7 +1757,7 @@ 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.
@@ -1758,6 +1765,8 @@ void prepareUserCallArguments(
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
index 8bdf13e08165c..a63695f38afc6 100644
--- 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
index 9a6b3ff3cdc2c..684c1dcc98fa3 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,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
new file mode 100644
index 0000000000000..0d13715df69fc
--- /dev/null
+++ 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
new file mode 100644
index 0000000000000..9a58bfd1040af
--- /dev/null
+++ 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
new file mode 100644
index 0000000000000..507c7bb00c09d
--- /dev/null
+++ 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
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
More information about the flang-commits
mailing list