/// Return how argument \p argName should be lowered given the rules for the
/// intrinsic function. The argument names are the one defined by the standard.
-ArgLoweringRule lowerIntrinsicArgumentAs(mlir::Location,
- const IntrinsicArgumentLoweringRules &,
- llvm::StringRef argName);
+ArgLoweringRule lowerIntrinsicArgumentAs(const IntrinsicArgumentLoweringRules &,
+ unsigned position);
/// Return place-holder for absent intrinsic arguments.
fir::ExtendedValue getAbsentIntrinsicArgument();
return obj.GetLastSymbol().GetUltimate();
}
+static bool
+isIntrinsicModuleProcRef(const Fortran::evaluate::ProcedureRef &procRef) {
+ const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
+ if (!symbol)
+ return false;
+ const Fortran::semantics::Symbol *module =
+ symbol->GetUltimate().owner().GetSymbol();
+ return module && module->attrs().test(Fortran::semantics::Attr::INTRINSIC);
+}
+
namespace {
/// Lowering of Fortran::evaluate::Expr<T> expressions
fir::factory::getNonDeferredLengthParams(exv));
}
- /// Generate a call to an intrinsic function.
- ExtValue
- genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef,
- const Fortran::evaluate::SpecificIntrinsic &intrinsic,
- llvm::Optional<mlir::Type> resultType) {
+ /// Generate a call to a Fortran intrinsic or intrinsic module procedure.
+ ExtValue genIntrinsicRef(
+ const Fortran::evaluate::ProcedureRef &procRef,
+ llvm::Optional<mlir::Type> resultType,
+ llvm::Optional<const Fortran::evaluate::SpecificIntrinsic> intrinsic =
+ llvm::None) {
llvm::SmallVector<ExtValue> operands;
- llvm::StringRef name = intrinsic.name;
+ std::string name =
+ intrinsic ? intrinsic->name
+ : procRef.proc().GetSymbol()->GetUltimate().name().ToString();
mlir::Location loc = getLoc();
- if (Fortran::lower::intrinsicRequiresCustomOptionalHandling(
- procRef, intrinsic, converter)) {
+ if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
+ procRef, *intrinsic, converter)) {
using ExvAndPresence = std::pair<ExtValue, llvm::Optional<mlir::Value>>;
llvm::SmallVector<ExvAndPresence, 4> operands;
auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
operands.emplace_back(genval(expr), llvm::None);
};
Fortran::lower::prepareCustomIntrinsicArgument(
- procRef, intrinsic, resultType, prepareOptionalArg, prepareOtherArg,
+ procRef, *intrinsic, resultType, prepareOptionalArg, prepareOtherArg,
converter);
auto getArgument = [&](std::size_t i) -> ExtValue {
const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering =
Fortran::lower::getIntrinsicArgumentLowering(name);
- for (const auto &[arg, dummy] :
- llvm::zip(procRef.arguments(),
- intrinsic.characteristics.value().dummyArguments)) {
- auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg);
+ for (const auto &arg : llvm::enumerate(procRef.arguments())) {
+ auto *expr =
+ Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
if (!expr) {
// Absent optional.
operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument());
}
// Ad-hoc argument lowering handling.
Fortran::lower::ArgLoweringRule argRules =
- Fortran::lower::lowerIntrinsicArgumentAs(loc, *argLowering,
- dummy.name);
+ Fortran::lower::lowerIntrinsicArgumentAs(*argLowering, arg.index());
if (argRules.handleDynamicOptional &&
Fortran::evaluate::MayBePassedAsAbsentOptional(
*expr, converter.getFoldingContext())) {
operands, stmtCtx);
}
- template <typename A>
- bool isCharacterType(const A &exp) {
- if (auto type = exp.GetType())
- return type->category() == Fortran::common::TypeCategory::Character;
- return false;
- }
-
/// helper to detect statement functions
static bool
isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) {
return details->stmtFunction().has_value();
return false;
}
+
/// Generate Statement function calls
ExtValue genStmtFunctionRef(const Fortran::evaluate::ProcedureRef &procRef) {
const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
Fortran::lower::getAdaptToByRefAttr(builder)});
}
+ template <typename A>
+ bool isCharacterType(const A &exp) {
+ if (auto type = exp.GetType())
+ return type->category() == Fortran::common::TypeCategory::Character;
+ return false;
+ }
+
/// Lower an actual argument that must be passed via an address.
/// This generates of the copy-in/copy-out if the actual is not contiguous, or
/// the creation of the temp if the actual is a variable and \p byValue is
if (isElementalProcWithArrayArgs(procRef))
fir::emitFatalError(loc, "trying to lower elemental procedure with array "
"arguments as normal procedure");
+
if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
procRef.proc().GetSpecificIntrinsic())
- return genIntrinsicRef(procRef, *intrinsic, resultType);
+ return genIntrinsicRef(procRef, resultType, *intrinsic);
+
+ if (isIntrinsicModuleProcRef(procRef))
+ return genIntrinsicRef(procRef, resultType);
if (isStatementFunctionCall(procRef))
return genStmtFunctionRef(procRef);
return genarr(x);
}
- // A procedure reference to a Fortran elemental intrinsic procedure.
+ // A reference to a Fortran elemental intrinsic or intrinsic module procedure.
CC genElementalIntrinsicProcRef(
const Fortran::evaluate::ProcedureRef &procRef,
llvm::Optional<mlir::Type> retTy,
- const Fortran::evaluate::SpecificIntrinsic &intrinsic) {
+ llvm::Optional<const Fortran::evaluate::SpecificIntrinsic> intrinsic =
+ llvm::None) {
+
llvm::SmallVector<CC> operands;
- llvm::StringRef name = intrinsic.name;
+ std::string name =
+ intrinsic ? intrinsic->name
+ : procRef.proc().GetSymbol()->GetUltimate().name().ToString();
const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering =
Fortran::lower::getIntrinsicArgumentLowering(name);
mlir::Location loc = getLoc();
- if (Fortran::lower::intrinsicRequiresCustomOptionalHandling(
- procRef, intrinsic, converter)) {
+ if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
+ procRef, *intrinsic, converter)) {
using CcPairT = std::pair<CC, llvm::Optional<mlir::Value>>;
llvm::SmallVector<CcPairT> operands;
auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
operands.emplace_back(genElementalArgument(expr), llvm::None);
};
Fortran::lower::prepareCustomIntrinsicArgument(
- procRef, intrinsic, retTy, prepareOptionalArg, prepareOtherArg,
+ procRef, *intrinsic, retTy, prepareOptionalArg, prepareOtherArg,
converter);
fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
- llvm::StringRef name = intrinsic.name;
return [=](IterSpace iters) -> ExtValue {
auto getArgument = [&](std::size_t i) -> ExtValue {
return operands[i].first(iters);
};
}
/// Otherwise, pre-lower arguments and use intrinsic lowering utility.
- for (const auto &[arg, dummy] :
- llvm::zip(procRef.arguments(),
- intrinsic.characteristics.value().dummyArguments)) {
+ for (const auto &arg : llvm::enumerate(procRef.arguments())) {
const auto *expr =
- Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg);
+ Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
if (!expr) {
// Absent optional.
operands.emplace_back([=](IterSpace) { return mlir::Value{}; });
} else {
// Ad-hoc argument lowering handling.
Fortran::lower::ArgLoweringRule argRules =
- Fortran::lower::lowerIntrinsicArgumentAs(getLoc(), *argLowering,
- dummy.name);
+ Fortran::lower::lowerIntrinsicArgumentAs(*argLowering, arg.index());
if (argRules.handleDynamicOptional &&
Fortran::evaluate::MayBePassedAsAbsentOptional(
*expr, converter.getFoldingContext())) {
// The intrinsic procedure is called once per element of the array.
return genElementalIntrinsicProcRef(procRef, retTy, *intrin);
}
+ if (isIntrinsicModuleProcRef(procRef))
+ return genElementalIntrinsicProcRef(procRef, retTy);
if (ScalarExprLowering::isStatementFunctionCall(procRef))
fir::emitFatalError(loc, "statement function cannot be elemental");
// Elide any implicit loop iters.
return [=, &procRef](IterSpace) {
return ScalarExprLowering{loc, converter, symMap, stmtCtx}
- .genIntrinsicRef(procRef, *intrinsic, retTy);
+ .genIntrinsicRef(procRef, retTy, *intrinsic);
};
}
return genarr(
ScalarExprLowering{loc, converter, symMap, stmtCtx}.genIntrinsicRef(
- procRef, *intrinsic, retTy));
+ procRef, retTy, *intrinsic));
}
if (explicitSpaceIsActive() && procRef.Rank() == 0) {
#define PGMATH_DECLARE
#include "flang/Evaluate/pgmath.h.inc"
-/// This file implements lowering of Fortran intrinsic procedures.
-/// Intrinsics are lowered to a mix of FIR and MLIR operations as
-/// well as call to runtime functions or LLVM intrinsics.
+/// This file implements lowering of Fortran intrinsic procedures and Fortran
+/// intrinsic module procedures. A call may be inlined with a mix of FIR and
+/// MLIR operations, or as a call to a runtime function or LLVM intrinsic.
/// Lowering of intrinsic procedure calls is based on a map that associates
/// Fortran intrinsic generic names to FIR generator functions.
mlir::Value genIbits(mlir::Type, llvm::ArrayRef<mlir::Value>);
mlir::Value genIbset(mlir::Type, llvm::ArrayRef<mlir::Value>);
fir::ExtendedValue genIchar(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+ mlir::Value genIeeeIsFinite(mlir::Type, llvm::ArrayRef<mlir::Value>);
+ template <mlir::arith::CmpIPredicate pred>
+ fir::ExtendedValue genIeeeTypeCompare(mlir::Type,
+ llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genIeor(mlir::Type, llvm::ArrayRef<mlir::Value>);
fir::ExtendedValue genIndex(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genIor(mlir::Type, llvm::ArrayRef<mlir::Value>);
{"ibits", &I::genIbits},
{"ibset", &I::genIbset},
{"ichar", &I::genIchar},
+ {"ieee_class_eq", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::eq>},
+ {"ieee_class_ne", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::ne>},
+ {"ieee_is_finite", &I::genIeeeIsFinite},
+ {"ieee_round_eq", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::eq>},
+ {"ieee_round_ne", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::ne>},
{"ieor", &I::genIeor},
{"index",
&I::genIndex,
// IntrinsicLibrary
//===----------------------------------------------------------------------===//
-/// Emit a TODO error message for as yet unimplemented intrinsics.
-static void crashOnMissingIntrinsic(mlir::Location loc, llvm::StringRef name) {
- TODO(loc, "missing intrinsic lowering: " + llvm::Twine(name));
+static bool isIntrinsicModuleProcedure(llvm::StringRef name) {
+ return name.startswith("c_") || name.startswith("compiler_") ||
+ name.startswith("ieee_");
+}
+
+/// Return the generic name of an intrinsic module procedure specific name.
+/// Remove any "__builtin_" prefix, and any specific suffix of the form
+/// {_[ail]?[0-9]+}*, such as _1 or _a4.
+llvm::StringRef genericName(llvm::StringRef specificName) {
+ const std::string builtin = "__builtin_";
+ llvm::StringRef name = specificName.startswith(builtin)
+ ? specificName.drop_front(builtin.size())
+ : specificName;
+ size_t size = name.size();
+ if (isIntrinsicModuleProcedure(name))
+ while (isdigit(name[size - 1]))
+ while (name[--size] != '_')
+ ;
+ return name.drop_back(name.size() - size);
+}
+
+/// Generate a TODO error message for an as yet unimplemented intrinsic.
+void crashOnMissingIntrinsic(mlir::Location loc, llvm::StringRef name) {
+ if (isIntrinsicModuleProcedure(name))
+ TODO(loc, "intrinsic module procedure: " + llvm::Twine(name));
+ else
+ TODO(loc, "intrinsic: " + llvm::Twine(name));
}
template <typename GeneratorType>
}
fir::ExtendedValue
-IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name,
+IntrinsicLibrary::genIntrinsicCall(llvm::StringRef specificName,
llvm::Optional<mlir::Type> resultType,
llvm::ArrayRef<fir::ExtendedValue> args) {
+ llvm::StringRef name = genericName(specificName);
if (const IntrinsicHandler *handler = findIntrinsicHandler(name)) {
bool outline = handler->outline || outlineAllIntrinsics;
return std::visit(
mlir::func::FuncOp funcOp =
getRuntimeFunction(loc, builder, name, soughtFuncType);
if (!funcOp) {
- std::string buffer("not yet implemented: missing intrinsic lowering: ");
- llvm::raw_string_ostream sstream(buffer);
- sstream << name << "\nrequested type was: " << soughtFuncType << '\n';
- fir::emitFatalError(loc, buffer);
+ std::string nameAndType;
+ llvm::raw_string_ostream sstream(nameAndType);
+ sstream << name << "\nrequested type: " << soughtFuncType;
+ crashOnMissingIntrinsic(loc, nameAndType);
}
mlir::FunctionType actualFuncType = funcOp.getFunctionType();
return builder.create<mlir::arith::ExtUIOp>(loc, resultType, code);
}
+// IEEE_CLASS_TYPE OPERATOR(==), OPERATOR(/=)
+// IEEE_ROUND_TYPE OPERATOR(==), OPERATOR(/=)
+template <mlir::arith::CmpIPredicate pred>
+fir::ExtendedValue
+IntrinsicLibrary::genIeeeTypeCompare(mlir::Type resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ assert(args.size() == 2);
+ mlir::Value arg0 = fir::getBase(args[0]);
+ mlir::Value arg1 = fir::getBase(args[1]);
+ auto recType =
+ fir::unwrapPassByRefType(arg0.getType()).dyn_cast<fir::RecordType>();
+ assert(recType.getTypeList().size() == 1 && "expected exactly one component");
+ auto [fieldName, fieldType] = recType.getTypeList().front();
+ mlir::Type fieldIndexType = fir::FieldType::get(recType.getContext());
+ mlir::Value field = builder.create<fir::FieldIndexOp>(
+ loc, fieldIndexType, fieldName, recType, fir::getTypeParams(arg0));
+ mlir::Value left = builder.create<fir::LoadOp>(
+ loc, fieldType,
+ builder.create<fir::CoordinateOp>(loc, builder.getRefType(fieldType),
+ arg0, field));
+ mlir::Value right = builder.create<fir::LoadOp>(
+ loc, fieldType,
+ builder.create<fir::CoordinateOp>(loc, builder.getRefType(fieldType),
+ arg1, field));
+ return builder.create<mlir::arith::CmpIOp>(loc, pred, left, right);
+}
+
+// IEEE_IS_FINITE
+mlir::Value
+IntrinsicLibrary::genIeeeIsFinite(mlir::Type resultType,
+ llvm::ArrayRef<mlir::Value> args) {
+ // IEEE_IS_FINITE(X) is true iff exponent(X) is the max exponent of kind(X).
+ assert(args.size() == 1);
+ mlir::Value floatVal = fir::getBase(args[0]);
+ mlir::FloatType floatType = floatVal.getType().dyn_cast<mlir::FloatType>();
+ int floatBits = floatType.getWidth();
+ mlir::Type intType = builder.getIntegerType(
+ floatType.isa<mlir::Float80Type>() ? 128 : floatBits);
+ mlir::Value intVal =
+ builder.create<mlir::arith::BitcastOp>(loc, intType, floatVal);
+ int significandBits;
+ if (floatType.isa<mlir::Float32Type>())
+ significandBits = 23;
+ else if (floatType.isa<mlir::Float64Type>())
+ significandBits = 52;
+ else // problems elsewhere for other kinds
+ TODO(loc, "intrinsic module procedure: ieee_is_finite");
+ mlir::Value significand =
+ builder.createIntegerConstant(loc, intType, significandBits);
+ int exponentBits = floatBits - 1 - significandBits;
+ mlir::Value maxExponent =
+ builder.createIntegerConstant(loc, intType, (1 << exponentBits) - 1);
+ mlir::Value exponent = genIbits(
+ intType, {intVal, significand,
+ builder.createIntegerConstant(loc, intType, exponentBits)});
+ return builder.createConvert(
+ loc, resultType,
+ builder.create<mlir::arith::CmpIOp>(loc, mlir::arith::CmpIPredicate::ne,
+ exponent, maxExponent));
+}
+
// IEOR
mlir::Value IntrinsicLibrary::genIeor(mlir::Type resultType,
llvm::ArrayRef<mlir::Value> args) {
// LGE, LGT, LLE, LLT
template <mlir::arith::CmpIPredicate pred>
fir::ExtendedValue
-IntrinsicLibrary::genCharacterCompare(mlir::Type type,
+IntrinsicLibrary::genCharacterCompare(mlir::Type resultType,
llvm::ArrayRef<fir::ExtendedValue> args) {
assert(args.size() == 2);
return fir::runtime::genCharCompare(
/// Return how argument \p argName should be lowered given the rules for the
/// intrinsic function.
Fortran::lower::ArgLoweringRule Fortran::lower::lowerIntrinsicArgumentAs(
- mlir::Location loc, const IntrinsicArgumentLoweringRules &rules,
- llvm::StringRef argName) {
- for (const IntrinsicDummyArgument &arg : rules.args) {
- if (arg.name && arg.name == argName)
- return {arg.lowerAs, arg.handleDynamicOptional};
- }
- fir::emitFatalError(
- loc, "internal: unknown intrinsic argument name in lowering '" + argName +
- "'");
+ const IntrinsicArgumentLoweringRules &rules, unsigned position) {
+ assert(position < sizeof(rules.args) / sizeof(decltype(*rules.args)) &&
+ "invalid argument");
+ return {rules.args[position].lowerAs,
+ rules.args[position].handleDynamicOptional};
}
//===----------------------------------------------------------------------===//
end interface
#define IEEE_SUPPORT_FLAG_R(XKIND) \
- pure logical function ieee_support_flag_a##XKIND(flag, x); \
+ logical function ieee_support_flag_a##XKIND(flag, x); \
import ieee_flag_type; \
type(ieee_flag_type), intent(in) :: flag; \
real(XKIND), intent(in) :: x(..); \
end function ieee_support_flag_a##XKIND;
interface ieee_support_flag
- pure logical function ieee_support_flag(flag)
+ logical function ieee_support_flag(flag)
import ieee_flag_type
type(ieee_flag_type), intent(in) :: flag
end function ieee_support_flag
real(XKIND), intent(in) :: x(..); \
end function ieee_support_rounding_a##XKIND;
interface ieee_support_rounding
- pure logical function ieee_support_rounding(round_value)
+ logical function ieee_support_rounding(round_value)
import ieee_round_type
type(ieee_round_type), intent(in) :: round_value
end function ieee_support_rounding
--- /dev/null
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: @_QPis_finite_test
+subroutine is_finite_test(x, y)
+ use ieee_arithmetic, only: ieee_is_finite
+ real(4) x
+ real(8) y
+ ! CHECK: %[[V_3:[0-9]+]] = fir.load %arg0 : !fir.ref<f32>
+ ! CHECK: %[[V_4:[0-9]+]] = arith.bitcast %[[V_3]] : f32 to i32
+ ! CHECK: %[[V_5:[0-9]+]] = arith.subi %c32{{.*}}, %c8{{.*}} : i32
+ ! CHECK: %[[V_6:[0-9]+]] = arith.shrui %c-1{{.*}}, %[[V_5]] : i32
+ ! CHECK: %[[V_7:[0-9]+]] = arith.shrsi %[[V_4]], %c23{{.*}} : i32
+ ! CHECK: %[[V_8:[0-9]+]] = arith.andi %[[V_7]], %[[V_6]] : i32
+ ! CHECK: %[[V_9:[0-9]+]] = arith.cmpi eq, %c8{{.*}}, %c0{{.*}} : i32
+ ! CHECK: %[[V_10:[0-9]+]] = arith.select %[[V_9]], %c0{{.*}}, %[[V_8]] : i32
+ ! CHECK: %[[V_11:[0-9]+]] = arith.cmpi ne, %[[V_10]], %c255{{.*}} : i32
+ ! CHECK: %[[V_12:[0-9]+]] = fir.convert %[[V_11]] : (i1) -> !fir.logical<4>
+ ! CHECK: %[[V_13:[0-9]+]] = fir.convert %[[V_12]] : (!fir.logical<4>) -> i1
+ print*, ieee_is_finite(x)
+
+ ! CHECK: %[[V_19:[0-9]+]] = fir.load %arg0 : !fir.ref<f32>
+ ! CHECK: %[[V_20:[0-9]+]] = fir.load %arg0 : !fir.ref<f32>
+ ! CHECK: %[[V_21:[0-9]+]] = arith.addf %[[V_19]], %[[V_20]] : f32
+ ! CHECK: %[[V_22:[0-9]+]] = arith.bitcast %[[V_21]] : f32 to i32
+ ! CHECK: %[[V_23:[0-9]+]] = arith.subi %c32{{.*}}, %c8{{.*}} : i32
+ ! CHECK: %[[V_24:[0-9]+]] = arith.shrui %c-1{{.*}}, %[[V_23]] : i32
+ ! CHECK: %[[V_25:[0-9]+]] = arith.shrsi %[[V_22]], %c23{{.*}} : i32
+ ! CHECK: %[[V_26:[0-9]+]] = arith.andi %[[V_25]], %[[V_24]] : i32
+ ! CHECK: %[[V_27:[0-9]+]] = arith.cmpi eq, %c8{{.*}}, %c0{{.*}} : i32
+ ! CHECK: %[[V_28:[0-9]+]] = arith.select %[[V_27]], %c0{{.*}}, %[[V_26]] : i32
+ ! CHECK: %[[V_29:[0-9]+]] = arith.cmpi ne, %[[V_28]], %c255{{.*}} : i32
+ ! CHECK: %[[V_30:[0-9]+]] = fir.convert %[[V_29]] : (i1) -> !fir.logical<4>
+ ! CHECK: %[[V_31:[0-9]+]] = fir.convert %[[V_30]] : (!fir.logical<4>) -> i1
+ print*, ieee_is_finite(x+x)
+
+ ! CHECK: %[[V_37:[0-9]+]] = fir.load %arg1 : !fir.ref<f64>
+ ! CHECK: %[[V_38:[0-9]+]] = arith.bitcast %[[V_37]] : f64 to i64
+ ! CHECK: %[[V_39:[0-9]+]] = arith.subi %c64{{.*}}, %c11{{.*}} : i64
+ ! CHECK: %[[V_40:[0-9]+]] = arith.shrui %c-1{{.*}}, %[[V_39]] : i64
+ ! CHECK: %[[V_41:[0-9]+]] = arith.shrsi %[[V_38]], %c52{{.*}} : i64
+ ! CHECK: %[[V_42:[0-9]+]] = arith.andi %[[V_41]], %[[V_40]] : i64
+ ! CHECK: %[[V_43:[0-9]+]] = arith.cmpi eq, %c11{{.*}}, %c0{{.*}} : i64
+ ! CHECK: %[[V_44:[0-9]+]] = arith.select %[[V_43]], %c0{{.*}}, %[[V_42]] : i64
+ ! CHECK: %[[V_45:[0-9]+]] = arith.cmpi ne, %[[V_44]], %c2047{{.*}} : i64
+ ! CHECK: %[[V_46:[0-9]+]] = fir.convert %[[V_45]] : (i1) -> !fir.logical<4>
+ ! CHECK: %[[V_47:[0-9]+]] = fir.convert %[[V_46]] : (!fir.logical<4>) -> i1
+ print*, ieee_is_finite(y)
+
+ ! CHECK: %[[V_53:[0-9]+]] = fir.load %arg1 : !fir.ref<f64>
+ ! CHECK: %[[V_54:[0-9]+]] = fir.load %arg1 : !fir.ref<f64>
+ ! CHECK: %[[V_55:[0-9]+]] = arith.addf %[[V_53]], %[[V_54]] : f64
+ ! CHECK: %[[V_56:[0-9]+]] = arith.bitcast %[[V_55]] : f64 to i64
+ ! CHECK: %[[V_57:[0-9]+]] = arith.subi %c64{{.*}}, %c11{{.*}} : i64
+ ! CHECK: %[[V_58:[0-9]+]] = arith.shrui %c-1{{.*}}, %[[V_57]] : i64
+ ! CHECK: %[[V_59:[0-9]+]] = arith.shrsi %[[V_56]], %c52{{.*}} : i64
+ ! CHECK: %[[V_60:[0-9]+]] = arith.andi %[[V_59]], %[[V_58]] : i64
+ ! CHECK: %[[V_61:[0-9]+]] = arith.cmpi eq, %c11{{.*}}, %c0{{.*}} : i64
+ ! CHECK: %[[V_62:[0-9]+]] = arith.select %[[V_61]], %c0{{.*}}, %[[V_60]] : i64
+ ! CHECK: %[[V_63:[0-9]+]] = arith.cmpi ne, %[[V_62]], %c2047{{.*}} : i64
+ ! CHECK: %[[V_64:[0-9]+]] = fir.convert %[[V_63]] : (i1) -> !fir.logical<4>
+ ! CHECK: %[[V_65:[0-9]+]] = fir.convert %[[V_64]] : (!fir.logical<4>) -> i1
+ print*, ieee_is_finite(y+y)
+end subroutine is_finite_test
+
+ real(4) x
+ real(8) y
+ call is_finite_test(huge(x), huge(y))
+end
--- /dev/null
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: @_QPs
+subroutine s(r1,r2)
+ use ieee_arithmetic, only: ieee_round_type, operator(==)
+ type(ieee_round_type) :: r1, r2
+ ! CHECK: %[[V_3:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_4:[0-9]+]] = fir.coordinate_of %arg0, %[[V_3]] : (!fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>, !fir.field) -> !fir.ref<i8>
+ ! CHECK: %[[V_5:[0-9]+]] = fir.load %[[V_4]] : !fir.ref<i8>
+ ! CHECK: %[[V_6:[0-9]+]] = fir.coordinate_of %arg1, %[[V_3]] : (!fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>, !fir.field) -> !fir.ref<i8>
+ ! CHECK: %[[V_7:[0-9]+]] = fir.load %[[V_6]] : !fir.ref<i8>
+ ! CHECK: %[[V_8:[0-9]+]] = arith.cmpi eq, %[[V_5]], %[[V_7]] : i8
+ ! CHECK: %[[V_9:[0-9]+]] = fir.call @_FortranAioOutputLogical(%{{.*}}, %[[V_8]]) : (!fir.ref<i8>, i1) -> i1
+ print*, r1 == r2
+end
+
+! CHECK-LABEL: @_QQmain
+ use ieee_arithmetic, only: ieee_round_type, ieee_nearest, ieee_to_zero
+ interface
+ subroutine s(r1,r2)
+ import ieee_round_type
+ type(ieee_round_type) :: r1, r2
+ end
+ end interface
+ ! CHECK: %[[V_0:[0-9]+]] = fir.alloca !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_1:[0-9]+]] = fir.alloca !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_2:[0-9]+]] = fir.alloca !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_3:[0-9]+]] = fir.alloca !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_4:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_5:[0-9]+]] = fir.coordinate_of %[[V_3]], %[[V_4]] : (!fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>, !fir.field) -> !fir.ref<i8>
+ ! CHECK: fir.store %c2{{.*}} to %[[V_5]] : !fir.ref<i8>
+ ! CHECK: %[[V_6:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_7:[0-9]+]] = fir.coordinate_of %[[V_2]], %[[V_6]] : (!fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>, !fir.field) -> !fir.ref<i8>
+ ! CHECK: fir.store %c1{{.*}} to %[[V_7]] : !fir.ref<i8>
+ call s(ieee_to_zero, ieee_nearest)
+
+ ! CHECK: fir.call @_QPs(%[[V_3]], %[[V_2]]) : (!fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>, !fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>) -> ()
+ ! CHECK: %[[V_8:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_9:[0-9]+]] = fir.coordinate_of %[[V_1]], %[[V_8]] : (!fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>, !fir.field) -> !fir.ref<i8>
+ ! CHECK: fir.store %c1{{.*}} to %[[V_9]] : !fir.ref<i8>
+ ! CHECK: %[[V_10:[0-9]+]] = fir.field_index mode, !fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>
+ ! CHECK: %[[V_11:[0-9]+]] = fir.coordinate_of %[[V_0]], %[[V_10]] : (!fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>, !fir.field) -> !fir.ref<i8>
+ ! CHECK: fir.store %c1{{.*}} to %[[V_11]] : !fir.ref<i8>
+ ! CHECK: fir.call @_QPs(%[[V_1]], %[[V_0]]) : (!fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>, !fir.ref<!fir.type<_QMieee_arithmeticTieee_round_type{mode:i8}>>) -> ()
+ call s(ieee_nearest, ieee_nearest)
+end