mlir::Value genSameTypeAs(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value a, mlir::Value b);
+mlir::Value genExtendsTypeOf(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value a, mlir::Value b);
+
} // namespace fir::runtime
#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H
// Perform the test of the SAME_TYPE_AS intrinsic.
bool RTNAME(SameTypeAs)(const Descriptor &, const Descriptor &);
+// Perform the test of the EXTENDS_TYPE_OF intrinsic.
+bool RTNAME(ExtendsTypeOf)(const Descriptor &, const Descriptor &);
+
} // extern "C"
} // namespace Fortran::runtime
#endif // FORTRAN_RUNTIME_DERIVED_API_H_
fir::ExtendedValue genEoshift(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
void genExit(llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genExponent(mlir::Type, llvm::ArrayRef<mlir::Value>);
+ fir::ExtendedValue genExtendsTypeOf(mlir::Type,
+ llvm::ArrayRef<fir::ExtendedValue>);
template <Extremum, ExtremumBehavior>
mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>);
mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
{{{"status", asValue, handleDynamicOptional}}},
/*isElemental=*/false},
{"exponent", &I::genExponent},
+ {"extends_type_of",
+ &I::genExtendsTypeOf,
+ {{{"a", asBox}, {"mold", asBox}}},
+ /*isElemental=*/false},
{"findloc",
&I::genFindloc,
{{{"array", asBox},
fir::getBase(args[0])));
}
+// EXTENDS_TYPE_OF
+fir::ExtendedValue
+IntrinsicLibrary::genExtendsTypeOf(mlir::Type resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ assert(args.size() == 2);
+
+ return builder.createConvert(
+ loc, resultType,
+ fir::runtime::genExtendsTypeOf(builder, loc, fir::getBase(args[0]),
+ fir::getBase(args[1])));
+}
+
// FINDLOC
fir::ExtendedValue
IntrinsicLibrary::genFindloc(mlir::Type resultType,
auto args = fir::runtime::createArguments(builder, loc, fTy, a, b);
return builder.create<fir::CallOp>(loc, sameTypeAsFunc, args).getResult(0);
}
+
+mlir::Value fir::runtime::genExtendsTypeOf(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Value a,
+ mlir::Value mold) {
+ mlir::func::FuncOp extendsTypeOfFunc =
+ fir::runtime::getRuntimeFunc<mkRTKey(ExtendsTypeOf)>(loc, builder);
+ auto fTy = extendsTypeOfFunc.getFunctionType();
+ auto args = fir::runtime::createArguments(builder, loc, fTy, a, mold);
+ return builder.create<fir::CallOp>(loc, extendsTypeOfFunc, args).getResult(0);
+}
return false;
}
+inline bool CompareDerivedType(
+ const typeInfo::DerivedType *a, const typeInfo::DerivedType *b) {
+ return a == b || CompareDerivedTypeNames(a->name(), b->name());
+}
+
static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) {
if (const DescriptorAddendum * addendum{desc.Addendum()}) {
if (const auto *derived{addendum->derivedType()}) {
return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name());
}
+bool RTNAME(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {
+ const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
+ const typeInfo::DerivedType *derivedTypeMold{GetDerivedType(mold)};
+
+ // If MOLD is unlimited polymorphic and is either a disassociated pointer or
+ // unallocated allocatable, the result is true.
+ // Unlimited polymorphic descriptors are initialized with a CFI_type_other
+ // type.
+ if (mold.type().raw() == CFI_type_other &&
+ (mold.IsAllocatable() || mold.IsPointer()) &&
+ derivedTypeMold == nullptr) {
+ return true;
+ }
+
+ // If A is unlimited polymorphic and is either a disassociated pointer or
+ // unallocated allocatable, the result is false.
+ // Unlimited polymorphic descriptors are initialized with a CFI_type_other
+ // type.
+ if (a.type().raw() == CFI_type_other &&
+ (a.IsAllocatable() || a.IsPointer()) && derivedTypeA == nullptr) {
+ return false;
+ }
+
+ if (derivedTypeA == nullptr || derivedTypeMold == nullptr) {
+ return false;
+ }
+
+ // Otherwise if the dynamic type of A or MOLD is extensible, the result is
+ // true if and only if the dynamic type of A is an extension type of the
+ // dynamic type of MOLD.
+ if (CompareDerivedType(derivedTypeA, derivedTypeMold)) {
+ return true;
+ }
+ const typeInfo::DerivedType *parent{derivedTypeA->GetParentType()};
+ while (parent) {
+ if (CompareDerivedType(parent, derivedTypeMold)) {
+ return true;
+ }
+ parent = parent->GetParentType();
+ }
+ return false;
+}
+
// TODO: Assign()
} // extern "C"
--- /dev/null
+! RUN: bbc -emit-fir -polymorphic-type %s -o - | FileCheck %s
+
+module extends_type_of_mod
+
+ type p1
+ integer :: a
+ end type
+
+ type, extends(p1) :: p2
+ integer :: b
+ end type
+
+ type k1(a)
+ integer, kind :: a
+ end type
+
+contains
+ subroutine is_extended_type(a, b)
+ class(*) :: a
+ class(*) :: b
+
+ if (extends_type_of(a, b)) then
+ print*, 'extends_type_of ok'
+ else
+ print*, 'extends_type_of failed'
+ end if
+ end subroutine
+
+! CHECK-LABEL: func.func @_QMextends_type_of_modPis_extended_type(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<none> {fir.bindc_name = "a"}, %[[ARG1:.*]]: !fir.class<none> {fir.bindc_name = "b"}) {
+! CHECK: %[[BOX0:.*]] = fir.convert %[[ARG0]] : (!fir.class<none>) -> !fir.box<none>
+! CHECK: %[[BOX1:.*]] = fir.convert %[[ARG1]] : (!fir.class<none>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAExtendsTypeOf(%[[BOX0]], %[[BOX1]]) {{.*}} : (!fir.box<none>, !fir.box<none>) -> i1
+
+end module
+
+program test
+ use extends_type_of_mod
+ type(p1) :: p, r
+ type(p2) :: q
+ type(k1(10)) :: k10
+ type(k1(20)) :: k20
+
+ call is_extended_type(p, p)
+ call is_extended_type(p, q)
+ call is_extended_type(p, r)
+ call is_extended_type(q, p)
+ call is_extended_type(k10, k20)
+end