From 04958737a77fb8ae81a4bac142a9d6523ced4bdd Mon Sep 17 00:00:00 2001 From: Peter Klausler 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/Semantics/bug172157-1.f90 | 27 +++++++++++++++ flang/test/Semantics/bug172157-2.f90 | 33 +++++++++++++++++++ flang/test/Semantics/resolve52.f90 | 2 +- 10 files changed, 102 insertions(+), 11 deletions(-) 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 { llvm_unreachable("getting host associated type in CallerInterface"); } + std::optional 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 actualInputs; + std::optional 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 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 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 passArg = caller.getPassArgIndex(); + int argIndex = -1; for (auto [preparedActual, arg] : llvm::zip(loweredActuals, caller.getPassedArguments())) { + ++argIndex; + bool thisIsPassArg = passArg && argIndex == static_cast(*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()) { 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()) { + // 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/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