diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index d657075d53efb..4c8e0cb128744 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -3273,7 +3273,9 @@ class FirConverter : public Fortran::lower::AbstractConverter { if (Fortran::evaluate::IsProcedurePointer(assign.lhs)) { hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR( loc, *this, assign.lhs, localSymbols, stmtCtx); - if (Fortran::evaluate::IsNullProcedurePointer(assign.rhs)) { + if (Fortran::evaluate::UnwrapExpr( + assign.rhs)) { + // rhs is null(). rhs being null(pptr) is handled in genNull. auto boxTy{Fortran::lower::getUntypedBoxProcType(&getMLIRContext())}; hlfir::Entity rhs( fir::factory::createNullBoxProc(*builder, loc, boxTy)); diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp index fa5406325ca96..b007c958cb6b3 100644 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -788,9 +788,13 @@ class Fortran::lower::CallInterfaceImpl { void handleImplicitResult( const Fortran::evaluate::characteristics::FunctionResult &result, bool isBindC) { - if (result.IsProcedurePointer()) - TODO(interface.converter.getCurrentLocation(), - "procedure pointer result not yet handled"); + if (auto proc{result.IsProcedurePointer()}) { + mlir::Type mlirType = fir::BoxProcType::get( + &mlirContext, getProcedureType(*proc, interface.converter)); + addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, + Property::Value); + return; + } const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape = result.GetTypeAndShape(); assert(typeAndShape && "expect type for non proc pointer result"); diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 552f5e93bd380..438ee4071b385 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -5173,6 +5173,15 @@ IntrinsicLibrary::genNull(mlir::Type, llvm::ArrayRef args) { // (see table 16.5 of Fortran 2018 standard). assert(args.size() == 1 && isStaticallyPresent(args[0]) && "MOLD argument required to lower NULL outside of any context"); + mlir::Type ptrTy = fir::getBase(args[0]).getType(); + if (ptrTy && fir::isBoxProcAddressType(ptrTy)) { + auto boxProcType = mlir::cast(fir::unwrapRefType(ptrTy)); + mlir::Value boxStorage = builder.createTemporary(loc, boxProcType); + mlir::Value nullBoxProc = + fir::factory::createNullBoxProc(builder, loc, boxProcType); + builder.createStoreWithConvert(loc, nullBoxProc, boxStorage); + return boxStorage; + } const auto *mold = args[0].getBoxOf(); assert(mold && "MOLD must be a pointer or allocatable"); fir::BaseBoxType boxType = mold->getBoxTy(); diff --git a/flang/test/Lower/HLFIR/procedure-pointer.f90 b/flang/test/Lower/HLFIR/procedure-pointer.f90 index 013c87a975a24..ba423db150841 100644 --- a/flang/test/Lower/HLFIR/procedure-pointer.f90 +++ b/flang/test/Lower/HLFIR/procedure-pointer.f90 @@ -307,6 +307,39 @@ function reffunc(arg) result(pp) ! CHECK: return end +subroutine sub12() +use m + procedure(char_func), pointer :: p1, p2 +! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref) -> !fir.box>>> +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.boxproc<(!fir.ref) -> !fir.box>>> +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.boxproc<(!fir.ref) -> !fir.box>>> {bindc_name = "p1", uniq_name = "_QFsub12Ep1"} +! CHECK: %[[VAL_3:.*]] = fir.zero_bits (!fir.ref) -> !fir.box>> +! CHECK: %[[VAL_4:.*]] = fir.emboxproc %[[VAL_3]] : ((!fir.ref) -> !fir.box>>) -> !fir.boxproc<(!fir.ref) -> !fir.box>>> +! CHECK: fir.store %[[VAL_4]] to %[[VAL_2]] : !fir.ref) -> !fir.box>>>> +! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_2]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFsub12Ep1"} : (!fir.ref) -> !fir.box>>>>) -> (!fir.ref) -> !fir.box>>>>, !fir.ref) -> !fir.box>>>>) +! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.boxproc<(!fir.ref) -> !fir.box>>> {bindc_name = "p2", uniq_name = "_QFsub12Ep2"} +! CHECK: %[[VAL_7:.*]] = fir.zero_bits (!fir.ref) -> !fir.box>> +! CHECK: %[[VAL_8:.*]] = fir.emboxproc %[[VAL_7]] : ((!fir.ref) -> !fir.box>>) -> !fir.boxproc<(!fir.ref) -> !fir.box>>> +! CHECK: fir.store %[[VAL_8]] to %[[VAL_6]] : !fir.ref) -> !fir.box>>>> +! CHECK: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_6]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFsub12Ep2"} : (!fir.ref) -> !fir.box>>>>) -> (!fir.ref) -> !fir.box>>>>, !fir.ref) -> !fir.box>>>>) + + p1 => NULL(p2) +! CHECK: %[[VAL_10:.*]] = fir.zero_bits (!fir.ref) -> !fir.box>> +! CHECK: %[[VAL_11:.*]] = fir.emboxproc %[[VAL_10]] : ((!fir.ref) -> !fir.box>>) -> !fir.boxproc<(!fir.ref) -> !fir.box>>> +! CHECK: fir.store %[[VAL_11]] to %[[VAL_1]] : !fir.ref) -> !fir.box>>>> +! CHECK: %[[VAL_12:.*]]:2 = hlfir.declare %[[VAL_1]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.ref) -> !fir.box>>>>) -> (!fir.ref) -> !fir.box>>>>, !fir.ref) -> !fir.box>>>>) +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_12]]#0 : !fir.ref) -> !fir.box>>>> +! CHECK: fir.store %[[VAL_13]] to %[[VAL_5]]#0 : !fir.ref) -> !fir.box>>>> + + call foo2(NULL(p2)) +! CHECK: %[[VAL_14:.*]] = fir.zero_bits (!fir.ref) -> !fir.box>> +! CHECK: %[[VAL_15:.*]] = fir.emboxproc %[[VAL_14]] : ((!fir.ref) -> !fir.box>>) -> !fir.boxproc<(!fir.ref) -> !fir.box>>> +! CHECK: fir.store %[[VAL_15]] to %[[VAL_0]] : !fir.ref) -> !fir.box>>>> +! CHECK: %[[VAL_16:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.ref) -> !fir.box>>>>) -> (!fir.ref) -> !fir.box>>>>, !fir.ref) -> !fir.box>>>>) +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]]#0 : (!fir.ref) -> !fir.box>>>>) -> !fir.ref ()>> +! CHECK: fir.call @_QPfoo2(%[[VAL_17]]) fastmath : (!fir.ref ()>>) -> () +end + ! CHECK-LABEL: fir.global internal @_QFsub1Ep2 : !fir.boxproc<(!fir.ref) -> f32> { ! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref) -> f32 ! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref) -> f32) -> !fir.boxproc<(!fir.ref) -> f32>