[flang-commits] [flang] [flang] Implement C_F_STRPOINTER (Fortran 2023) (PR #176973)
Caroline Newcombe via flang-commits
flang-commits at lists.llvm.org
Tue Jan 20 09:21:58 PST 2026
https://github.com/cenewcombe created https://github.com/llvm/llvm-project/pull/176973
Implement C_F_STRPOINTER to associate a Fortran character pointer with a C string.
This intrinsic has two forms:
C_F_STRPOINTER(CSTRARRAY, FSTRPTR [,NCHARS]): Associates FSTRPTR with a C string array
C_F_STRPOINTER(CSTRPTR, FSTRPTR, NCHARS): Associates FSTRPTR with a C_PTR pointing to a character string
Implementation includes semantic validation, FIR lowering, and associated tests.
F2023 Standard: 18.2.3.5
AI Usage Disclosure: AI tools (Claude Sonnet 4.5) were used to assist with implementation of this feature and test code generation. I have reviewed, modified, and tested all AI-generated code.
>From 8f9790c9801eb4dde9ffd3831ab98af8b3f9fed8 Mon Sep 17 00:00:00 2001
From: Caroline Newcombe <caroline.newcombe at hpe.com>
Date: Wed, 14 Jan 2026 12:18:01 -0600
Subject: [PATCH] [flang] Implement C_F_STRPOINTER (Fortran 2023)
---
.../flang/Optimizer/Builder/IntrinsicCall.h | 1 +
flang/lib/Evaluate/intrinsics.cpp | 184 +++++++++++++++++-
flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 99 ++++++++++
flang/module/__fortran_builtins.f90 | 3 +
flang/module/iso_c_binding.f90 | 5 +-
.../test/Lower/Intrinsics/c_f_strpointer.f90 | 59 ++++++
flang/test/Semantics/c_f_strpointer.f90 | 46 +++++
7 files changed, 394 insertions(+), 3 deletions(-)
create mode 100644 flang/test/Lower/Intrinsics/c_f_strpointer.f90
create mode 100644 flang/test/Semantics/c_f_strpointer.f90
diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
index b248106b51101..45b6f06c845bc 100644
--- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
+++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
@@ -223,6 +223,7 @@ struct IntrinsicLibrary {
llvm::ArrayRef<mlir::Value> args);
void genCFPointer(llvm::ArrayRef<fir::ExtendedValue>);
void genCFProcPointer(llvm::ArrayRef<fir::ExtendedValue>);
+ void genCFStrpointer(llvm::ArrayRef<fir::ExtendedValue>);
fir::ExtendedValue genCFunLoc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
fir::ExtendedValue genCLoc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
template <mlir::arith::CmpIPredicate pred>
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 72ac9e2f68758..c74f6f73c0469 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2893,6 +2893,8 @@ class IntrinsicProcTable::Implementation {
SpecificCall HandleNull(ActualArguments &, FoldingContext &) const;
std::optional<SpecificCall> HandleC_F_Pointer(
ActualArguments &, FoldingContext &) const;
+ std::optional<SpecificCall> HandleC_F_Strpointer(
+ ActualArguments &, FoldingContext &) const;
std::optional<SpecificCall> HandleC_Loc(
ActualArguments &, FoldingContext &) const;
std::optional<SpecificCall> HandleC_Devloc(
@@ -2935,7 +2937,7 @@ bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine(
return true;
}
// special cases
- return name == "__builtin_c_f_pointer";
+ return name == "__builtin_c_f_pointer" || name == "__builtin_c_f_strpointer";
}
bool IntrinsicProcTable::Implementation::IsIntrinsic(
const std::string &name) const {
@@ -3251,6 +3253,184 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
}
}
+// Subroutine C_F_STRPOINTER from intrinsic module ISO_C_BINDING (18.2.3.5)
+// C_F_STRPOINTER(CSTRARRAY, FSTRPTR [,NCHARS]) or
+// C_F_STRPOINTER(CSTRPTR, FSTRPTR, NCHARS)
+std::optional<SpecificCall>
+IntrinsicProcTable::Implementation::HandleC_F_Strpointer(
+ ActualArguments &arguments, FoldingContext &context) const {
+ characteristics::Procedure::Attrs attrs;
+ attrs.set(characteristics::Procedure::Attr::Subroutine);
+ // The first argument can be either CSTRARRAY or CSTRPTR - we use a generic
+ // keyword since they're mutually exclusive
+ static const char *const keywords[]{
+ "cstrarray", "fstrptr", "nchars", nullptr};
+ characteristics::DummyArguments dummies;
+ if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 2)) {
+ CHECK(arguments.size() == 3);
+ const bool hasNchars{arguments[2].has_value()};
+
+ // Check first argument (CSTRARRAY or CSTRPTR) and optional third argument
+ // (NCHARS)
+ if (const auto *expr{arguments[0].value().UnwrapExpr()}) {
+ // General semantic checks will catch an actual argument that's not
+ // scalar.
+ const auto at{arguments[0]->sourceLocation()};
+ if (const auto type{expr->GetType()}) {
+ if (type->category() == TypeCategory::Derived &&
+ !type->IsPolymorphic() &&
+ (type->GetDerivedTypeSpec().typeSymbol().name() ==
+ "__builtin_c_ptr" ||
+ type->GetDerivedTypeSpec().typeSymbol().name() ==
+ "__builtin_c_devptr")) {
+ // First argument is C_PTR (CSTRPTR form)
+ if (!hasNchars) {
+ context.messages().Say(at,
+ "NCHARS= argument is required when CSTRPTR= appears in C_F_STRPOINTER()"_err_en_US);
+ }
+ characteristics::DummyDataObject cstrptr{
+ characteristics::TypeAndShape{*type}};
+ cstrptr.intent = common::Intent::In;
+ dummies.emplace_back("cstrptr"s, std::move(cstrptr));
+ } else if (type->category() == TypeCategory::Character) {
+ // First argument should be CSTRARRAY - rank-1 character array
+ if (type->kind() != 1) {
+ context.messages().Say(at,
+ "CSTRARRAY= argument to C_F_STRPOINTER() must be of kind C_CHAR"_err_en_US);
+ }
+ if (expr->Rank() != 1) {
+ context.messages().Say(at,
+ "CSTRARRAY= argument to C_F_STRPOINTER() must be a rank-one array"_err_en_US);
+ }
+ if (const auto len{type->GetCharLength()}) {
+ if (const auto constLen{ToInt64(*len)}) {
+ if (*constLen != 1) {
+ context.messages().Say(at,
+ "CSTRARRAY= argument to C_F_STRPOINTER() must have length type parameter equal to one"_err_en_US);
+ }
+ }
+ }
+ // Check if CSTRARRAY is assumed-size and NCHARS is absent
+ if (auto shape{GetShape(context, *expr)}) {
+ if (shape->size() == 1) {
+ const auto &extentExpr{(*shape)[0]};
+ const auto extentInt{ToInt64(extentExpr)};
+ if ((!extentInt || *extentInt < 0) && !hasNchars) {
+ context.messages().Say(at,
+ "NCHARS= argument is required when CSTRARRAY= is assumed-size in C_F_STRPOINTER()"_err_en_US);
+ }
+ }
+ }
+ // Check if NCHARS > size(CSTRARRAY) at compile time
+ if (hasNchars && arguments[2]) {
+ if (const auto *ncharsExpr{arguments[2]->UnwrapExpr()}) {
+ if (const auto ncharsVal{ToInt64(*ncharsExpr)}) {
+ if (const auto shape{GetShape(context, *expr)};
+ shape && shape->size() == 1) {
+ if (const auto arraySize{ToInt64((*shape)[0])};
+ arraySize && *arraySize > 0 && *ncharsVal > *arraySize) {
+ context.messages().Say(arguments[2]->sourceLocation(),
+ "NCHARS=%jd is greater than the size of CSTRARRAY=%jd in C_F_STRPOINTER()"_err_en_US,
+ static_cast<std::intmax_t>(*ncharsVal),
+ static_cast<std::intmax_t>(*arraySize));
+ }
+ }
+ }
+ }
+ }
+ characteristics::DummyDataObject cstrarray{
+ characteristics::TypeAndShape{*type, 1}};
+ cstrarray.intent = common::Intent::In;
+ cstrarray.attrs.set(characteristics::DummyDataObject::Attr::Target);
+ dummies.emplace_back("cstrarray"s, std::move(cstrarray));
+ } else {
+ context.messages().Say(at,
+ "First argument to C_F_STRPOINTER() must be a C_PTR or a rank-one character array of kind C_CHAR"_err_en_US);
+ }
+ }
+ }
+
+ // Check FSTRPTR argument - must be scalar deferred-length character pointer
+ if (const auto *expr{arguments[1].value().UnwrapExpr()}) {
+ const auto at{arguments[1]->sourceLocation()};
+ if (const auto type{expr->GetType()}) {
+ if (type->category() != TypeCategory::Character) {
+ context.messages().Say(at,
+ "FSTRPTR= argument to C_F_STRPOINTER() must be a character pointer"_err_en_US);
+ } else {
+ if (type->kind() != 1) {
+ context.messages().Say(at,
+ "FSTRPTR= argument to C_F_STRPOINTER() must be of kind C_CHAR"_err_en_US);
+ }
+ if (!type->HasDeferredTypeParameter()) {
+ context.messages().Say(at,
+ "FSTRPTR= argument to C_F_STRPOINTER() must have deferred length"_err_en_US);
+ }
+ }
+ if (ExtractCoarrayRef(*expr)) {
+ context.messages().Say(at,
+ "FSTRPTR= argument to C_F_STRPOINTER() may not be a coindexed object"_err_en_US);
+ }
+ characteristics::DummyDataObject fstrptr{
+ characteristics::TypeAndShape{*type, 0}};
+ fstrptr.intent = common::Intent::Out;
+ fstrptr.attrs.set(characteristics::DummyDataObject::Attr::Pointer);
+ dummies.emplace_back("fstrptr"s, std::move(fstrptr));
+ } else {
+ context.messages().Say(at,
+ "FSTRPTR= argument to C_F_STRPOINTER() must have a type"_err_en_US);
+ }
+ }
+
+ // Check NCHARS argument if present
+ if (hasNchars) {
+ if (const auto *expr{arguments[2].value().UnwrapExpr()}) {
+ const auto at{arguments[2]->sourceLocation()};
+ if (const auto type{expr->GetType()}) {
+ if (type->category() != TypeCategory::Integer) {
+ context.messages().Say(at,
+ "NCHARS= argument to C_F_STRPOINTER() must be an integer"_err_en_US);
+ }
+ }
+ if (expr->Rank() != 0) {
+ context.messages().Say(at,
+ "NCHARS= argument to C_F_STRPOINTER() must be a scalar"_err_en_US);
+ }
+ // Check for negative value if constant
+ if (const auto ncharsVal{ToInt64(*expr)}) {
+ if (*ncharsVal < 0) {
+ context.messages().Say(at,
+ "NCHARS= argument to C_F_STRPOINTER() must be non-negative"_err_en_US);
+ }
+ }
+ }
+ }
+ }
+ if (dummies.size() == 2) {
+ // Add NCHARS dummy
+ DynamicType ncharsType{TypeCategory::Integer, defaults_.sizeIntegerKind()};
+ if (arguments.size() >= 3 && arguments[2]) {
+ if (const auto type{arguments[2]->GetType()}) {
+ if (type->category() == TypeCategory::Integer) {
+ ncharsType = *type;
+ }
+ }
+ }
+ characteristics::DummyDataObject nchars{
+ characteristics::TypeAndShape{ncharsType}};
+ nchars.intent = common::Intent::In;
+ nchars.attrs.set(characteristics::DummyDataObject::Attr::Optional);
+ dummies.emplace_back("nchars"s, std::move(nchars));
+
+ return SpecificCall{
+ SpecificIntrinsic{"__builtin_c_f_strpointer"s,
+ characteristics::Procedure{std::move(dummies), attrs}},
+ std::move(arguments)};
+ } else {
+ return std::nullopt;
+ }
+}
+
// Function C_LOC(X) from intrinsic module ISO_C_BINDING (18.2.3.6)
std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
ActualArguments &arguments, FoldingContext &context) const {
@@ -3533,6 +3713,8 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
if (call.isSubroutineCall) {
if (call.name == "__builtin_c_f_pointer") {
return HandleC_F_Pointer(arguments, context);
+ } else if (call.name == "__builtin_c_f_strpointer") {
+ return HandleC_F_Strpointer(arguments, context);
} else if (call.name == "random_seed") {
int optionalCount{0};
for (const auto &arg : arguments) {
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index c8a76fc97809c..95fc667329f84 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -192,6 +192,12 @@ static constexpr IntrinsicHandler handlers[]{
&I::genCFProcPointer,
{{{"cptr", asValue}, {"fptr", asInquired}}},
/*isElemental=*/false},
+ {"c_f_strpointer",
+ &I::genCFStrpointer,
+ {{{"cstrptr_or_cstrarray", asValue},
+ {"fstrptr", asInquired},
+ {"nchars", asValue, handleDynamicOptional}}},
+ /*isElemental=*/false},
{"c_funloc", &I::genCFunLoc, {{{"x", asBox}}}, /*isElemental=*/false},
{"c_loc", &I::genCLoc, {{{"x", asBox}}}, /*isElemental=*/false},
{"c_ptr_eq", &I::genCPtrCompare<mlir::arith::CmpIPredicate::eq>},
@@ -3245,6 +3251,99 @@ void IntrinsicLibrary::genCFProcPointer(
fir::StoreOp::create(builder, loc, cptrBox, fptr);
}
+// C_F_STRPOINTER
+void IntrinsicLibrary::genCFStrpointer(
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ assert(args.size() == 3);
+
+ mlir::Value cStrAddr;
+ mlir::Value strLen;
+
+ const mlir::Value firstArg = fir::getBase(args[0]);
+ const mlir::Type firstArgType = fir::unwrapRefType(firstArg.getType());
+ const bool isCstrptr = mlir::isa<fir::RecordType>(firstArgType);
+
+ if (isCstrptr) {
+ // CSTRPTR form: Extract address from C_PTR
+ cStrAddr = fir::factory::genCPtrOrCFunptrValue(builder, loc, firstArg);
+
+ assert(isStaticallyPresent(args[2]));
+ mlir::Value nchars = fir::getBase(args[2]);
+ if (fir::isa_ref_type(nchars.getType())) {
+ strLen = fir::LoadOp::create(builder, loc, nchars);
+ } else {
+ strLen = nchars;
+ }
+ } else {
+ // CSTRARRAY form: Get address from CHARACTER array
+ if (const auto boxCharTy =
+ mlir::dyn_cast<fir::BoxCharType>(firstArg.getType())) {
+ const auto charTy = mlir::cast<fir::CharacterType>(boxCharTy.getEleTy());
+ const auto addrTy = builder.getRefType(charTy);
+ auto unboxed = fir::UnboxCharOp::create(
+ builder, loc, mlir::TypeRange{addrTy, builder.getIndexType()},
+ firstArg);
+ cStrAddr = unboxed.getResult(0);
+ } else if (mlir::isa<fir::BoxType>(firstArg.getType())) {
+ cStrAddr = fir::BoxAddrOp::create(builder, loc, firstArg);
+ } else {
+ cStrAddr = firstArg;
+ }
+
+ // Handle optional NCHARS argument
+ if (isStaticallyPresent(args[2])) {
+ mlir::Value nchars = fir::getBase(args[2]);
+ if (fir::isa_ref_type(nchars.getType())) {
+ strLen = fir::LoadOp::create(builder, loc, nchars);
+ } else {
+ strLen = nchars;
+ }
+ } else {
+ const mlir::Type i8PtrTy = builder.getRefType(builder.getIntegerType(8));
+ const mlir::Value strPtr = builder.createConvert(loc, i8PtrTy, cStrAddr);
+
+ const mlir::Type i64Ty = builder.getIntegerType(64);
+ const mlir::FunctionType strlenType =
+ mlir::FunctionType::get(builder.getContext(), {i8PtrTy}, {i64Ty});
+
+ mlir::func::FuncOp strlenFunc = builder.getNamedFunction("strlen");
+ if (!strlenFunc) {
+ strlenFunc = builder.createFunction(loc, "strlen", strlenType);
+ strlenFunc->setAttr(
+ fir::getSymbolAttrName(),
+ mlir::StringAttr::get(builder.getContext(), "strlen"));
+ }
+ auto call = fir::CallOp::create(builder, loc, strlenFunc, {strPtr});
+ strLen = call.getResult(0);
+ }
+ }
+
+ // Handle FSTRPTR (second argument)
+ const auto *fStrPtr = args[1].getBoxOf<fir::MutableBoxValue>();
+ assert(fStrPtr && "FSTRPTR must be a pointer");
+
+ const mlir::Value lenIdx =
+ builder.createConvert(loc, builder.getIndexType(), strLen);
+
+ const mlir::Type charPtrType = fir::PointerType::get(fir::CharacterType::get(
+ builder.getContext(), 1, fir::CharacterType::unknownLen()));
+ const mlir::Value charPtr = builder.createConvert(loc, charPtrType, cStrAddr);
+
+ const fir::CharBoxValue charBox{charPtr, lenIdx};
+ fir::factory::associateMutableBox(builder, loc, *fStrPtr, charBox,
+ /*lbounds=*/mlir::ValueRange{});
+
+ // CUDA synchronization if needed
+ if (auto declare = mlir::dyn_cast_or_null<hlfir::DeclareOp>(
+ fStrPtr->getAddr().getDefiningOp()))
+ if (declare.getMemref().getDefiningOp() &&
+ mlir::isa<fir::AddrOfOp>(declare.getMemref().getDefiningOp()))
+ if (cuf::isRegisteredDeviceAttr(declare.getDataAttr()) &&
+ !cuf::isCUDADeviceContext(builder.getRegion()))
+ fir::runtime::cuda::genSyncGlobalDescriptor(builder, loc,
+ declare.getMemref());
+}
+
// C_FUNLOC
fir::ExtendedValue
IntrinsicLibrary::genCFunLoc(mlir::Type resultType,
diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90
index a9b60508785db..fbb7870f83f71 100644
--- a/flang/module/__fortran_builtins.f90
+++ b/flang/module/__fortran_builtins.f90
@@ -28,6 +28,9 @@
intrinsic :: __builtin_c_f_pointer
public :: __builtin_c_f_pointer
+ intrinsic :: __builtin_c_f_strpointer
+ public :: __builtin_c_f_strpointer
+
intrinsic :: __builtin_show_descriptor
public :: __builtin_show_descriptor
diff --git a/flang/module/iso_c_binding.f90 b/flang/module/iso_c_binding.f90
index 8e3f78cea51b7..a0d2bbcba8c71 100644
--- a/flang/module/iso_c_binding.f90
+++ b/flang/module/iso_c_binding.f90
@@ -15,6 +15,7 @@ module iso_c_binding
c_funloc => __builtin_c_funloc, &
c_funptr => __builtin_c_funptr, &
c_f_pointer => __builtin_c_f_pointer, &
+ c_f_strpointer => __builtin_c_f_strpointer, &
c_loc => __builtin_c_loc, &
c_null_funptr => __builtin_c_null_funptr, &
c_null_ptr => __builtin_c_null_ptr, &
@@ -28,8 +29,8 @@ module iso_c_binding
! to be exported by this MODULE.
private
- public :: c_associated, c_funloc, c_funptr, c_f_pointer, c_loc, &
- c_null_funptr, c_null_ptr, c_ptr, c_sizeof, &
+ public :: c_associated, c_funloc, c_funptr, c_f_pointer, c_f_strpointer, &
+ c_loc, c_null_funptr, c_null_ptr, c_ptr, c_sizeof, &
operator(==), operator(/=)
! Table 18.2 (in clause 18.3.1)
diff --git a/flang/test/Lower/Intrinsics/c_f_strpointer.f90 b/flang/test/Lower/Intrinsics/c_f_strpointer.f90
new file mode 100644
index 0000000000000..78d0c9a2e58a5
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/c_f_strpointer.f90
@@ -0,0 +1,59 @@
+! RUN: bbc -emit-fir -hlfir=false %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-fir -flang-deprecated-no-hlfir %s -o - | FileCheck %s
+
+! Test intrinsic module procedure c_f_strpointer
+
+! CHECK-LABEL: func.func @_QPtest_cstrarray(
+! CHECK-SAME: %[[CSTRARRAY:.*]]: !fir.boxchar<1> {fir.bindc_name = "cstrarray", fir.target},
+! CHECK-SAME: %[[FSTRPTR:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>> {fir.bindc_name = "fstrptr"}
+subroutine test_cstrarray(cstrarray, fstrptr)
+ use iso_c_binding
+ character(len=1, kind=c_char), dimension(*), target, intent(in) :: cstrarray
+ character(len=:), pointer, intent(out) :: fstrptr
+ ! CHECK: %[[UNBOXED:.*]]:2 = fir.unboxchar %[[CSTRARRAY]]
+ ! CHECK: %[[CONVERTED:.*]] = fir.convert %[[UNBOXED]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
+ ! CHECK: %[[NCHARS:.*]] = arith.constant 100 : i32
+ ! CHECK: %[[NCHARS_IDX:.*]] = fir.convert %[[NCHARS]] : (i32) -> index
+ ! CHECK: %[[PTR:.*]] = fir.convert %[[CONVERTED]] : (!fir.ref<!fir.array<?x!fir.char<1>>>) -> !fir.ptr<!fir.char<1,?>>
+ ! CHECK: %[[BOX:.*]] = fir.embox %[[PTR]] typeparams %[[NCHARS_IDX]] : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.store %[[BOX]] to %[[FSTRPTR]]
+ call c_f_strpointer(cstrarray, fstrptr, 100)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_cstrarray_no_nchars(
+! CHECK-SAME: %[[FSTRPTR:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>> {fir.bindc_name = "fstrptr"}
+subroutine test_cstrarray_no_nchars(fstrptr)
+ use iso_c_binding
+ character(len=1, kind=c_char), dimension(100), target :: cstrarray
+ character(len=:), pointer, intent(out) :: fstrptr
+ ! CHECK: %[[CSTRARRAY:.*]] = fir.alloca !fir.array<100x!fir.char<1>> {bindc_name = "cstrarray"
+ ! CHECK: %[[I8PTR:.*]] = fir.convert %[[CSTRARRAY]] : (!fir.ref<!fir.array<100x!fir.char<1>>>) -> !fir.ref<i8>
+ ! CHECK: %[[STRLEN:.*]] = fir.call @strlen(%[[I8PTR]]) {{.*}} : (!fir.ref<i8>) -> i64
+ ! CHECK: %[[STRLEN_IDX:.*]] = fir.convert %[[STRLEN]] : (i64) -> index
+ ! CHECK: %[[PTR:.*]] = fir.convert %[[CSTRARRAY]] : (!fir.ref<!fir.array<100x!fir.char<1>>>) -> !fir.ptr<!fir.char<1,?>>
+ ! CHECK: %[[BOX:.*]] = fir.embox %[[PTR]] typeparams %[[STRLEN_IDX]] : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.store %[[BOX]] to %[[FSTRPTR]]
+ cstrarray = 'Hello' // c_null_char
+ call c_f_strpointer(cstrarray, fstrptr)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_cstrptr(
+! CHECK-SAME: %[[CPTR:.*]]: !fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>> {fir.bindc_name = "cptr"},
+! CHECK-SAME: %[[FSTRPTR:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>> {fir.bindc_name = "fstrptr"},
+! CHECK-SAME: %[[NCHARS:.*]]: !fir.ref<i32> {fir.bindc_name = "nchars"}
+subroutine test_cstrptr(cptr, fstrptr, nchars)
+ use iso_c_binding
+ type(c_ptr), intent(in) :: cptr
+ character(len=:), pointer, intent(out) :: fstrptr
+ integer, intent(in) :: nchars
+ ! CHECK: %[[NCHARS_LOAD:.*]] = fir.load %[[NCHARS]]
+ ! CHECK: %[[ADDR_REF:.*]] = fir.coordinate_of %[[CPTR]], __address
+ ! CHECK: %[[ADDR_VAL:.*]] = fir.load %[[ADDR_REF]] : !fir.ref<i64>
+ ! CHECK: %[[NCHARS_IDX:.*]] = fir.convert %[[NCHARS_LOAD]] : (i32) -> index
+ ! CHECK: %[[PTR:.*]] = fir.convert %[[ADDR_VAL]] : (i64) -> !fir.ptr<!fir.char<1,?>>
+ ! CHECK: %[[BOX:.*]] = fir.embox %[[PTR]] typeparams %[[NCHARS_IDX]] : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.store %[[BOX]] to %[[FSTRPTR]]
+ call c_f_strpointer(cptr, fstrptr, nchars)
+end subroutine
+
+end
diff --git a/flang/test/Semantics/c_f_strpointer.f90 b/flang/test/Semantics/c_f_strpointer.f90
new file mode 100644
index 0000000000000..4b401a20e30c4
--- /dev/null
+++ b/flang/test/Semantics/c_f_strpointer.f90
@@ -0,0 +1,46 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+! Enforce C_F_STRPOINTER semantics (18.2.3.5)
+
+program test
+ use iso_c_binding
+ type(c_ptr) :: cptr
+ character(len=:), pointer :: fstrptr
+ character(len=1, kind=c_char), dimension(100), target :: cstrarray
+ character(len=10), pointer :: fstrptr_not_deferred
+ integer :: nchars
+
+ ! Valid calls
+ call c_f_strpointer(cstrarray, fstrptr) ! ok
+ call c_f_strpointer(cstrarray, fstrptr, 50) ! ok with NCHARS
+ call c_f_strpointer(cptr, fstrptr, 100) ! ok with CSTRPTR form
+
+ ! Error: CSTRPTR form requires NCHARS
+ !ERROR: NCHARS= argument is required when CSTRPTR= appears in C_F_STRPOINTER()
+ call c_f_strpointer(cptr, fstrptr)
+
+ ! Error: FSTRPTR must have deferred length
+ !ERROR: FSTRPTR= argument to C_F_STRPOINTER() must have deferred length
+ call c_f_strpointer(cstrarray, fstrptr_not_deferred)
+
+ ! Error: NCHARS must be non-negative
+ !ERROR: NCHARS= argument to C_F_STRPOINTER() must be non-negative
+ call c_f_strpointer(cstrarray, fstrptr, -5)
+
+ ! Error: NCHARS greater than array size (compile-time check)
+ !ERROR: NCHARS=150 is greater than the size of CSTRARRAY=100 in C_F_STRPOINTER()
+ call c_f_strpointer(cstrarray, fstrptr, 150)
+
+end program
+
+subroutine test_assumed_size(cstrarray_assumed, fstrptr)
+ use iso_c_binding
+ character(len=1, kind=c_char), dimension(*), target, intent(in) :: cstrarray_assumed
+ character(len=:), pointer :: fstrptr
+
+ ! Error: Assumed-size requires NCHARS
+ !ERROR: NCHARS= argument is required when CSTRARRAY= is assumed-size in C_F_STRPOINTER()
+ call c_f_strpointer(cstrarray_assumed, fstrptr)
+
+ ! Valid: Assumed-size with NCHARS
+ call c_f_strpointer(cstrarray_assumed, fstrptr, 100)
+end subroutine
More information about the flang-commits
mailing list