diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 593cd99147515..467b58af3afbd 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -459,6 +459,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 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/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> {bindc_name = ".result"} +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.class>> +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box> {bindc_name = ".result"} +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.class>> +! CHECK: %{{.*}} = fir.dummy_scope : !fir.dscope +! CHECK: %[[VAL_5:.*]] = fir.alloca !fir.class>> {bindc_name = "xp", uniq_name = "_QFtestExp"} +! CHECK: %[[VAL_6:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_6]] : (!fir.ptr>) -> !fir.class>> +! CHECK: fir.store %[[VAL_7]] to %[[VAL_5]] : !fir.ref>>> +! CHECK: %[[VAL_8:.*]] = fir.declare %[[VAL_5]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtestExp"} : (!fir.ref>>>) -> !fir.ref>>> +! 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, uniq_name = "_QFtestExt"} : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_11:.*]] = fir.address_of(@_QQ_QMmTt.DerivedInit) : !fir.ref> +! CHECK: fir.copy %[[VAL_11]] to %[[VAL_10]] no_overlap : !fir.ref>, !fir.ref> +! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_10]] : (!fir.ref>) -> !fir.box>> +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (!fir.box>>) -> !fir.class>> +! CHECK: fir.store %[[VAL_13]] to %[[VAL_8]] : !fir.ref>>> +! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_10]] : (!fir.ref>) -> !fir.class>> +! CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_15:.*]] = fir.call @_QMmPf(%[[VAL_3]]) fastmath : (!fir.ref>>>) -> !fir.box> +! CHECK: fir.save_result %[[VAL_15]] to %[[VAL_2]] : !fir.box>, !fir.ref>> +! CHECK: %[[VAL_16:.*]] = fir.declare %[[VAL_2]] {uniq_name = ".tmp.func_result"} : (!fir.ref>>) -> !fir.ref>> +! CHECK: %[[VAL_17:.*]] = fir.load %[[VAL_16]] : !fir.ref>> +! CHECK: %[[VAL_18:.*]] = fir.box_addr %[[VAL_17]] : (!fir.box>) -> !fir.ptr +! CHECK: fir.store %[[C1_I32]] to %[[VAL_18]] : !fir.ptr +! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_8]] : !fir.ref>>> +! CHECK: %[[VAL_20:.*]] = fir.rebox %[[VAL_19]] : (!fir.class>>) -> !fir.class>> +! CHECK: fir.store %[[VAL_20]] to %[[VAL_1]] : !fir.ref>>> +! CHECK: %[[VAL_21:.*]] = fir.dispatch "tbp"(%[[VAL_19]] : !fir.class>>) (%[[VAL_1]] : !fir.ref>>>) -> !fir.box> {pass_arg_pos = 0 : i32} +! CHECK: fir.save_result %[[VAL_21]] to %[[VAL_0]] : !fir.box>, !fir.ref>> +! CHECK: %[[VAL_22:.*]] = fir.declare %[[VAL_0]] {uniq_name = ".tmp.func_result"} : (!fir.ref>>) -> !fir.ref>> +! CHECK: %[[VAL_23:.*]] = fir.load %[[VAL_22]] : !fir.ref>> +! CHECK: %[[VAL_24:.*]] = fir.box_addr %[[VAL_23]] : (!fir.box>) -> !fir.ptr +! CHECK: fir.store %[[C2_I32]] to %[[VAL_24]] : !fir.ptr 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