} else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
intrinsic->name == "ubound") {
+ // These are the array-valued cases for LBOUND and UBOUND (no DIM=).
const auto *expr{call.arguments().front().value().UnwrapExpr()};
CHECK(expr != nullptr);
return Shape{MaybeExtentExpr{ExtentExpr{expr->Rank()}}};
}
}
}
+ } else if (intrinsic->name == "cshift" || intrinsic->name == "eoshift") {
+ if (!call.arguments().empty()) {
+ return (*this)(call.arguments()[0]);
+ }
+ } else if (intrinsic->name == "spread") {
+ // SHAPE(SPREAD(ARRAY,DIM,NCOPIES)) = SHAPE(ARRAY) with NCOPIES inserted
+ // at position DIM.
+ if (call.arguments().size() == 3) {
+ auto arrayShape{
+ (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
+ const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
+ const auto *nCopies{
+ UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))};
+ if (arrayShape.has_value() && dimArg != nullptr && nCopies != nullptr) {
+ if (auto dim{ToInt64(*dimArg)}) {
+ if (*dim >= 1 &&
+ static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {
+ arrayShape->emplace(arrayShape->begin() + *dim - 1,
+ ConvertToType<ExtentType>(common::Clone(*nCopies)));
+ return std::move(*arrayShape);
+ }
+ }
+ }
+ }
} else if (intrinsic->characteristics.value().attrs.test(characteristics::
Procedure::Attr::NullPointer)) { // NULL(MOLD=)
return (*this)(call.arguments());
ieee_support_flag_4, ieee_support_flag_8, ieee_support_flag_10, &
ieee_support_flag_16
interface ieee_support_flag
- module procedure :: ieee_support_flag_2, ieee_support_flag_3, &
+ module procedure :: ieee_support_flag, &
+ ieee_support_flag_2, ieee_support_flag_3, &
ieee_support_flag_4, ieee_support_flag_8, ieee_support_flag_10, &
ieee_support_flag_16
end interface
type(ieee_status_type), intent(in) :: status
end subroutine ieee_set_status
+ pure logical function ieee_support_flag(flag)
+ type(ieee_flag_type), intent(in) :: flag
+ ieee_support_flag = .true.
+ end function
pure logical function ieee_support_flag_2(flag, x)
type(ieee_flag_type), intent(in) :: flag
real(kind=2), intent(in) :: x(..)