Skip to content

Commit f834b0c

Browse files
mjklemmmjklemm
authored
[Flang] Implement LOWER= argument for C_F_POINTER (Fortran 2023) (#149870)
This PR resolves issue #147819 and adds support for the F2023 extension of the `LOWER=` argument for `C_F_POINTER`.
1 parent 63c2b8a commit f834b0c

File tree

6 files changed

+147
-9
lines changed

6 files changed

+147
-9
lines changed

‎flang/docs/F202X.md

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -268,7 +268,6 @@ Addressing some issues and omissions in intrinsic modules:
268268
* LOGICAL8/16/32/64 and REAL16
269269
* IEEE module facilities upgraded to match latest IEEE FP standard
270270
* C_F_STRPOINTER, F_C_STRING for NUL-terminated strings
271-
* C_F_POINTER(LOWER=)
272271

273272
#### Intrinsic Procedure Extensions
274273

‎flang/docs/ReleaseNotes.md

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,8 @@ page](https://llvm.org/releases/).
2424

2525
## Major New Features
2626

27+
* Support for LOWER= argument for C_F_POINTER.
28+
2729
## Bug Fixes
2830

2931
## Non-comprehensive list of changes in this release

‎flang/lib/Evaluate/intrinsics.cpp

Lines changed: 40 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -3077,10 +3077,11 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
30773077
ActualArguments &arguments, FoldingContext &context) const {
30783078
characteristics::Procedure::Attrs attrs;
30793079
attrs.set(characteristics::Procedure::Attr::Subroutine);
3080-
static const char *const keywords[]{"cptr", "fptr", "shape", nullptr};
3080+
static const char *const keywords[]{
3081+
"cptr", "fptr", "shape", "lower", nullptr};
30813082
characteristics::DummyArguments dummies;
3082-
if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
3083-
CHECK(arguments.size() == 3);
3083+
if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 2)) {
3084+
CHECK(arguments.size() == 4);
30843085
if (const auto *expr{arguments[0].value().UnwrapExpr()}) {
30853086
// General semantic checks will catch an actual argument that's not
30863087
// scalar.
@@ -3173,11 +3174,30 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
31733174
}
31743175
}
31753176
}
3177+
if (arguments[3] && fptrRank == 0) {
3178+
context.messages().Say(arguments[3]->sourceLocation(),
3179+
"LOWER= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US);
3180+
} else if (arguments[3]) {
3181+
if (const auto *argExpr{arguments[3].value().UnwrapExpr()}) {
3182+
if (argExpr->Rank() > 1) {
3183+
context.messages().Say(arguments[3]->sourceLocation(),
3184+
"LOWER= argument to C_F_POINTER() must be a rank-one array."_err_en_US);
3185+
} else if (argExpr->Rank() == 1) {
3186+
if (auto constShape{GetConstantShape(context, *argExpr)}) {
3187+
if (constShape->At(ConstantSubscripts{1}).ToInt64() != fptrRank) {
3188+
context.messages().Say(arguments[3]->sourceLocation(),
3189+
"LOWER= argument to C_F_POINTER() must have size equal to the rank of FPTR="_err_en_US);
3190+
}
3191+
}
3192+
}
3193+
}
3194+
}
31763195
}
31773196
}
31783197
if (dummies.size() == 2) {
3198+
// Handle SHAPE
31793199
DynamicType shapeType{TypeCategory::Integer, defaults_.sizeIntegerKind()};
3180-
if (arguments[2]) {
3200+
if (arguments.size() >= 3 && arguments[2]) {
31813201
if (auto type{arguments[2]->GetType()}) {
31823202
if (type->category() == TypeCategory::Integer) {
31833203
shapeType = *type;
@@ -3189,6 +3209,22 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
31893209
shape.intent = common::Intent::In;
31903210
shape.attrs.set(characteristics::DummyDataObject::Attr::Optional);
31913211
dummies.emplace_back("shape"s, std::move(shape));
3212+
3213+
// Handle LOWER
3214+
DynamicType lowerType{TypeCategory::Integer, defaults_.sizeIntegerKind()};
3215+
if (arguments.size() >= 4 && arguments[3]) {
3216+
if (auto type{arguments[3]->GetType()}) {
3217+
if (type->category() == TypeCategory::Integer) {
3218+
lowerType = *type;
3219+
}
3220+
}
3221+
}
3222+
characteristics::DummyDataObject lower{
3223+
characteristics::TypeAndShape{lowerType, 1}};
3224+
lower.intent = common::Intent::In;
3225+
lower.attrs.set(characteristics::DummyDataObject::Attr::Optional);
3226+
dummies.emplace_back("lower"s, std::move(lower));
3227+
31923228
return SpecificCall{
31933229
SpecificIntrinsic{"__builtin_c_f_pointer"s,
31943230
characteristics::Procedure{std::move(dummies), attrs}},

‎flang/lib/Optimizer/Builder/IntrinsicCall.cpp

Lines changed: 22 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -371,7 +371,8 @@ static constexpr IntrinsicHandler handlers[]{
371371
&I::genCFPointer,
372372
{{{"cptr", asValue},
373373
{"fptr", asInquired},
374-
{"shape", asAddr, handleDynamicOptional}}},
374+
{"shape", asAddr, handleDynamicOptional},
375+
{"lower", asAddr, handleDynamicOptional}}},
375376
/*isElemental=*/false},
376377
{"c_f_procpointer",
377378
&I::genCFProcPointer,
@@ -3438,7 +3439,7 @@ IntrinsicLibrary::genCDevLoc(mlir::Type resultType,
34383439

34393440
// C_F_POINTER
34403441
void IntrinsicLibrary::genCFPointer(llvm::ArrayRef<fir::ExtendedValue> args) {
3441-
assert(args.size() == 3);
3442+
assert(args.size() == 4);
34423443
// Handle CPTR argument
34433444
// Get the value of the C address or the result of a reference to C_LOC.
34443445
mlir::Value cPtr = fir::getBase(args[0]);
@@ -3453,9 +3454,12 @@ void IntrinsicLibrary::genCFPointer(llvm::ArrayRef<fir::ExtendedValue> args) {
34533454
mlir::Value addr =
34543455
builder.createConvert(loc, fPtr->getMemTy(), cPtrAddrVal);
34553456
mlir::SmallVector<mlir::Value> extents;
3457+
mlir::SmallVector<mlir::Value> lbounds;
34563458
if (box.hasRank()) {
34573459
assert(isStaticallyPresent(args[2]) &&
34583460
"FPTR argument must be an array if SHAPE argument exists");
3461+
3462+
// Handle and unpack SHAPE argument
34593463
mlir::Value shape = fir::getBase(args[2]);
34603464
int arrayRank = box.rank();
34613465
mlir::Type shapeElementType =
@@ -3468,17 +3472,31 @@ void IntrinsicLibrary::genCFPointer(llvm::ArrayRef<fir::ExtendedValue> args) {
34683472
mlir::Value load = fir::LoadOp::create(builder, loc, var);
34693473
extents.push_back(builder.createConvert(loc, idxType, load));
34703474
}
3475+
3476+
// Handle and unpack LOWER argument if present
3477+
if (isStaticallyPresent(args[3])) {
3478+
mlir::Value lower = fir::getBase(args[3]);
3479+
mlir::Type lowerElementType =
3480+
fir::unwrapSequenceType(fir::unwrapPassByRefType(lower.getType()));
3481+
for (int i = 0; i < arrayRank; ++i) {
3482+
mlir::Value index = builder.createIntegerConstant(loc, idxType, i);
3483+
mlir::Value var = builder.create<fir::CoordinateOp>(
3484+
loc, builder.getRefType(lowerElementType), lower, index);
3485+
mlir::Value load = builder.create<fir::LoadOp>(loc, var);
3486+
lbounds.push_back(builder.createConvert(loc, idxType, load));
3487+
}
3488+
}
34713489
}
34723490
if (box.isCharacter()) {
34733491
mlir::Value len = box.nonDeferredLenParams()[0];
34743492
if (box.hasRank())
3475-
return fir::CharArrayBoxValue{addr, len, extents};
3493+
return fir::CharArrayBoxValue{addr, len, extents, lbounds};
34763494
return fir::CharBoxValue{addr, len};
34773495
}
34783496
if (box.isDerivedWithLenParameters())
34793497
TODO(loc, "get length parameters of derived type");
34803498
if (box.hasRank())
3481-
return fir::ArrayBoxValue{addr, extents};
3499+
return fir::ArrayBoxValue{addr, extents, lbounds};
34823500
return addr;
34833501
};
34843502

‎flang/test/Lower/Intrinsics/c_f_pointer.f90

Lines changed: 75 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -140,3 +140,78 @@ subroutine dynamic_shape_size_2(cptr, fptr, shape, n)
140140
! CHECK: %[[VAL_16:.*]] = fir.shape %[[VAL_11]], %[[VAL_15]] : (index, index) -> !fir.shape<2>
141141
call c_f_pointer(cptr, fptr, shape)
142142
end subroutine
143+
144+
! CHECK-LABEL: func.func @_QPdynamic_shape_lower(
145+
subroutine dynamic_shape_lower(cptr, fpr, shape, lower)
146+
use iso_c_binding
147+
type(c_ptr) :: cptr
148+
real, pointer :: fptr(:, :)
149+
integer :: n
150+
integer :: shape(:)
151+
integer :: lower(:)
152+
! CHECK: %[[C_0:.*]] = arith.constant 0 : index
153+
! CHECK: %[[VAL_2:.*]] = fir.shape %[[C_0]], %[[C_0]] : (index, index) -> !fir.shape<2>
154+
! CHECK: %[[VAL_3:.*]] = fir.embox %[[VAL_1:.*]](%[[VAL_2]]) : (!fir.ptr<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
155+
! CHECK: fir.store %[[VAL_3]] to %[[VAL_0:.*]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
156+
! CHECK: %[[VAL_4:.*]] = fir.alloca i32 {bindc_name = "n", uniq_name = "_QFdynamic_shape_lowerEn"}
157+
! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[ARG_0:.*]], __address : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>) -> !fir.ref<i64>
158+
! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.ref<i64>
159+
! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> !fir.ptr<!fir.array<?x?xf32>>
160+
! CHECK: %[[C_0:.*]]_0 = arith.constant 0 : index
161+
! CHECK: %[[VAL_8:.*]] = fir.coordinate_of %[[ARG_2:.*]], %[[C_0]]_0 : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
162+
! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_8]] : !fir.ref<i32>
163+
! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> index
164+
! CHECK: %[[C_1:.*]] = arith.constant 1 : index
165+
! CHECK: %[[VAL_11:.*]] = fir.coordinate_of %[[ARG_2:.*]], %[[C_1]] : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
166+
! CHECK: %[[VAL_12:.*]] = fir.load %[[VAL_11]] : !fir.ref<i32>
167+
! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (i32) -> index
168+
! CHECK: %[[C_0:.*]]_1 = arith.constant 0 : index
169+
! CHECK: %[[VAL_14:.*]] = fir.coordinate_of %[[ARG_3:.*]], %[[C_0]]_1 : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
170+
! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_14]] : !fir.ref<i32>
171+
! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i32) -> index
172+
! CHECK: %[[C_1:.*]]_2 = arith.constant 1 : index
173+
! CHECK: %[[VAL_17:.*]] = fir.coordinate_of %[[ARG_3:.*]], %[[C_1]]_2 : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
174+
! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_17]] : !fir.ref<i32>
175+
! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> index
176+
! CHECK: %[[VAL_20:.*]] = fir.shape_shift %[[VAL_16]], %[[VAL_10]], %[[VAL_19]], %[[VAL_13]] : (index, index, index, index) -> !fir.shapeshift<2>
177+
! CHECK: %[[VAL_21:.*]] = fir.embox %[[VAL_7]](%[[VAL_20]]) : (!fir.ptr<!fir.array<?x?xf32>>, !fir.shapeshift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
178+
! CHECK: fir.store %[[VAL_21:.*]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
179+
call c_f_pointer(cptr, fptr, shape, lower)
180+
end subroutine dynamic_shape_lower
181+
182+
! CHECK-LABEL: func.func @_QPdynamic_shape_lower_2(
183+
subroutine dynamic_shape_lower_2(cptr, fpr, shape, lower, n)
184+
use iso_c_binding
185+
type(c_ptr) :: cptr
186+
real, pointer :: fptr(:, :)
187+
integer :: n
188+
integer :: shape(n)
189+
integer :: lower(n)
190+
!CHECK: %[[C_0:.*]] = arith.constant 0 : index
191+
!CHECK: %[[VAL_2:.*]] = fir.shape %[[C_0]], %[[C_0]] : (index, index) -> !fir.shape<2>
192+
!CHECK: %[[VAL_3:.*]] = fir.embox %[[ARG1:.*]](%[[VAL_2]]) : (!fir.ptr<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
193+
!CHECK: fir.store %[[VAL_3]] to %[[VAL_0:.*]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
194+
!CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[ARG_0:.*]], __address : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>) -> !fir.ref<i64>
195+
!CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref<i64>
196+
!CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> !fir.ptr<!fir.array<?x?xf32>>
197+
!CHECK: %[[C_0:.*]]_0 = arith.constant 0 : index
198+
!CHECK: %[[VAL_7:.*]] = fir.coordinate_of %[[ARG_2:.*]], %[[C_0]]_0 : (!fir.ref<!fir.array<?xi32>>, index) -> !fir.ref<i32>
199+
!CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_7]] : !fir.ref<i32>
200+
!CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i32) -> index
201+
!CHECK: %[[C_1:.*]] = arith.constant 1 : index
202+
!CHECK: %[[VAL_10:.*]] = fir.coordinate_of %[[ARG_2]], %[[C_1]] : (!fir.ref<!fir.array<?xi32>>, index) -> !fir.ref<i32>
203+
!CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_10]] : !fir.ref<i32>
204+
!CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i32) -> index
205+
!CHECK: %[[C_0:.*]]_1 = arith.constant 0 : index
206+
!CHECK: %[[VAL_13:.*]] = fir.coordinate_of %[[ARG_3:.*]], %[[C_0]]_1 : (!fir.ref<!fir.array<?xi32>>, index) -> !fir.ref<i32>
207+
!CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_13]] : !fir.ref<i32>
208+
!CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i32) -> index
209+
!CHECK: %[[C_1:.*]]_2 = arith.constant 1 : index
210+
!CHECK: %[[VAL_16:.*]] = fir.coordinate_of %[[ARG_3]], %[[C_1]]_2 : (!fir.ref<!fir.array<?xi32>>, index) -> !fir.ref<i32>
211+
!CHECK: %[[VAL_17:.*]] = fir.load %[[VAL_16]] : !fir.ref<i32>
212+
!CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_17]] : (i32) -> index
213+
!CHECK: %[[VAL_19:.*]] = fir.shape_shift %[[VAL_15]], %[[VAL_9]], %[[VAL_18]], %[[VAL_12]] : (index, index, index, index) -> !fir.shapeshift<2>
214+
!CHECK: %[[VAL_20:.*]] = fir.embox %[[VAL_6]](%[[VAL_19]]) : (!fir.ptr<!fir.array<?x?xf32>>, !fir.shapeshift<2>)
215+
!CHECK: fir.store %[[VAL_20]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
216+
call c_f_pointer(cptr, fptr, shape, lower)
217+
end subroutine dynamic_shape_lower_2

‎flang/test/Semantics/c_f_pointer.f90

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -54,4 +54,12 @@ program test
5454
call c_f_pointer(scalarC, c2ptr)
5555
!WARNING: FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type or kind CHARACTER(KIND=4,LEN=1_8) [-Winteroperability]
5656
call c_f_pointer(scalarC, unicodePtr)
57+
58+
!ERROR: SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar
59+
!ERROR: LOWER= argument to C_F_POINTER() may not appear when FPTR= is scalar
60+
call c_f_pointer(scalarC, scalarIntF, [1_8], [0_8])
61+
!ERROR: LOWER= argument to C_F_POINTER() must be a rank-one array.
62+
call c_f_pointer(scalarC, arrayIntF, shape=[1_8], lower=rankTwoArray)
63+
!ERROR: SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array
64+
call c_f_pointer(scalarC, arrayIntF, lower=[0])
5765
end program

0 commit comments

Comments
 (0)