Index: flang/include/flang/Optimizer/Builder/FIRBuilder.h =================================================================== --- flang/include/flang/Optimizer/Builder/FIRBuilder.h +++ flang/include/flang/Optimizer/Builder/FIRBuilder.h @@ -560,6 +560,10 @@ mlir::Value genCPtrOrCFunptrAddr(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value cPtr, mlir::Type ty); +/// Get the C address value. +mlir::Value genCPtrOrCFunptrValue(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value cPtr); + } // namespace fir::factory #endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H Index: flang/lib/Lower/IntrinsicCall.cpp =================================================================== --- flang/lib/Lower/IntrinsicCall.cpp +++ flang/lib/Lower/IntrinsicCall.cpp @@ -481,6 +481,10 @@ fir::ExtendedValue genCount(mlir::Type, llvm::ArrayRef); void genCpuTime(llvm::ArrayRef); fir::ExtendedValue genCshift(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genCAssociatedCFunPtr(mlir::Type, + llvm::ArrayRef); + fir::ExtendedValue genCAssociatedCPtr(mlir::Type, + llvm::ArrayRef); void genCFPointer(llvm::ArrayRef); fir::ExtendedValue genCFunLoc(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genCLoc(mlir::Type, llvm::ArrayRef); @@ -731,6 +735,14 @@ {"ble", &I::genBitwiseCompare}, {"blt", &I::genBitwiseCompare}, {"btest", &I::genBtest}, + {"c_associated_c_funptr", + &I::genCAssociatedCFunPtr, + {{{"c_ptr_1", asValue}, {"c_ptr_2", asValue, handleDynamicOptional}}}, + /*isElemental=*/false}, + {"c_associated_c_ptr", + &I::genCAssociatedCPtr, + {{{"c_ptr_1", asValue}, {"c_ptr_2", asValue, handleDynamicOptional}}}, + /*isElemental=*/false}, {"c_f_pointer", &I::genCFPointer, {{{"cptr", asValue}, @@ -2611,16 +2623,50 @@ return res; } +/// C_ASSOCIATED +static fir::ExtendedValue +genCAssociated(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Type resultType, llvm::ArrayRef args) { + assert(args.size() == 2); + mlir::Value cPtr1 = fir::getBase(args[0]); + mlir::Value cPtrVal1 = + fir::factory::genCPtrOrCFunptrValue(builder, loc, cPtr1); + mlir::Value zero = builder.createIntegerConstant(loc, cPtrVal1.getType(), 0); + mlir::Value res = builder.create( + loc, mlir::arith::CmpIPredicate::ne, cPtrVal1, zero); + + if (isStaticallyPresent(args[1])) { + mlir::Value cPtr2 = fir::getBase(args[1]); + mlir::Value cPtrVal2 = + fir::factory::genCPtrOrCFunptrValue(builder, loc, cPtr2); + mlir::Value cmpVal = builder.create( + loc, mlir::arith::CmpIPredicate::eq, cPtrVal1, cPtrVal2); + res = builder.create(loc, res, cmpVal); + } + return builder.createConvert(loc, resultType, res); +} + +/// C_ASSOCIATED (C_FUNPTR [, C_FUNPTR]) +fir::ExtendedValue IntrinsicLibrary::genCAssociatedCFunPtr( + mlir::Type resultType, llvm::ArrayRef args) { + return genCAssociated(builder, loc, resultType, args); +} + +/// C_ASSOCIATED (C_PTR [, C_PTR]) +fir::ExtendedValue +IntrinsicLibrary::genCAssociatedCPtr(mlir::Type resultType, + llvm::ArrayRef args) { + return genCAssociated(builder, loc, resultType, args); +} + // C_F_POINTER void IntrinsicLibrary::genCFPointer(llvm::ArrayRef args) { assert(args.size() == 3); // Handle CPTR argument // Get the value of the C address or the result of a reference to C_LOC. mlir::Value cPtr = fir::getBase(args[0]); - mlir::Type cPtrTy = fir::unwrapRefType(cPtr.getType()); - mlir::Value cPtrAddr = - fir::factory::genCPtrOrCFunptrAddr(builder, loc, cPtr, cPtrTy); - mlir::Value cPtrAddrVal = builder.create(loc, cPtrAddr); + mlir::Value cPtrAddrVal = + fir::factory::genCPtrOrCFunptrValue(builder, loc, cPtr); // Handle FPTR argument const auto *fPtr = args[1].getBoxOf(); Index: flang/lib/Optimizer/Builder/FIRBuilder.cpp =================================================================== --- flang/lib/Optimizer/Builder/FIRBuilder.cpp +++ flang/lib/Optimizer/Builder/FIRBuilder.cpp @@ -1317,3 +1317,12 @@ return builder.create(loc, builder.getRefType(fieldTy), cPtr, field); } + +mlir::Value fir::factory::genCPtrOrCFunptrValue(fir::FirOpBuilder &builder, + mlir::Location loc, + mlir::Value cPtr) { + mlir::Type cPtrTy = fir::unwrapRefType(cPtr.getType()); + mlir::Value cPtrAddr = + fir::factory::genCPtrOrCFunptrAddr(builder, loc, cPtr, cPtrTy); + return builder.create(loc, cPtrAddr); +} Index: flang/test/Lower/Intrinsics/c_associated.f90 =================================================================== --- /dev/null +++ flang/test/Lower/Intrinsics/c_associated.f90 @@ -0,0 +1,78 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s +! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s + +! Test intrinsic module procedure c_associated + +! CHECK-LABEL: func.func @_QPtest_1( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref> {fir.bindc_name = "cptr1"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "cptr2"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.logical<4> {bindc_name = "z1", uniq_name = "_QFtest_1Ez1"} +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.logical<4> {bindc_name = "z2", uniq_name = "_QFtest_1Ez2"} +! CHECK: %[[VAL_4:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}> +! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_4]] : (!fir.ref>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_7:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_8:.*]] = arith.cmpi ne, %[[VAL_6]], %[[VAL_7]] : i64 +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i1) -> !fir.logical<4> +! CHECK: fir.store %[[VAL_9]] to %[[VAL_2]] : !fir.ref> +! CHECK: %[[VAL_10:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}> +! CHECK: %[[VAL_11:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_10]] : (!fir.ref>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_12:.*]] = fir.load %[[VAL_11]] : !fir.ref +! CHECK: %[[VAL_13:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_14:.*]] = arith.cmpi ne, %[[VAL_12]], %[[VAL_13]] : i64 +! CHECK: %[[VAL_15:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}> +! CHECK: %[[VAL_16:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_15]] : (!fir.ref>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_17:.*]] = fir.load %[[VAL_16]] : !fir.ref +! CHECK: %[[VAL_18:.*]] = arith.cmpi eq, %[[VAL_12]], %[[VAL_17]] : i64 +! CHECK: %[[VAL_19:.*]] = arith.andi %[[VAL_14]], %[[VAL_18]] : i1 +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i1) -> !fir.logical<4> +! CHECK: fir.store %[[VAL_20]] to %[[VAL_3]] : !fir.ref> +! CHECK: return +! CHECK: } + +subroutine test_1(cptr1, cptr2) + use iso_c_binding + type(c_ptr) :: cptr1, cptr2 + logical :: z1, z2 + + z1 = c_associated(cptr1) + + z2 = c_associated(cptr1, cptr2) +end + +! CHECK-LABEL: func.func @_QPtest_2( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref> {fir.bindc_name = "cptr1"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "cptr2"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.logical<4> {bindc_name = "z1", uniq_name = "_QFtest_2Ez1"} +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.logical<4> {bindc_name = "z2", uniq_name = "_QFtest_2Ez2"} +! CHECK: %[[VAL_4:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}> +! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_4]] : (!fir.ref>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_7:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_8:.*]] = arith.cmpi ne, %[[VAL_6]], %[[VAL_7]] : i64 +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i1) -> !fir.logical<4> +! CHECK: fir.store %[[VAL_9]] to %[[VAL_2]] : !fir.ref> +! CHECK: %[[VAL_10:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}> +! CHECK: %[[VAL_11:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_10]] : (!fir.ref>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_12:.*]] = fir.load %[[VAL_11]] : !fir.ref +! CHECK: %[[VAL_13:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_14:.*]] = arith.cmpi ne, %[[VAL_12]], %[[VAL_13]] : i64 +! CHECK: %[[VAL_15:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}> +! CHECK: %[[VAL_16:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_15]] : (!fir.ref>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_17:.*]] = fir.load %[[VAL_16]] : !fir.ref +! CHECK: %[[VAL_18:.*]] = arith.cmpi eq, %[[VAL_12]], %[[VAL_17]] : i64 +! CHECK: %[[VAL_19:.*]] = arith.andi %[[VAL_14]], %[[VAL_18]] : i1 +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i1) -> !fir.logical<4> +! CHECK: fir.store %[[VAL_20]] to %[[VAL_3]] : !fir.ref> +! CHECK: return +! CHECK: } + +subroutine test_2(cptr1, cptr2) + use iso_c_binding + type(c_funptr) :: cptr1, cptr2 + logical :: z1, z2 + + z1 = c_associated(cptr1) + + z2 = c_associated(cptr1, cptr2) +end