shylie/llvm-project
1
0
Fork 0
Code Issues Pull Requests Actions 6 Packages Projects Releases Wiki Activity

[flang] Implement 'F_C_STRING' library function (Fortran 2023) (#174474)

Browse Source 
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])`.
This commit is contained in:
Caroline Newcombe 2026-02-10 12:30:31 -06:00 committed by GitHub
parent a88274f008
commit d3a70f3b2c
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
12 changed files with 288 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
flang-rt/lib/runtime/character.cpp
View File

@ -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<const char>(), 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<char>(chars) = '\0';
}
void RTDEF(Trim)(Descriptor &result, const Descriptor &string,
const char *sourceFile, int sourceLine) {
Terminator terminator{sourceFile, sourceLine};

95
flang-rt/unittests/Runtime/CharacterTest.cpp
View File

@ -430,3 +430,98 @@ TYPED_TEST(RepeatTests, Repeat) {
RunRepeatTest<TypeParam>(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<Descriptor> 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<char>();
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<Descriptor> 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<char>();
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<Descriptor> 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<char>();
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<Descriptor> 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<char>();
EXPECT_EQ(std::string(data, 6), std::string("hello\0", 6));
result->Destroy();
}
}

2
flang/include/flang/Optimizer/Builder/IntrinsicCall.h
View File

@ -261,6 +261,8 @@ struct IntrinsicLibrary {
llvm::ArrayRef<fir::ExtendedValue>);
template <Extremum, ExtremumBehavior>
mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>);
fir::ExtendedValue genFCString(mlir::Type,
llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
void genFlush(llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genFraction(mlir::Type resultType,

14
flang/include/flang/Optimizer/Builder/Runtime/Character.h
View File

@ -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<i1>) 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.

3
flang/include/flang/Runtime/character.h
View File

@ -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,

5
flang/lib/Evaluate/intrinsics.cpp
View File

@ -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",

30
flang/lib/Optimizer/Builder/IntrinsicCall.cpp
View File

@ -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<fir::ExtendedValue> 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,

13
flang/lib/Optimizer/Builder/Runtime/Character.cpp
View File

@ -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<mkRTKey(FCString)>(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,

3
flang/module/__fortran_builtins.f90
View File

@ -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

3
flang/module/iso_c_binding.f90
View File

@ -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)

52
flang/test/Lower/Intrinsics/f_c_string.f90 Normal file
View File

@ -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<!fir.heap<!fir.char<1,?>>>
! CHECK: %[[strBox:.*]] = fir.embox %{{.*}} typeparams %{{.*}} : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
! CHECK: %[[resBoxNone:.*]] = fir.convert %[[tmpBox]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: %[[strBoxNone:.*]] = fir.convert %[[strBox]] : (!fir.box<!fir.char<1,?>>) -> !fir.box<none>
! CHECK: %{{.*}} = fir.convert %{{.*}} : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
! CHECK: fir.call @_FortranAFCString(%[[resBoxNone]], %[[strBoxNone]], %{{(false|.*)}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.box<none>, i1, !fir.ref<i8>, 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<!fir.logical<4>>{{.*}}) {
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<!fir.heap<!fir.char<1,?>>>
! CHECK: %[[strBox:.*]] = fir.embox %{{.*}} typeparams %{{.*}} : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
! CHECK: %[[resBoxNone:.*]] = fir.convert %[[tmpBox]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: %[[strBoxNone:.*]] = fir.convert %[[strBox]] : (!fir.box<!fir.char<1,?>>) -> !fir.box<none>
! CHECK: %[[asisBool:.*]] = fir.convert %{{.*}} : (!fir.logical<4>) -> i1
! CHECK: %{{.*}} = fir.convert %{{.*}} : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
! CHECK: fir.call @_FortranAFCString(%[[resBoxNone]], %[[strBoxNone]], %[[asisBool]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.box<none>, i1, !fir.ref<i8>, 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.char<1,{{.*}}>>) -> !fir.ref<i8>
! CHECK: fir.call @_FortranAFCString(%{{.*}}, %{{.*}}, %{{(true|.*)}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.box<none>, i1, !fir.ref<i8>, i32) -> ()
result = f_c_string('hello', .true.)
end subroutine

49
flang/test/Semantics/f_c_string.f90 Normal file
View File

@ -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