[flang] Implement C_F_STRPOINTER (Fortran 2023) (#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.
This commit is contained in:
Caroline Newcombe
GitHub
parent
d18f6d086e
commit
4b109dc5ac
@ -231,6 +231,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>
|
||||
|
||||
@ -2898,6 +2898,8 @@ private:
|
||||
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(
|
||||
@ -2940,7 +2942,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 {
|
||||
@ -3256,6 +3258,206 @@ 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 (overloaded).
|
||||
// Assign common internal keyword "cstr" for CheckAndRearrangeArguments.
|
||||
std::optional<std::string> firstArgKeyword;
|
||||
for (auto &arg : arguments) {
|
||||
if (arg && arg->keyword()) {
|
||||
auto kw{arg->keyword()->ToString()};
|
||||
if (kw == "cstrarray" || kw == "cstrptr") {
|
||||
if (!firstArgKeyword) {
|
||||
firstArgKeyword = kw;
|
||||
}
|
||||
static const char cstrKeyword[] = "cstr";
|
||||
arg->set_keyword(
|
||||
parser::CharBlock{cstrKeyword, sizeof(cstrKeyword) - 1});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static const char *const keywords[]{"cstr", "fstrptr", "nchars", nullptr};
|
||||
characteristics::DummyArguments dummies;
|
||||
if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
|
||||
CHECK(arguments.size() == 3);
|
||||
const bool hasNchars{arguments[2].has_value()};
|
||||
const int cCharKind = defaults_.GetDefaultKind(TypeCategory::Character);
|
||||
|
||||
// Check first argument (CSTRARRAY or CSTRPTR) and optional third argument
|
||||
// (NCHARS)
|
||||
if (const auto *expr{arguments[0].value().UnwrapExpr()}) {
|
||||
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 (firstArgKeyword && *firstArgKeyword != "cstrptr") {
|
||||
context.messages().Say(at,
|
||||
"Keyword CSTRARRAY= cannot be used with a C_PTR argument; use CSTRPTR= instead"_err_en_US);
|
||||
}
|
||||
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 (firstArgKeyword && *firstArgKeyword != "cstrarray") {
|
||||
context.messages().Say(at,
|
||||
"Keyword CSTRPTR= cannot be used with a character array argument; use CSTRARRAY= instead"_err_en_US);
|
||||
}
|
||||
if (type->kind() != cCharKind) {
|
||||
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) {
|
||||
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() != cCharKind) {
|
||||
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 {
|
||||
@ -3538,6 +3740,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) {
|
||||
|
||||
@ -193,6 +193,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>},
|
||||
@ -3250,6 +3256,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,
|
||||
|
||||
@ -31,6 +31,9 @@ module __fortran_builtins
|
||||
intrinsic :: __builtin_f_c_string
|
||||
public :: __builtin_f_c_string
|
||||
|
||||
intrinsic :: __builtin_c_f_strpointer
|
||||
public :: __builtin_c_f_strpointer
|
||||
|
||||
intrinsic :: __builtin_show_descriptor
|
||||
public :: __builtin_show_descriptor
|
||||
|
||||
|
||||
@ -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, &
|
||||
@ -29,8 +30,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, f_c_string, &
|
||||
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, f_c_string, &
|
||||
operator(==), operator(/=)
|
||||
|
||||
! Table 18.2 (in clause 18.3.1)
|
||||
|
||||
58
flang/test/Lower/Intrinsics/c_f_strpointer.f90
Normal file
58
flang/test/Lower/Intrinsics/c_f_strpointer.f90
Normal file
@ -0,0 +1,58 @@
|
||||
! RUN: bbc -emit-hlfir %s -o - | FileCheck %s
|
||||
! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
|
||||
|
||||
! Test intrinsic module procedure c_f_strpointer
|
||||
|
||||
! CHECK-LABEL: func.func @_QPtest_cstrarray(
|
||||
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-DAG: %[[CSTRARRAY_DECL:.*]]:2 = hlfir.declare %{{.*}} {{.*}} {{{.*}}uniq_name = "_QFtest_cstrarrayEcstrarray"}
|
||||
! CHECK-DAG: %[[FSTRPTR_DECL:.*]]:2 = hlfir.declare %{{.*}} {{.*}} {{{.*}}uniq_name = "_QFtest_cstrarrayEfstrptr"}
|
||||
! CHECK: %[[NCHARS:.*]] = arith.constant 100 : i32
|
||||
! CHECK: %[[NCHARS_IDX:.*]] = fir.convert %[[NCHARS]] : (i32) -> index
|
||||
! CHECK: %[[PTR:.*]] = fir.convert %[[CSTRARRAY_DECL]]#1 : (!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_DECL]]#0
|
||||
call c_f_strpointer(cstrarray, fstrptr, 100)
|
||||
end subroutine
|
||||
|
||||
! CHECK-LABEL: func.func @_QPtest_cstrarray_no_nchars(
|
||||
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-DAG: %[[CSTRARRAY_DECL:.*]]:2 = hlfir.declare %{{.*}} {{.*}} {{{.*}}uniq_name = "_QFtest_cstrarray_no_ncharsEcstrarray"}
|
||||
! CHECK-DAG: %[[FSTRPTR_DECL:.*]]:2 = hlfir.declare %{{.*}} {{.*}} {{{.*}}uniq_name = "_QFtest_cstrarray_no_ncharsEfstrptr"}
|
||||
! CHECK: hlfir.assign %{{.*}} to %[[CSTRARRAY_DECL]]#0
|
||||
! CHECK: %[[I8PTR:.*]] = fir.convert %[[CSTRARRAY_DECL]]#0 : (!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_DECL]]#0 : (!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_DECL]]#0
|
||||
cstrarray = 'Hello' // c_null_char
|
||||
call c_f_strpointer(cstrarray, fstrptr)
|
||||
end subroutine
|
||||
|
||||
! CHECK-LABEL: func.func @_QPtest_cstrptr(
|
||||
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-DAG: %[[CPTR_DECL:.*]]:2 = hlfir.declare %{{.*}} {{.*}} {{{.*}}uniq_name = "_QFtest_cstrptrEcptr"}
|
||||
! CHECK-DAG: %[[FSTRPTR_DECL:.*]]:2 = hlfir.declare %{{.*}} {{.*}} {{{.*}}uniq_name = "_QFtest_cstrptrEfstrptr"}
|
||||
! CHECK-DAG: %[[NCHARS_DECL:.*]]:2 = hlfir.declare %{{.*}} {{.*}} {{{.*}}uniq_name = "_QFtest_cstrptrEnchars"}
|
||||
! CHECK: %[[NCHARS_LOAD:.*]] = fir.load %[[NCHARS_DECL]]#0
|
||||
! CHECK: %[[ADDR_REF:.*]] = fir.coordinate_of %[[CPTR_DECL]]#0, __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_DECL]]#0
|
||||
call c_f_strpointer(cptr, fstrptr, nchars)
|
||||
end subroutine
|
||||
|
||||
end
|
||||
74
flang/test/Semantics/c_f_strpointer.f90
Normal file
74
flang/test/Semantics/c_f_strpointer.f90
Normal file
@ -0,0 +1,74 @@
|
||||
! 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
|
||||
call c_f_strpointer(CSTRARRAY=cstrarray, FSTRPTR=fstrptr) ! ok with CSTRARRAY keyword
|
||||
call c_f_strpointer(CSTRARRAY=cstrarray, FSTRPTR=fstrptr, NCHARS=50) ! ok with all keywords
|
||||
call c_f_strpointer(CSTRPTR=cptr, FSTRPTR=fstrptr, NCHARS=50) ! ok with all keywords
|
||||
|
||||
! Error: CSTRPTR form requires NCHARS
|
||||
!ERROR: NCHARS= argument is required when CSTRPTR= appears in C_F_STRPOINTER()
|
||||
call c_f_strpointer(cptr, fstrptr)
|
||||
|
||||
! Error: CSTRPTR form requires NCHARS (with explicit keyword)
|
||||
!ERROR: NCHARS= argument is required when CSTRPTR= appears in C_F_STRPOINTER()
|
||||
call c_f_strpointer(CSTRPTR=cptr, FSTRPTR=fstrptr)
|
||||
|
||||
! Error: Wrong keyword for C_PTR argument
|
||||
!ERROR: Keyword CSTRARRAY= cannot be used with a C_PTR argument; use CSTRPTR= instead
|
||||
call c_f_strpointer(CSTRARRAY=cptr, FSTRPTR=fstrptr, NCHARS=10)
|
||||
|
||||
! Error: Wrong keyword for character array argument
|
||||
!ERROR: Keyword CSTRPTR= cannot be used with a character array argument; use CSTRARRAY= instead
|
||||
call c_f_strpointer(CSTRPTR=cstrarray, FSTRPTR=fstrptr, NCHARS=50)
|
||||
|
||||
! 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)
|
||||
|
||||
! Error: Missing required argument FSTRPTR
|
||||
!ERROR: Dummy argument 'fstrptr=' is absent and not OPTIONAL
|
||||
call c_f_strpointer(cstrarray)
|
||||
|
||||
! Error: Missing both required arguments
|
||||
!ERROR: Dummy argument 'cstr=' is absent and not OPTIONAL
|
||||
!ERROR: Dummy argument 'fstrptr=' is absent and not OPTIONAL
|
||||
call c_f_strpointer()
|
||||
|
||||
! Error: Too many arguments
|
||||
!ERROR: Too many actual arguments (4 > 3)
|
||||
call c_f_strpointer(cstrarray, fstrptr, 50, 999)
|
||||
|
||||
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
|
||||
Loading…
x
Reference in New Issue
Block a user