From d3a70f3b2c7174d8fdea94e966b5bbc5ba7466ec Mon Sep 17 00:00:00 2001 From: Caroline Newcombe Date: Tue, 10 Feb 2026 12:30:31 -0600 Subject: [PATCH] [flang] Implement 'F_C_STRING' library function (Fortran 2023) (#174474) Implement `F_C_STRING` to convert a Fortran string to a C null-terminated string. Documented in F2023 Standard: 18.2.3.9 `F_C_STRING (STRING [, ASIS])`. --- flang-rt/lib/runtime/character.cpp | 20 ++++ flang-rt/unittests/Runtime/CharacterTest.cpp | 95 +++++++++++++++++++ .../flang/Optimizer/Builder/IntrinsicCall.h | 2 + .../Optimizer/Builder/Runtime/Character.h | 14 +++ flang/include/flang/Runtime/character.h | 3 + flang/lib/Evaluate/intrinsics.cpp | 5 + flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 30 ++++++ .../Optimizer/Builder/Runtime/Character.cpp | 13 +++ flang/module/__fortran_builtins.f90 | 3 + flang/module/iso_c_binding.f90 | 3 +- flang/test/Lower/Intrinsics/f_c_string.f90 | 52 ++++++++++ flang/test/Semantics/f_c_string.f90 | 49 ++++++++++ 12 files changed, 288 insertions(+), 1 deletion(-) create mode 100644 flang/test/Lower/Intrinsics/f_c_string.f90 create mode 100644 flang/test/Semantics/f_c_string.f90 diff --git a/flang-rt/lib/runtime/character.cpp b/flang-rt/lib/runtime/character.cpp index c9ac55736d42..04c9055f8449 100644 --- a/flang-rt/lib/runtime/character.cpp +++ b/flang-rt/lib/runtime/character.cpp @@ -843,6 +843,26 @@ void RTDEF(Repeat)(Descriptor &result, const Descriptor &string, } } +// F_C_STRING - Appends null terminator to create C-compatible string +// If asis is false, trailing blanks are trimmed first +void RTDEF(FCString)(Descriptor &result, const Descriptor &string, bool asis, + const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + RUNTIME_CHECK(terminator, string.raw().type == CFI_type_char); + std::size_t chars{string.ElementBytes()}; + if (!asis) { + chars = LenTrim(string.OffsetElement(), chars); + } + std::size_t resultBytes{chars + 1}; + result.Establish(string.type(), resultBytes, nullptr, 0, nullptr, + CFI_attribute_allocatable); + RUNTIME_CHECK(terminator, result.Allocate(kNoAsyncObject) == CFI_SUCCESS); + if (chars > 0) { + std::memcpy(result.OffsetElement(), string.OffsetElement(), chars); + } + *result.OffsetElement(chars) = '\0'; +} + void RTDEF(Trim)(Descriptor &result, const Descriptor &string, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; diff --git a/flang-rt/unittests/Runtime/CharacterTest.cpp b/flang-rt/unittests/Runtime/CharacterTest.cpp index 2c7af27b9da7..5d8bcd2354c4 100644 --- a/flang-rt/unittests/Runtime/CharacterTest.cpp +++ b/flang-rt/unittests/Runtime/CharacterTest.cpp @@ -430,3 +430,98 @@ TYPED_TEST(RepeatTests, Repeat) { RunRepeatTest(t.ncopies, t.input, t.output); } } + +// Test F_C_STRING() +TEST(CharacterTests, FCString) { + // Test 1: Default behavior (trim trailing blanks) + { + static char buffer[11]; // "abc " = 10 chars + std::memset(buffer, ' ', 10); + std::memcpy(buffer, "abc", 3); + + StaticDescriptor<0> inputStaticDescriptor; + Descriptor &input{inputStaticDescriptor.descriptor()}; + input.Establish(TypeCode{CFI_type_char}, /*elemLen=*/10, buffer, 0, nullptr, + CFI_attribute_pointer); + + OwningPtr result{Descriptor::Create(TypeCode{CFI_type_char}, 1, + nullptr, 0, nullptr, CFI_attribute_allocatable)}; + + RTNAME(FCString)(*result, input, /*asis=*/false); + + EXPECT_EQ(result->ElementBytes(), std::size_t(4)); // "abc\0" = 4 bytes + const char *data = result->OffsetElement(); + EXPECT_EQ(std::string(data, 4), std::string("abc\0", 4)); + + result->Destroy(); + } + + // Test 2: Keep trailing blanks (asis=true) + { + static char buffer[11]; + std::memset(buffer, ' ', 10); + std::memcpy(buffer, "abc", 3); + + StaticDescriptor<0> inputStaticDescriptor; + Descriptor &input{inputStaticDescriptor.descriptor()}; + input.Establish(TypeCode{CFI_type_char}, /*elemLen=*/10, buffer, 0, nullptr, + CFI_attribute_pointer); + + OwningPtr result{Descriptor::Create(TypeCode{CFI_type_char}, 1, + nullptr, 0, nullptr, CFI_attribute_allocatable)}; + + RTNAME(FCString)(*result, input, /*asis=*/true); + + EXPECT_EQ( + result->ElementBytes(), std::size_t(11)); // "abc \0" = 11 bytes + const char *data = result->OffsetElement(); + EXPECT_EQ(data[3], ' '); // Verify space preserved + EXPECT_EQ(data[10], '\0'); // Verify null terminator + + result->Destroy(); + } + + // Test 3: All blanks, trimmed + { + static char buffer[11]; + std::memset(buffer, ' ', 10); + + StaticDescriptor<0> inputStaticDescriptor; + Descriptor &input{inputStaticDescriptor.descriptor()}; + input.Establish(TypeCode{CFI_type_char}, /*elemLen=*/10, buffer, 0, nullptr, + CFI_attribute_pointer); + + OwningPtr result{Descriptor::Create(TypeCode{CFI_type_char}, 1, + nullptr, 0, nullptr, CFI_attribute_allocatable)}; + + RTNAME(FCString)(*result, input, /*asis=*/false); + + EXPECT_EQ(result->ElementBytes(), std::size_t(1)); // Just "\0" + const char *data = result->OffsetElement(); + EXPECT_EQ(data[0], '\0'); + + result->Destroy(); + } + + // Test 4: No trailing blanks + { + static char buffer[11]; + std::memcpy(buffer, "hello", 5); + + StaticDescriptor<0> inputStaticDescriptor; + Descriptor &input{inputStaticDescriptor.descriptor()}; + input.Establish(TypeCode{CFI_type_char}, /*elemLen=*/5, buffer, 0, nullptr, + CFI_attribute_pointer); + + OwningPtr result{Descriptor::Create(TypeCode{CFI_type_char}, 1, + nullptr, 0, nullptr, CFI_attribute_allocatable)}; + + RTNAME(FCString)(*result, input, /*asis=*/false); + + EXPECT_EQ(result->ElementBytes(), std::size_t(6)); // "hello\0" + const char *data = result->OffsetElement(); + EXPECT_EQ(std::string(data, 6), std::string("hello\0", 6)); + + result->Destroy(); + } +} diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h index 0b62ca1292d9..56642a38cb1c 100644 --- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h +++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h @@ -261,6 +261,8 @@ struct IntrinsicLibrary { llvm::ArrayRef); template mlir::Value genExtremum(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genFCString(mlir::Type, + llvm::ArrayRef); mlir::Value genFloor(mlir::Type, llvm::ArrayRef); void genFlush(llvm::ArrayRef); mlir::Value genFraction(mlir::Type resultType, diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Character.h b/flang/include/flang/Optimizer/Builder/Runtime/Character.h index 261ac348a402..b7181e33d688 100644 --- a/flang/include/flang/Optimizer/Builder/Runtime/Character.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/Character.h @@ -57,6 +57,20 @@ mlir::Value genCharCompare(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value lhsLen, mlir::Value rhsBuff, mlir::Value rhsLen); +/// Generate call to F_C_STRING intrinsic runtime routine +/// This appends a null character to a Fortran character string to create +/// a C-compatible null-terminated string. +/// +/// \p resultBox must be an unallocated allocatable used for the temporary +/// result. \p stringBox must be a fir.box describing the F_C_STRING string +/// argument. \p asis must be a boxed logical value (fir.box) or an +/// AbsentOp: if true, trailing blanks are kept; if false or absent (default), +/// trailing blanks are trimmed before appending the null. +/// The runtime will always allocate the resultBox. +void genFCString(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox, + mlir::Value asis); + /// Generate call to INDEX runtime. /// This calls the simple runtime entry points based on the KIND of the string. /// No descriptors are used. diff --git a/flang/include/flang/Runtime/character.h b/flang/include/flang/Runtime/character.h index dd47686fe858..36a66fc50e71 100644 --- a/flang/include/flang/Runtime/character.h +++ b/flang/include/flang/Runtime/character.h @@ -93,6 +93,9 @@ void RTDECL(Repeat)(Descriptor &result, const Descriptor &string, void RTDECL(Trim)(Descriptor &result, const Descriptor &string, const char *sourceFile = nullptr, int sourceLine = 0); +void RTDECL(FCString)(Descriptor &result, const Descriptor &string, + bool asis = false, const char *sourceFile = nullptr, int sourceLine = 0); + void RTDECL(CharacterMax)(Descriptor &accumulator, const Descriptor &x, const char *sourceFile = nullptr, int sourceLine = 0); void RTDECL(CharacterMin)(Descriptor &accumulator, const Descriptor &x, diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index 6bab713136a0..1242e18ba246 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -132,6 +132,7 @@ static constexpr TypePattern DefaultChar{CharType, KindCode::defaultCharKind}; static constexpr TypePattern DefaultLogical{ LogicalType, KindCode::defaultLogicalKind}; static constexpr TypePattern BOZ{IntType, KindCode::typeless}; +static constexpr TypePattern CChar{CharType, KindCode::defaultCharKind}; static constexpr TypePattern EventType{DerivedType, KindCode::eventType}; static constexpr TypePattern IeeeFlagType{DerivedType, KindCode::ieeeFlagType}; static constexpr TypePattern IeeeRoundType{ @@ -517,6 +518,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ Optionality::required, common::Intent::In, {ArgFlag::canBeMoldNull}}}, DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, + {"__builtin_f_c_string", + {{"string", CChar, Rank::scalar}, + {"asis", AnyLogical, Rank::scalar, Optionality::optional}}, + CChar, Rank::scalar, IntrinsicClass::transformationalFunction}, {"failed_images", {OptionalTEAM, SizeDefaultKIND}, KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, {"findloc", diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 2541e41bb405..bf76a78e7e25 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -299,6 +299,10 @@ static constexpr IntrinsicHandler handlers[]{ &I::genExtendsTypeOf, {{{"a", asBox}, {"mold", asBox}}}, /*isElemental=*/false}, + {"f_c_string", + &I::genFCString, + {{{"string", asAddr}, {"asis", asValue, handleDynamicOptional}}}, + /*isElemental=*/false}, {"findloc", &I::genFindloc, {{{"array", asBox}, @@ -3879,6 +3883,32 @@ IntrinsicLibrary::genExtendsTypeOf(mlir::Type resultType, fir::getBase(args[1]))); } +// F_C_STRING +fir::ExtendedValue +IntrinsicLibrary::genFCString(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() >= 1 && args.size() <= 2); + + mlir::Value string = builder.createBox(loc, args[0]); + + // Handle optional ASIS argument + mlir::Value asis = isStaticallyAbsent(args, 1) + ? builder.createBool(loc, false) + : fir::getBase(args[1]); + + // Create mutable fir.box to be passed to the runtime for the result. + fir::MutableBoxValue resultMutableBox = + fir::factory::createTempMutableBox(builder, loc, resultType); + mlir::Value resultIrBox = + fir::factory::getMutableIRBox(builder, loc, resultMutableBox); + + fir::runtime::genFCString(builder, loc, resultIrBox, string, asis); + + // Read result from mutable fir.box and add it to the list of temps to be + // finalized by the StatementContext. + return readAndAddCleanUp(resultMutableBox, resultType, "F_C_STRING"); +} + // FINDLOC fir::ExtendedValue IntrinsicLibrary::genFindloc(mlir::Type resultType, diff --git a/flang/lib/Optimizer/Builder/Runtime/Character.cpp b/flang/lib/Optimizer/Builder/Runtime/Character.cpp index 2f1772f602ac..e297125880f7 100644 --- a/flang/lib/Optimizer/Builder/Runtime/Character.cpp +++ b/flang/lib/Optimizer/Builder/Runtime/Character.cpp @@ -147,6 +147,19 @@ mlir::Value fir::runtime::genCharCompare(fir::FirOpBuilder &builder, rhsBuffer, fir::getLen(rhs)); } +void fir::runtime::genFCString(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox, + mlir::Value asis) { + auto func = fir::runtime::getRuntimeFunc(loc, builder); + auto fTy = func.getFunctionType(); + auto sourceFile = fir::factory::locationToFilename(builder, loc); + auto sourceLine = + fir::factory::locationToLineNo(builder, loc, fTy.getInput(4)); + auto args = fir::runtime::createArguments( + builder, loc, fTy, resultBox, stringBox, asis, sourceFile, sourceLine); + fir::CallOp::create(builder, loc, func, args); +} + mlir::Value fir::runtime::genIndex(fir::FirOpBuilder &builder, mlir::Location loc, int kind, mlir::Value stringBase, diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90 index a9b60508785d..3f313f8ffbe8 100644 --- a/flang/module/__fortran_builtins.f90 +++ b/flang/module/__fortran_builtins.f90 @@ -28,6 +28,9 @@ module __fortran_builtins intrinsic :: __builtin_c_f_pointer public :: __builtin_c_f_pointer + intrinsic :: __builtin_f_c_string + public :: __builtin_f_c_string + 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 a1807f9a7da2..9b4a3fe1c34c 100644 --- a/flang/module/iso_c_binding.f90 +++ b/flang/module/iso_c_binding.f90 @@ -20,6 +20,7 @@ module iso_c_binding c_null_ptr => __builtin_c_null_ptr, & c_ptr => __builtin_c_ptr, & c_sizeof => sizeof, & + f_c_string => __builtin_f_c_string, & operator(==), operator(/=) implicit none @@ -29,7 +30,7 @@ module iso_c_binding private public :: c_associated, c_funloc, c_funptr, c_f_pointer, c_loc, & - c_null_funptr, c_null_ptr, c_ptr, c_sizeof, & + c_null_funptr, c_null_ptr, c_ptr, c_sizeof, f_c_string, & operator(==), operator(/=) ! Table 18.2 (in clause 18.3.1) diff --git a/flang/test/Lower/Intrinsics/f_c_string.f90 b/flang/test/Lower/Intrinsics/f_c_string.f90 new file mode 100644 index 000000000000..f6fabab89736 --- /dev/null +++ b/flang/test/Lower/Intrinsics/f_c_string.f90 @@ -0,0 +1,52 @@ +! RUN: bbc -emit-hlfir %s -o - | FileCheck %s +! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s + +! Test lowering of F_C_STRING intrinsic from ISO_C_BINDING + +! CHECK-LABEL: func @_QPtest_default( +! CHECK-SAME: %[[arg0:.*]]: !fir.boxchar<1>{{.*}}) { +subroutine test_default(str) + use iso_c_binding + character(*) :: str + character(:), allocatable :: result + + ! CHECK: %[[tmpBox:.*]] = fir.alloca !fir.box>> + ! CHECK: %[[strBox:.*]] = fir.embox %{{.*}} typeparams %{{.*}} : (!fir.ref>, index) -> !fir.box> + ! CHECK: %[[resBoxNone:.*]] = fir.convert %[[tmpBox]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: %[[strBoxNone:.*]] = fir.convert %[[strBox]] : (!fir.box>) -> !fir.box + ! CHECK: %{{.*}} = fir.convert %{{.*}} : (!fir.ref>) -> !fir.ref + ! CHECK: fir.call @_FortranAFCString(%[[resBoxNone]], %[[strBoxNone]], %{{(false|.*)}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.ref, i32) -> () + result = f_c_string(str) + + ! CHECK: fir.freemem +end subroutine + +! CHECK-LABEL: func @_QPtest_with_asis( +! CHECK-SAME: %[[arg0:.*]]: !fir.boxchar<1>{{.*}}, %[[arg1:.*]]: !fir.ref>{{.*}}) { +subroutine test_with_asis(str, keep_blanks) + use iso_c_binding + character(*) :: str + logical :: keep_blanks + character(:), allocatable :: result + + ! CHECK: %[[tmpBox:.*]] = fir.alloca !fir.box>> + ! CHECK: %[[strBox:.*]] = fir.embox %{{.*}} typeparams %{{.*}} : (!fir.ref>, index) -> !fir.box> + ! CHECK: %[[resBoxNone:.*]] = fir.convert %[[tmpBox]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: %[[strBoxNone:.*]] = fir.convert %[[strBox]] : (!fir.box>) -> !fir.box + ! CHECK: %[[asisBool:.*]] = fir.convert %{{.*}} : (!fir.logical<4>) -> i1 + ! CHECK: %{{.*}} = fir.convert %{{.*}} : (!fir.ref>) -> !fir.ref + ! CHECK: fir.call @_FortranAFCString(%[[resBoxNone]], %[[strBoxNone]], %[[asisBool]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.ref, i32) -> () + result = f_c_string(str, keep_blanks) + + ! CHECK: fir.freemem +end subroutine + +! CHECK-LABEL: func @_QPtest_literal_asis( +subroutine test_literal_asis() + use iso_c_binding + character(:), allocatable :: result + + ! CHECK: %{{.*}} = fir.convert %{{.*}} : (!fir.ref>) -> !fir.ref + ! CHECK: fir.call @_FortranAFCString(%{{.*}}, %{{.*}}, %{{(true|.*)}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.ref, i32) -> () + result = f_c_string('hello', .true.) +end subroutine diff --git a/flang/test/Semantics/f_c_string.f90 b/flang/test/Semantics/f_c_string.f90 new file mode 100644 index 000000000000..cfba259590ff --- /dev/null +++ b/flang/test/Semantics/f_c_string.f90 @@ -0,0 +1,49 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Test semantic checking of F_C_STRING from ISO_C_BINDING + +program test + use iso_c_binding + implicit none + + character(len=20) :: str + character(len=:), allocatable :: result + logical :: flag + integer :: n + real :: x + character(len=20), dimension(2) :: str_array + + ! Valid usages + result = f_c_string('hello') + result = f_c_string(str) + result = f_c_string(str, .true.) + result = f_c_string(str, .false.) + result = f_c_string(str, flag) + result = f_c_string(string=str) + result = f_c_string(string=str, asis=.true.) + result = f_c_string(asis=.false., string=str) + + ! Invalid: missing required argument + !ERROR: missing mandatory 'string=' argument + result = f_c_string() + + ! Invalid: non-character first argument + !ERROR: Actual argument for 'string=' has bad type 'INTEGER(4)' + result = f_c_string(n) + + ! Invalid: non-character first argument (real) + !ERROR: Actual argument for 'string=' has bad type 'REAL(4)' + result = f_c_string(x) + + ! Invalid: non-logical second argument + !ERROR: Actual argument for 'asis=' has bad type 'INTEGER(4)' + result = f_c_string(str, n) + + ! Invalid: too many arguments + !ERROR: too many actual arguments for intrinsic '__builtin_f_c_string' + result = f_c_string(str, .true., .false.) + + ! Invalid: array argument (must be scalar) + !ERROR: 'string=' argument has unacceptable rank 1 + result = f_c_string(str_array) + +end program