diff --git a/flang/docs/F202X.md b/flang/docs/F202X.md index 67ea7fd97449a..7504561a64aa6 100644 --- a/flang/docs/F202X.md +++ b/flang/docs/F202X.md @@ -268,7 +268,6 @@ Addressing some issues and omissions in intrinsic modules: * LOGICAL8/16/32/64 and REAL16 * IEEE module facilities upgraded to match latest IEEE FP standard * C_F_STRPOINTER, F_C_STRING for NUL-terminated strings - * C_F_POINTER(LOWER=) #### Intrinsic Procedure Extensions diff --git a/flang/docs/ReleaseNotes.md b/flang/docs/ReleaseNotes.md index f0c956281915f..99dc41c907c36 100644 --- a/flang/docs/ReleaseNotes.md +++ b/flang/docs/ReleaseNotes.md @@ -24,6 +24,8 @@ page](https://llvm.org/releases/). ## Major New Features +* Support for LOWER= argument for C_F_POINTER. + ## Bug Fixes ## Non-comprehensive list of changes in this release diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index 768e4bafa90ee..c37a7f908d4d1 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -3077,10 +3077,11 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer( ActualArguments &arguments, FoldingContext &context) const { characteristics::Procedure::Attrs attrs; attrs.set(characteristics::Procedure::Attr::Subroutine); - static const char *const keywords[]{"cptr", "fptr", "shape", nullptr}; + static const char *const keywords[]{ + "cptr", "fptr", "shape", "lower", nullptr}; characteristics::DummyArguments dummies; - if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) { - CHECK(arguments.size() == 3); + if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 2)) { + CHECK(arguments.size() == 4); if (const auto *expr{arguments[0].value().UnwrapExpr()}) { // General semantic checks will catch an actual argument that's not // scalar. @@ -3173,11 +3174,30 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer( } } } + if (arguments[3] && fptrRank == 0) { + context.messages().Say(arguments[3]->sourceLocation(), + "LOWER= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US); + } else if (arguments[3]) { + if (const auto *argExpr{arguments[3].value().UnwrapExpr()}) { + if (argExpr->Rank() > 1) { + context.messages().Say(arguments[3]->sourceLocation(), + "LOWER= argument to C_F_POINTER() must be a rank-one array."_err_en_US); + } else if (argExpr->Rank() == 1) { + if (auto constShape{GetConstantShape(context, *argExpr)}) { + if (constShape->At(ConstantSubscripts{1}).ToInt64() != fptrRank) { + context.messages().Say(arguments[3]->sourceLocation(), + "LOWER= argument to C_F_POINTER() must have size equal to the rank of FPTR="_err_en_US); + } + } + } + } + } } } if (dummies.size() == 2) { + // Handle SHAPE DynamicType shapeType{TypeCategory::Integer, defaults_.sizeIntegerKind()}; - if (arguments[2]) { + if (arguments.size() >= 3 && arguments[2]) { if (auto type{arguments[2]->GetType()}) { if (type->category() == TypeCategory::Integer) { shapeType = *type; @@ -3189,6 +3209,22 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer( shape.intent = common::Intent::In; shape.attrs.set(characteristics::DummyDataObject::Attr::Optional); dummies.emplace_back("shape"s, std::move(shape)); + + // Handle LOWER + DynamicType lowerType{TypeCategory::Integer, defaults_.sizeIntegerKind()}; + if (arguments.size() >= 4 && arguments[3]) { + if (auto type{arguments[3]->GetType()}) { + if (type->category() == TypeCategory::Integer) { + lowerType = *type; + } + } + } + characteristics::DummyDataObject lower{ + characteristics::TypeAndShape{lowerType, 1}}; + lower.intent = common::Intent::In; + lower.attrs.set(characteristics::DummyDataObject::Attr::Optional); + dummies.emplace_back("lower"s, std::move(lower)); + return SpecificCall{ SpecificIntrinsic{"__builtin_c_f_pointer"s, characteristics::Procedure{std::move(dummies), attrs}}, diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 4753d0add6787..e62ed4811a37e 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -371,7 +371,8 @@ static constexpr IntrinsicHandler handlers[]{ &I::genCFPointer, {{{"cptr", asValue}, {"fptr", asInquired}, - {"shape", asAddr, handleDynamicOptional}}}, + {"shape", asAddr, handleDynamicOptional}, + {"lower", asAddr, handleDynamicOptional}}}, /*isElemental=*/false}, {"c_f_procpointer", &I::genCFProcPointer, @@ -3438,7 +3439,7 @@ IntrinsicLibrary::genCDevLoc(mlir::Type resultType, // C_F_POINTER void IntrinsicLibrary::genCFPointer(llvm::ArrayRef args) { - assert(args.size() == 3); + assert(args.size() == 4); // Handle CPTR argument // Get the value of the C address or the result of a reference to C_LOC. mlir::Value cPtr = fir::getBase(args[0]); @@ -3453,9 +3454,12 @@ void IntrinsicLibrary::genCFPointer(llvm::ArrayRef args) { mlir::Value addr = builder.createConvert(loc, fPtr->getMemTy(), cPtrAddrVal); mlir::SmallVector extents; + mlir::SmallVector lbounds; if (box.hasRank()) { assert(isStaticallyPresent(args[2]) && "FPTR argument must be an array if SHAPE argument exists"); + + // Handle and unpack SHAPE argument mlir::Value shape = fir::getBase(args[2]); int arrayRank = box.rank(); mlir::Type shapeElementType = @@ -3468,17 +3472,31 @@ void IntrinsicLibrary::genCFPointer(llvm::ArrayRef args) { mlir::Value load = fir::LoadOp::create(builder, loc, var); extents.push_back(builder.createConvert(loc, idxType, load)); } + + // Handle and unpack LOWER argument if present + if (isStaticallyPresent(args[3])) { + mlir::Value lower = fir::getBase(args[3]); + mlir::Type lowerElementType = + fir::unwrapSequenceType(fir::unwrapPassByRefType(lower.getType())); + for (int i = 0; i < arrayRank; ++i) { + mlir::Value index = builder.createIntegerConstant(loc, idxType, i); + mlir::Value var = builder.create( + loc, builder.getRefType(lowerElementType), lower, index); + mlir::Value load = builder.create(loc, var); + lbounds.push_back(builder.createConvert(loc, idxType, load)); + } + } } if (box.isCharacter()) { mlir::Value len = box.nonDeferredLenParams()[0]; if (box.hasRank()) - return fir::CharArrayBoxValue{addr, len, extents}; + return fir::CharArrayBoxValue{addr, len, extents, lbounds}; return fir::CharBoxValue{addr, len}; } if (box.isDerivedWithLenParameters()) TODO(loc, "get length parameters of derived type"); if (box.hasRank()) - return fir::ArrayBoxValue{addr, extents}; + return fir::ArrayBoxValue{addr, extents, lbounds}; return addr; }; diff --git a/flang/test/Lower/Intrinsics/c_f_pointer.f90 b/flang/test/Lower/Intrinsics/c_f_pointer.f90 index 67817e39d5c2b..c1f1d7972d4b1 100644 --- a/flang/test/Lower/Intrinsics/c_f_pointer.f90 +++ b/flang/test/Lower/Intrinsics/c_f_pointer.f90 @@ -140,3 +140,78 @@ subroutine dynamic_shape_size_2(cptr, fptr, shape, n) ! CHECK: %[[VAL_16:.*]] = fir.shape %[[VAL_11]], %[[VAL_15]] : (index, index) -> !fir.shape<2> call c_f_pointer(cptr, fptr, shape) end subroutine + +! CHECK-LABEL: func.func @_QPdynamic_shape_lower( +subroutine dynamic_shape_lower(cptr, fpr, shape, lower) + use iso_c_binding + type(c_ptr) :: cptr + real, pointer :: fptr(:, :) + integer :: n + integer :: shape(:) + integer :: lower(:) +! CHECK: %[[C_0:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_2:.*]] = fir.shape %[[C_0]], %[[C_0]] : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_3:.*]] = fir.embox %[[VAL_1:.*]](%[[VAL_2]]) : (!fir.ptr>, !fir.shape<2>) -> !fir.box>> +! CHECK: fir.store %[[VAL_3]] to %[[VAL_0:.*]] : !fir.ref>>> +! CHECK: %[[VAL_4:.*]] = fir.alloca i32 {bindc_name = "n", uniq_name = "_QFdynamic_shape_lowerEn"} +! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[ARG_0:.*]], __address : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> !fir.ptr> +! CHECK: %[[C_0:.*]]_0 = arith.constant 0 : index +! CHECK: %[[VAL_8:.*]] = fir.coordinate_of %[[ARG_2:.*]], %[[C_0]]_0 : (!fir.box>, index) -> !fir.ref +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_8]] : !fir.ref +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> index +! CHECK: %[[C_1:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_11:.*]] = fir.coordinate_of %[[ARG_2:.*]], %[[C_1]] : (!fir.box>, index) -> !fir.ref +! CHECK: %[[VAL_12:.*]] = fir.load %[[VAL_11]] : !fir.ref +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (i32) -> index +! CHECK: %[[C_0:.*]]_1 = arith.constant 0 : index +! CHECK: %[[VAL_14:.*]] = fir.coordinate_of %[[ARG_3:.*]], %[[C_0]]_1 : (!fir.box>, index) -> !fir.ref +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_14]] : !fir.ref +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i32) -> index +! CHECK: %[[C_1:.*]]_2 = arith.constant 1 : index +! CHECK: %[[VAL_17:.*]] = fir.coordinate_of %[[ARG_3:.*]], %[[C_1]]_2 : (!fir.box>, index) -> !fir.ref +! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_17]] : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> index +! CHECK: %[[VAL_20:.*]] = fir.shape_shift %[[VAL_16]], %[[VAL_10]], %[[VAL_19]], %[[VAL_13]] : (index, index, index, index) -> !fir.shapeshift<2> +! CHECK: %[[VAL_21:.*]] = fir.embox %[[VAL_7]](%[[VAL_20]]) : (!fir.ptr>, !fir.shapeshift<2>) -> !fir.box>> +! CHECK: fir.store %[[VAL_21:.*]] to %[[VAL_0]] : !fir.ref>>> + call c_f_pointer(cptr, fptr, shape, lower) +end subroutine dynamic_shape_lower + +! CHECK-LABEL: func.func @_QPdynamic_shape_lower_2( +subroutine dynamic_shape_lower_2(cptr, fpr, shape, lower, n) + use iso_c_binding + type(c_ptr) :: cptr + real, pointer :: fptr(:, :) + integer :: n + integer :: shape(n) + integer :: lower(n) +!CHECK: %[[C_0:.*]] = arith.constant 0 : index +!CHECK: %[[VAL_2:.*]] = fir.shape %[[C_0]], %[[C_0]] : (index, index) -> !fir.shape<2> +!CHECK: %[[VAL_3:.*]] = fir.embox %[[ARG1:.*]](%[[VAL_2]]) : (!fir.ptr>, !fir.shape<2>) -> !fir.box>> +!CHECK: fir.store %[[VAL_3]] to %[[VAL_0:.*]] : !fir.ref>>> +!CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[ARG_0:.*]], __address : (!fir.ref>) -> !fir.ref +!CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref +!CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> !fir.ptr> +!CHECK: %[[C_0:.*]]_0 = arith.constant 0 : index +!CHECK: %[[VAL_7:.*]] = fir.coordinate_of %[[ARG_2:.*]], %[[C_0]]_0 : (!fir.ref>, index) -> !fir.ref +!CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_7]] : !fir.ref +!CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i32) -> index +!CHECK: %[[C_1:.*]] = arith.constant 1 : index +!CHECK: %[[VAL_10:.*]] = fir.coordinate_of %[[ARG_2]], %[[C_1]] : (!fir.ref>, index) -> !fir.ref +!CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_10]] : !fir.ref +!CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i32) -> index +!CHECK: %[[C_0:.*]]_1 = arith.constant 0 : index +!CHECK: %[[VAL_13:.*]] = fir.coordinate_of %[[ARG_3:.*]], %[[C_0]]_1 : (!fir.ref>, index) -> !fir.ref +!CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_13]] : !fir.ref +!CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i32) -> index +!CHECK: %[[C_1:.*]]_2 = arith.constant 1 : index +!CHECK: %[[VAL_16:.*]] = fir.coordinate_of %[[ARG_3]], %[[C_1]]_2 : (!fir.ref>, index) -> !fir.ref +!CHECK: %[[VAL_17:.*]] = fir.load %[[VAL_16]] : !fir.ref +!CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_17]] : (i32) -> index +!CHECK: %[[VAL_19:.*]] = fir.shape_shift %[[VAL_15]], %[[VAL_9]], %[[VAL_18]], %[[VAL_12]] : (index, index, index, index) -> !fir.shapeshift<2> +!CHECK: %[[VAL_20:.*]] = fir.embox %[[VAL_6]](%[[VAL_19]]) : (!fir.ptr>, !fir.shapeshift<2>) +!CHECK: fir.store %[[VAL_20]] to %[[VAL_0]] : !fir.ref>>> + call c_f_pointer(cptr, fptr, shape, lower) +end subroutine dynamic_shape_lower_2 diff --git a/flang/test/Semantics/c_f_pointer.f90 b/flang/test/Semantics/c_f_pointer.f90 index e2d00536cdacb..8a22175ffe19e 100644 --- a/flang/test/Semantics/c_f_pointer.f90 +++ b/flang/test/Semantics/c_f_pointer.f90 @@ -54,4 +54,12 @@ program test call c_f_pointer(scalarC, c2ptr) !WARNING: FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type or kind CHARACTER(KIND=4,LEN=1_8) [-Winteroperability] call c_f_pointer(scalarC, unicodePtr) + + !ERROR: SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar + !ERROR: LOWER= argument to C_F_POINTER() may not appear when FPTR= is scalar + call c_f_pointer(scalarC, scalarIntF, [1_8], [0_8]) + !ERROR: LOWER= argument to C_F_POINTER() must be a rank-one array. + call c_f_pointer(scalarC, arrayIntF, shape=[1_8], lower=rankTwoArray) + !ERROR: SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array + call c_f_pointer(scalarC, arrayIntF, lower=[0]) end program