[flang-commits] [flang] [flang] Enumeration Type: (PR 4/5) Lowering (PR #193571)
via flang-commits
flang-commits at lists.llvm.org
Thu Oct 1 09:53:51 PDT 2026
https://github.com/kwyatt-ext updated https://github.com/llvm/llvm-project/pull/193571
>From 4e42c01bbb4e19cdbb3a460f6da17d39d94c718e Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 16 Apr 2026 13:45:30 -0500
Subject: [PATCH 01/11] Enumeration Type Lowering: FIR code generation (PR 9)
Maps enumeration types to i32 at the FIR level. Intercepts enumeration
DerivedTypeSpec in ConvertType to produce IntegerType, lowers
enumeration constructors/constants, and generates NEXT/PREVIOUS/HUGE
intrinsic lowering with STAT boundary handling and error termination.
Files from original PR 9 plus PR 7/8 lowering additions (PREVIOUS,
STAT, void-cast fixes).
---
flang/lib/Lower/ConvertConstant.cpp | 38 ++++
flang/lib/Lower/ConvertExprToHLFIR.cpp | 181 ++++++++++++++++++
flang/lib/Lower/ConvertType.cpp | 11 ++
flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 1 +
4 files changed, 231 insertions(+)
diff --git a/flang/lib/Lower/ConvertConstant.cpp b/flang/lib/Lower/ConvertConstant.cpp
index f48dc9931e627..9f6046a2fd8c4 100644
--- a/flang/lib/Lower/ConvertConstant.cpp
+++ b/flang/lib/Lower/ConvertConstant.cpp
@@ -510,12 +510,44 @@ static mlir::Value genStructureComponentInit(
return res;
}
+// Extract __ordinal integer value from an enumeration StructureConstructor.
+// Returns std::nullopt if not an enumeration type or ordinal not found.
+static std::optional<int64_t>
+getEnumerationOrdinal(const Fortran::evaluate::StructureConstructor &ctor) {
+ const auto &derivedSpec = ctor.derivedTypeSpec();
+ // Check the type symbol's DerivedTypeDetails for the enumeration flag,
+ // rather than the DerivedTypeSpec::category(), because some DerivedTypeSpec
+ // copies created during name resolution may not have the
+ // EnumerationType category set.
+ const auto *dtDetails =
+ derivedSpec.typeSymbol()
+ .detailsIf<Fortran::semantics::DerivedTypeDetails>();
+ if (!dtDetails || !dtDetails->isEnumerationType())
+ return std::nullopt;
+ if (const auto *scope = derivedSpec.GetScope()) {
+ auto it = scope->find(Fortran::parser::CharBlock{"__ordinal", 9});
+ if (it != scope->end()) {
+ if (auto val = ctor.Find(it->second.get())) {
+ return Fortran::evaluate::ToInt64(*val);
+ }
+ }
+ }
+ return std::nullopt;
+}
+
// Generate a StructureConstructor inlined (returns raw fir.type<T> value,
// not the address of a global constant).
static mlir::Value genInlinedStructureCtorLitImpl(
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
const Fortran::evaluate::StructureConstructor &ctor, mlir::Type type) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+
+ // Enumeration type: produce an i32 constant from the __ordinal value.
+ if (auto ordinal = getEnumerationOrdinal(ctor)) {
+ mlir::Type i32Ty = mlir::IntegerType::get(builder.getContext(), 32);
+ return builder.createIntegerConstant(loc, i32Ty, *ordinal);
+ }
+
auto recTy = mlir::cast<fir::RecordType>(type);
auto fieldTy = fir::FieldType::get(recTy.getContext());
@@ -809,6 +841,12 @@ fir::ExtendedValue Fortran::lower::ConstantBuilder<T>::gen(
loc, builder.getCharacterLengthType(), constant.LEN());
return fir::CharBoxValue{value, len};
} else if constexpr (T::category == Fortran::common::TypeCategory::Derived) {
+ // Enumeration types: produce i32 constant directly.
+ if (auto ordinal = getEnumerationOrdinal(*opt)) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Type i32Ty = mlir::IntegerType::get(builder.getContext(), 32);
+ return builder.createIntegerConstant(loc, i32Ty, *ordinal);
+ }
mlir::Type eleTy = Fortran::lower::translateDerivedTypeToFIRType(
converter, opt->GetType().GetDerivedTypeSpec());
return genScalarLit(converter, loc, *opt, eleTy,
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index 24c990141be55..bb60147b26099 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -29,6 +29,7 @@
#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Builder/Runtime/Pointer.h"
+#include "flang/Optimizer/Builder/Runtime/Stop.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIRAttr.h"
#include "flang/Optimizer/HLFIR/HLFIROps.h"
@@ -1727,12 +1728,166 @@ class HlfirBuilder {
gen(const Fortran::evaluate::FunctionRef<T> &expr) {
mlir::Type resType =
Fortran::lower::TypeBuilder<T>::genType(getConverter(), expr);
+
+ // Intercept enumeration-type intrinsics (NEXT, PREVIOUS, HUGE) that return
+ // SomeDerived but lower to i32 operations.
+ if constexpr (std::is_same_v<T, Fortran::evaluate::SomeDerived>) {
+ if (const auto *intrinsic = expr.proc().GetSpecificIntrinsic()) {
+ if (intrinsic->name == "next") {
+ return genEnumerationNext(expr, resType);
+ }
+ if (intrinsic->name == "previous") {
+ return genEnumerationPrevious(expr, resType);
+ }
+ if (intrinsic->name == "huge") {
+ return genEnumerationHuge(expr, resType);
+ }
+ }
+ }
+
auto result = Fortran::lower::convertCallToHLFIR(
getLoc(), getConverter(), expr, resType, getSymMap(), getStmtCtx());
assert(result.has_value());
return *result;
}
+ // Helper to extract enumeration type info from a NEXT/PREVIOUS/HUGE
+ // intrinsic's result type.
+ std::pair<const Fortran::semantics::DerivedTypeSpec *, int>
+ getEnumerationTypeInfo(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr,
+ llvm::StringRef name) {
+ auto resultDynType = expr.proc().GetType();
+ assert(resultDynType && (name + " must have a result type").str().c_str());
+ const auto *derived = Fortran::evaluate::GetDerivedTypeSpec(*resultDynType);
+ assert(derived &&
+ derived->typeSymbol()
+ .detailsIf<Fortran::semantics::DerivedTypeDetails>() &&
+ derived->typeSymbol()
+ .detailsIf<Fortran::semantics::DerivedTypeDetails>()
+ ->isEnumerationType() &&
+ (name + " result must be enumeration type").str().c_str());
+ int count = derived->typeSymbol()
+ .GetUltimate()
+ .get<Fortran::semantics::DerivedTypeDetails>()
+ .enumeratorCount();
+ return {derived, count};
+ }
+
+ // Helper to lower STAT argument handling for NEXT/PREVIOUS.
+ // atBoundary is a boolean indicating whether the boundary condition was hit.
+ void genEnumerationStatHandling(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr,
+ mlir::Value atBoundary, mlir::Type resType) {
+ mlir::Location loc = getLoc();
+ fir::FirOpBuilder &builder = getBuilder();
+ if (expr.arguments().size() >= 2 && expr.arguments()[1]) {
+ // STAT is present — assign 0 or FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY (112)
+ const auto *statExpr = expr.arguments()[1]->UnwrapExpr();
+ assert(statExpr && "STAT argument must be an expression");
+ hlfir::Entity statAddr = Fortran::lower::convertExprToHLFIR(
+ loc, converter, *statExpr, getSymMap(), getStmtCtx());
+ mlir::Type statType = statAddr.getFortranElementType();
+ mlir::Value boundaryConst = builder.createIntegerConstant(
+ loc, statType, 112 /* FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY */);
+ mlir::Value zeroConst = builder.createIntegerConstant(loc, statType, 0);
+ mlir::Value statVal = mlir::arith::SelectOp::create(
+ builder, loc, atBoundary, boundaryConst, zeroConst);
+ hlfir::AssignOp::create(builder, loc, statVal, statAddr);
+ } else {
+ // STAT absent — error termination if at boundary
+ auto ifOp = fir::IfOp::create(builder, loc, {}, atBoundary,
+ /*withElseRegion=*/false);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ fir::runtime::genReportFatalUserError(
+ builder, loc,
+ "NEXT or PREVIOUS of enumeration type at boundary without STAT=");
+ builder.setInsertionPointAfter(ifOp);
+ }
+ }
+
+ // Lower NEXT(a [, stat]) for non-constant enumeration arguments.
+ // Produces: min(ordinal + 1, enumeratorCount) with STAT handling.
+ hlfir::EntityWithAttributes genEnumerationNext(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr,
+ mlir::Type resType) {
+ mlir::Location loc = getLoc();
+ fir::FirOpBuilder &builder = getBuilder();
+ auto [derived, count] = getEnumerationTypeInfo(expr, "NEXT");
+ (void)derived;
+ // Lower argument A (the enum variable).
+ assert(expr.arguments().size() >= 1 && expr.arguments()[0]);
+ const auto *argExpr = expr.arguments()[0]->UnwrapExpr();
+ assert(argExpr && "NEXT argument must be an expression");
+ hlfir::Entity arg = Fortran::lower::convertExprToHLFIR(
+ loc, converter, *argExpr, getSymMap(), getStmtCtx());
+ mlir::Value ordinal = hlfir::loadTrivialScalar(loc, builder, arg);
+ // Produce: min(ordinal + 1, enumeratorCount)
+ mlir::Value one = builder.createIntegerConstant(loc, resType, 1);
+ mlir::Value incremented =
+ mlir::arith::AddIOp::create(builder, loc, ordinal, one);
+ mlir::Value maxVal = builder.createIntegerConstant(loc, resType, count);
+ mlir::Value cmp = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::sle, incremented, maxVal);
+ mlir::Value result =
+ mlir::arith::SelectOp::create(builder, loc, cmp, incremented, maxVal);
+ // Handle STAT: boundary when ordinal == enumeratorCount
+ mlir::Value atBoundary = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, maxVal);
+ genEnumerationStatHandling(expr, atBoundary, resType);
+ return hlfir::EntityWithAttributes{result};
+ }
+
+ // Lower PREVIOUS(a [, stat]) for non-constant enumeration arguments.
+ // Produces: max(ordinal - 1, 1) with STAT handling.
+ hlfir::EntityWithAttributes genEnumerationPrevious(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr,
+ mlir::Type resType) {
+ mlir::Location loc = getLoc();
+ fir::FirOpBuilder &builder = getBuilder();
+ auto [derived, count] = getEnumerationTypeInfo(expr, "PREVIOUS");
+ (void)derived;
+ (void)count;
+ // Lower argument A (the enum variable).
+ assert(expr.arguments().size() >= 1 && expr.arguments()[0]);
+ const auto *argExpr = expr.arguments()[0]->UnwrapExpr();
+ assert(argExpr && "PREVIOUS argument must be an expression");
+ hlfir::Entity arg = Fortran::lower::convertExprToHLFIR(
+ loc, converter, *argExpr, getSymMap(), getStmtCtx());
+ mlir::Value ordinal = hlfir::loadTrivialScalar(loc, builder, arg);
+ // Produce: max(ordinal - 1, 1)
+ mlir::Value one = builder.createIntegerConstant(loc, resType, 1);
+ mlir::Value decremented =
+ mlir::arith::SubIOp::create(builder, loc, ordinal, one);
+ mlir::Value cmp = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::sge, decremented, one);
+ mlir::Value result =
+ mlir::arith::SelectOp::create(builder, loc, cmp, decremented, one);
+ // Handle STAT: boundary when ordinal == 1
+ mlir::Value atBoundary = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, one);
+ genEnumerationStatHandling(expr, atBoundary, resType);
+ return hlfir::EntityWithAttributes{result};
+ }
+
+ // Lower HUGE(enumVar) for non-constant enumeration arguments.
+ // Should always be folded, but handle as a constant just in case.
+ hlfir::EntityWithAttributes genEnumerationHuge(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr,
+ mlir::Type resType) {
+ mlir::Location loc = getLoc();
+ fir::FirOpBuilder &builder = getBuilder();
+ auto [derived, count] = getEnumerationTypeInfo(expr, "HUGE");
+ (void)derived;
+ mlir::Value result = builder.createIntegerConstant(loc, resType, count);
+ return hlfir::EntityWithAttributes{result};
+ }
+
template <typename T>
hlfir::EntityWithAttributes gen(const Fortran::evaluate::Constant<T> &expr) {
mlir::Location loc = getLoc();
@@ -2074,6 +2229,32 @@ class HlfirBuilder {
mlir::Location loc = getLoc();
fir::FirOpBuilder &builder = getBuilder();
mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor));
+
+ // Enumeration types lower to i32 — extract the __ordinal value.
+ // Check via the type symbol's DerivedTypeDetails rather than
+ // DerivedTypeSpec::IsEnumerationType(), which may not be set on
+ // all DerivedTypeSpec instances.
+ if (const auto *dtDetails =
+ ctor.derivedTypeSpec()
+ .typeSymbol()
+ .detailsIf<Fortran::semantics::DerivedTypeDetails>()) {
+ if (dtDetails->isEnumerationType()) {
+ if (const auto *scope = ctor.derivedTypeSpec().GetScope()) {
+ auto it = scope->find(Fortran::parser::CharBlock{"__ordinal", 9});
+ if (it != scope->end()) {
+ if (auto val = ctor.Find(it->second.get())) {
+ if (auto ordinal = Fortran::evaluate::ToInt64(*val)) {
+ mlir::Value result =
+ builder.createIntegerConstant(loc, ty, *ordinal);
+ return hlfir::EntityWithAttributes{result};
+ }
+ }
+ }
+ }
+ fir::emitFatalError(loc, "failed to extract enumeration ordinal");
+ }
+ }
+
auto recTy = mlir::cast<fir::RecordType>(ty);
if (recTy.isDependentType())
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index 0fdbdfcc74424..b6938aa6b97f9 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -385,6 +385,17 @@ struct TypeBuilderImpl {
if (tySpec.IsVectorType()) {
return genVectorType(tySpec);
}
+ // Check the type symbol's DerivedTypeDetails for the enumeration flag,
+ // because some DerivedTypeSpec instances may not have the
+ // EnumerationType category set (e.g., those created during USE
+ // association or variable declarations).
+ if (const auto *dtDetails =
+ tySpec.typeSymbol()
+ .detailsIf<Fortran::semantics::DerivedTypeDetails>()) {
+ if (dtDetails->isEnumerationType()) {
+ return mlir::IntegerType::get(&converter.getMLIRContext(), 32);
+ }
+ }
const Fortran::semantics::Symbol &typeSymbol = tySpec.typeSymbol();
const Fortran::semantics::Scope &derivedScope = DEREF(tySpec.GetScope());
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index a6a9551993e1e..39f079f3b0ea1 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -534,6 +534,7 @@ static constexpr IntrinsicHandler handlers[]{
{"substring", asAddr},
{"back", asValue, handleDynamicOptional},
{"kind", asValue}}}},
+ {"int", &I::genConversion},
{"ior", &I::genIor},
{"iparity",
&I::genIparity,
>From 0b88bbdadd8bda492d068d3e479527f28b1a9e68 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Wed, 22 Apr 2026 13:32:30 -0500
Subject: [PATCH 02/11] Adding lowering test.
---
flang/test/Lower/enumeration-type.f90 | 261 ++++++++++++++++++++++++++
1 file changed, 261 insertions(+)
create mode 100644 flang/test/Lower/enumeration-type.f90
diff --git a/flang/test/Lower/enumeration-type.f90 b/flang/test/Lower/enumeration-type.f90
new file mode 100644
index 0000000000000..e9187db225ebc
--- /dev/null
+++ b/flang/test/Lower/enumeration-type.f90
@@ -0,0 +1,261 @@
+! Test lowering of enumeration types to HLFIR/FIR.
+! Enumeration types lower to i32 values representing 1-based ordinal positions.
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+
+module enum_mod
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end module
+
+! -----------------------------------------------------------------------------
+! Test enumeration type maps to i32 (not fir.type)
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_enum_variable()
+subroutine test_enum_variable()
+ use enum_mod
+ type(color) :: c
+ ! CHECK: %[[ALLOC:.*]] = fir.alloca i32
+ ! CHECK: hlfir.declare %[[ALLOC]]
+ c = red
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test enumerator constants lower to i32 constants
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_enumerator_constants()
+subroutine test_enumerator_constants()
+ use enum_mod
+ type(color) :: c
+ ! CHECK: %[[RED:.*]] = arith.constant 1 : i32
+ ! CHECK: hlfir.assign %[[RED]]
+ c = red
+ ! CHECK: %[[GREEN:.*]] = arith.constant 2 : i32
+ ! CHECK: hlfir.assign %[[GREEN]]
+ c = green
+ ! CHECK: %[[BLUE:.*]] = arith.constant 3 : i32
+ ! CHECK: hlfir.assign %[[BLUE]]
+ c = blue
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test enumeration constructor — color(n) → i32 constant
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_constructor()
+subroutine test_constructor()
+ use enum_mod
+ type(color) :: c
+ ! CHECK: %[[C2:.*]] = arith.constant 2 : i32
+ ! CHECK: hlfir.assign %[[C2]]
+ c = color(2)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test enumeration comparisons (relational operators)
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_comparisons(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<i32>{{.*}}, %[[ARG1:.*]]: !fir.ref<i32>{{.*}})
+subroutine test_comparisons(c1, c2)
+ use enum_mod
+ type(color), intent(in) :: c1, c2
+ logical :: l
+ ! CHECK: %[[V1:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK: %[[V2:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK: arith.cmpi eq, %[[V1]], %[[V2]] : i32
+ l = (c1 == c2)
+ ! CHECK: arith.cmpi slt
+ l = (c1 < c2)
+ ! CHECK: arith.cmpi sle
+ l = (c1 <= c2)
+ ! CHECK: arith.cmpi sgt
+ l = (c1 > c2)
+ ! CHECK: arith.cmpi sge
+ l = (c1 >= c2)
+ ! CHECK: arith.cmpi ne
+ l = (c1 /= c2)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test INT() conversion of enumeration values
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_int_conversion()
+subroutine test_int_conversion()
+ use enum_mod
+ integer :: i
+ ! CHECK: %[[C1:.*]] = arith.constant 1 : i32
+ i = int(red)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test HUGE() — returns enumerator count as i32 constant
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_huge()
+subroutine test_huge()
+ use enum_mod
+ type(color) :: c
+ ! CHECK: arith.constant 3 : i32
+ c = huge(red)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() with variable argument
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_next(
+! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+subroutine test_next(c)
+ use enum_mod
+ type(color), intent(in) :: c
+ type(color) :: result
+ integer :: stat
+ ! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! Compute: min(ordinal + 1, 3)
+ ! CHECK: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK: %[[INC:.*]] = arith.addi %[[ORD]], %[[ONE]] : i32
+ ! CHECK: %[[MAX:.*]] = arith.constant 3 : i32
+ ! CHECK: %[[CMP:.*]] = arith.cmpi sle, %[[INC]], %[[MAX]] : i32
+ ! CHECK: %[[RES:.*]] = arith.select %[[CMP]], %[[INC]], %[[MAX]] : i32
+ ! Boundary check: ordinal == 3
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq, %[[ORD]], %[[MAX]] : i32
+ ! STAT handling: select 112 or 0
+ ! CHECK: arith.constant 112
+ ! CHECK: arith.constant 0
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign
+ result = next(c, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test PREVIOUS() with variable argument
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_previous(
+! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+subroutine test_previous(c)
+ use enum_mod
+ type(color), intent(in) :: c
+ type(color) :: result
+ integer :: stat
+ ! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! Compute: max(ordinal - 1, 1)
+ ! CHECK: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK: %[[DEC:.*]] = arith.subi %[[ORD]], %[[ONE]] : i32
+ ! CHECK: %[[CMP:.*]] = arith.cmpi sge, %[[DEC]], %[[ONE]] : i32
+ ! CHECK: %[[RES:.*]] = arith.select %[[CMP]], %[[DEC]], %[[ONE]] : i32
+ ! Boundary check: ordinal == 1
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq, %[[ORD]], %[[ONE]] : i32
+ ! STAT handling: select 112 or 0
+ ! CHECK: arith.constant 112
+ ! CHECK: arith.constant 0
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign
+ result = previous(c, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() without STAT — generates fatal error path
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_next_no_stat(
+subroutine test_next_no_stat(c)
+ use enum_mod
+ type(color), intent(in) :: c
+ type(color) :: result
+ ! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK: arith.addi
+ ! CHECK: arith.cmpi sle
+ ! CHECK: arith.select
+ ! Boundary without STAT — fir.if for fatal error
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: fir.if %[[BOUND]]
+ ! CHECK: fir.call @{{.*}}ReportFatalUserError
+ ! CHECK: }
+ result = next(c)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test SELECT CASE with enumeration type
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_select_case(
+subroutine test_select_case(c)
+ use enum_mod
+ type(color), intent(in) :: c
+ integer :: result
+ ! CHECK: %[[SEL:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK: %[[C1:.*]] = arith.constant 1 : i32
+ ! CHECK: %[[C2:.*]] = arith.constant 2 : i32
+ ! CHECK: %[[C3:.*]] = arith.constant 3 : i32
+ ! CHECK: fir.select_case %[[SEL]] : i32 [#fir.point, %[[C1]], ^{{.*}}, #fir.point, %[[C2]], ^{{.*}}, #fir.point, %[[C3]], ^{{.*}}, unit, ^{{.*}}]
+ select case (c)
+ case (red)
+ result = 1
+ case (green)
+ result = 2
+ case (blue)
+ result = 3
+ end select
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test enumeration dummy argument passing
+! -----------------------------------------------------------------------------
+
+! -----------------------------------------------------------------------------
+! Test formatted WRITE of enumeration value
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_formatted_write(
+! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+subroutine test_formatted_write(c)
+ use enum_mod
+ type(color), intent(in) :: c
+ ! CHECK: fir.call @_FortranAioBeginExternalFormattedOutput
+ ! CHECK: %[[VAL:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[VAL]])
+ ! CHECK: fir.call @_FortranAioEndIoStatement
+ write(*, '(I4)') c
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test formatted READ into enumeration variable
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_formatted_read(
+! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+subroutine test_formatted_read(c)
+ use enum_mod
+ type(color), intent(inout) :: c
+ ! CHECK: fir.call @_FortranAioBeginExternalFormattedInput
+ ! CHECK: %[[CONV:.*]] = fir.convert %{{.*}} : (!fir.ref<i32>) -> !fir.ref<i64>
+ ! CHECK: fir.call @_FortranAioInputInteger(%{{.*}}, %[[CONV]], %{{.*}})
+ ! CHECK: fir.call @_FortranAioEndIoStatement
+ read(*, '(I4)') c
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test enumeration dummy argument passing
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_enum_arg_pass()
+subroutine test_enum_arg_pass()
+ use enum_mod
+ type(color) :: c
+ c = green
+ ! CHECK: %[[C2:.*]] = arith.constant 2 : i32
+ ! CHECK: fir.call @_QPtake_enum
+ call take_enum(c)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtake_enum(
+! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+subroutine take_enum(c)
+ use enum_mod
+ type(color), intent(in) :: c
+end subroutine
>From 20526d27814cfb290e1cf4e0994d27e7dc5cd45f Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Wed, 10 Jun 2026 14:30:20 -0500
Subject: [PATCH 03/11] Added processing for non-constant constructors.
---
flang/lib/Lower/ConvertExprToHLFIR.cpp | 10 ++++++++++
1 file changed, 10 insertions(+)
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index bb60147b26099..f7a7ec0bb2795 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -2248,6 +2248,16 @@ class HlfirBuilder {
builder.createIntegerConstant(loc, ty, *ordinal);
return hlfir::EntityWithAttributes{result};
}
+ // Non-constant ordinal (e.g. color(i) with variable i): lower
+ // the __ordinal component expression to a runtime scalar value.
+ // TODO: when a -fcheck=enum runtime check flag is added, emit a
+ // bounds check here that the ordinal is in 1..enumeratorCount.
+ hlfir::Entity ordinalEntity = gen(*val);
+ mlir::Value ordinal =
+ hlfir::loadTrivialScalar(loc, builder, ordinalEntity);
+ if (ordinal.getType() != ty)
+ ordinal = builder.createConvert(loc, ty, ordinal);
+ return hlfir::EntityWithAttributes{ordinal};
}
}
}
>From 891484d8a6f60b715714b37e69b2077301c0d525 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Wed, 16 Sep 2026 10:20:56 -0500
Subject: [PATCH 04/11] Completed the lowering of intrinsics: STAT=, arrays,
etc.
---
flang/lib/Evaluate/fold-implementation.h | 36 +---
flang/lib/Evaluate/intrinsics.cpp | 28 ---
flang/lib/Lower/Bridge.cpp | 15 +-
flang/lib/Lower/ConvertExprToHLFIR.cpp | 183 +++++++++++++-----
flang/test/Lower/enumeration-type.f90 | 2 +-
.../Semantics/enumeration-type-intrinsics.f90 | 91 +++++----
6 files changed, 208 insertions(+), 147 deletions(-)
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index f89fb1601176e..3dd517ba8a077 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1293,26 +1293,18 @@ static inline Expr<SomeDerived> FoldEnumerationNextOrPrevious(
return Expr<SomeDerived>{std::move(funcRef)};
}
// A boundary hit (NEXT() of the last enumerator or PREVIOUS() of the first)
- // without STAT= is, in the final design, a runtime error termination. In a
- // required-constant context that value cannot be deferred, so it is
- // diagnosed as out of range. Outside a constant context the reference would
- // otherwise be left unfolded and deferred to run time — but lowering has no
- // NEXT/PREVIOUS support yet (IntrinsicCall.cpp aborts), so a constant
- // boundary argument is temporarily gated here, mirroring the STAT= and
- // non-constant guards in intrinsics.cpp, until the lowering handler lands.
+ // without STAT= is a runtime error termination. In a required-constant
+ // context that value cannot be deferred, so it is diagnosed as out of range.
+ // Outside a constant context the reference is left unfolded and deferred to
+ // run time, where lowering emits the STAT assignment or error termination.
auto handleBoundary{[&]() -> Expr<SomeDerived> {
if (context.inConstantContext()) {
context.messages().Say(isNext
? "NEXT() of the last enumerator is out of range"_err_en_US
: "PREVIOUS() of the first enumerator is out of range"_err_en_US);
- } else {
- // TEMPORARY: gate the boundary case until lowering handler lands in PR
- // 4/5
- context.messages().Say(isNext
- ? "NEXT() at the last enumerator is not yet supported"_err_en_US
- : "PREVIOUS() at the first enumerator is not yet supported"_err_en_US);
+ return MakeInvalidIntrinsic<SomeDerived>(std::move(funcRef));
}
- return MakeInvalidIntrinsic<SomeDerived>(std::move(funcRef));
+ return Expr<SomeDerived>{std::move(funcRef)};
}};
if (auto sc{constant->GetScalarValue()}) {
if (auto ordExpr{sc->Find(ordSym)}) {
@@ -1332,20 +1324,8 @@ static inline Expr<SomeDerived> FoldEnumerationNextOrPrevious(
// Array constant: NEXT/PREVIOUS are elemental, so fold elementwise into
// a constant array of enumerators. STAT= is absent here (the
// STAT-present case bails out above), so there is no side effect to
- // preserve.
- //
- // NOTE (enum-lowering / next PR): the runtime counterpart of this array
- // case is not yet implemented. genEnumerationNext/Previous in
- // flang/lib/Lower/ConvertExprToHLFIR.cpp call hlfir::loadTrivialScalar
- // and emit scalar arith, so they only accept scalar arguments. When a
- // non-constant array argument reaches lowering, those emitters must be
- // wrapped in an hlfir.elemental region (one scalar min/max plus a
- // per-element boundary test, per element), and STAT handling must reduce
- // the per-element boundary flags (any-boundary -> STAT/abort). This
- // elementwise fold is the compile-time mirror of that loop. Until the
- // lowering lands, only constant array arguments fold here; the sem-3
- // handler's temporary "non-constant argument is not yet supported" guard
- // still rejects runtime arrays.
+ // preserve. This elementwise fold mirrors the runtime elemental lowering
+ // in genEnumerationArray (flang/lib/Lower/ConvertExprToHLFIR.cpp).
std::vector<StructureConstructor> elements;
elements.reserve(constant->values().size());
for (const StructureConstructorValues &scv : constant->values()) {
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 88874f7ef08e8..a687a4f0aea46 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -3756,20 +3756,6 @@ IntrinsicProcTable::Implementation::HandleEnumerationNext(
context.messages().Say("NEXT() requires argument A"_err_en_US);
return std::nullopt;
}
- // TEMPORARY: Reject STAT= until lowering handler lands in PR 4/5
- if (arguments.size() > 1 && arguments[1]) {
- context.messages().Say(arguments[1]->sourceLocation(),
- "NEXT() with STAT= is not yet supported"_err_en_US);
- return std::nullopt;
- }
- // TEMPORARY: Reject non-constant argument until lowering handler in PR 4/5
- if (const auto *expr{arguments[0]->UnwrapExpr()}) {
- if (!IsConstantExpr(*expr)) {
- context.messages().Say(arguments[0]->sourceLocation(),
- "NEXT() with a non-constant argument is not yet supported"_err_en_US);
- return std::nullopt;
- }
- }
DynamicType enumerationType{derived};
characteristics::DummyDataObject ddoA{
characteristics::TypeAndShape{enumerationType}};
@@ -3807,20 +3793,6 @@ IntrinsicProcTable::Implementation::HandleEnumerationPrevious(
context.messages().Say("PREVIOUS() requires argument A"_err_en_US);
return std::nullopt;
}
- // TEMPORARY: Reject STAT= until lowering handler lands in PR 4/5
- if (arguments.size() > 1 && arguments[1]) {
- context.messages().Say(arguments[1]->sourceLocation(),
- "PREVIOUS() with STAT= is not yet supported"_err_en_US);
- return std::nullopt;
- }
- // TEMPORARY: Reject non-constant argument until lowering handler in PR 4/5
- if (const auto *expr{arguments[0]->UnwrapExpr()}) {
- if (!IsConstantExpr(*expr)) {
- context.messages().Say(arguments[0]->sourceLocation(),
- "PREVIOUS() with a non-constant argument is not yet supported"_err_en_US);
- return std::nullopt;
- }
- }
DynamicType enumerationType{derived};
characteristics::DummyDataObject ddoA{
characteristics::TypeAndShape{enumerationType}};
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 6d3331b164dca..f3881a3f59d22 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -6845,9 +6845,22 @@ class FirConverter : public Fortran::lower::AbstractConverter {
Fortran::common::TypeCategory::Derived) {
if (const auto *constant =
std::get_if<Fortran::evaluate::Constant<
- Fortran::evaluate::SomeDerived>>(&x.u))
+ Fortran::evaluate::SomeDerived>>(&x.u)) {
+ const auto &spec = constant->GetType().GetDerivedTypeSpec();
+ const auto *dtDetails =
+ spec.typeSymbol()
+ .template detailsIf<
+ Fortran::semantics::DerivedTypeDetails>();
+ if (dtDetails && dtDetails->isEnumerationType())
+ // Enumeration types lower to i32 (no RecordType); mangle the
+ // name from the type spec instead of the element type.
+ return Fortran::lower::mangle::mangleArrayLiteral(
+ constant->values().size() * sizeof(constant->values()[0]),
+ constant->shape(), Fortran::common::TypeCategory::Derived,
+ /*kind=*/0, /*charLen=*/-1, mangleName(spec));
return Fortran::lower::mangle::mangleArrayLiteral(eleTy,
*constant);
+ }
fir::emitFatalError(loc,
"non a constant derived type expression");
} else {
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index f7a7ec0bb2795..7aeb2f8b3d2da 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -1808,72 +1808,163 @@ class HlfirBuilder {
}
}
- // Lower NEXT(a [, stat]) for non-constant enumeration arguments.
- // Produces: min(ordinal + 1, enumeratorCount) with STAT handling.
- hlfir::EntityWithAttributes genEnumerationNext(
- const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
- &expr,
- mlir::Type resType) {
- mlir::Location loc = getLoc();
- fir::FirOpBuilder &builder = getBuilder();
- auto [derived, count] = getEnumerationTypeInfo(expr, "NEXT");
- (void)derived;
- // Lower argument A (the enum variable).
- assert(expr.arguments().size() >= 1 && expr.arguments()[0]);
- const auto *argExpr = expr.arguments()[0]->UnwrapExpr();
- assert(argExpr && "NEXT argument must be an expression");
- hlfir::Entity arg = Fortran::lower::convertExprToHLFIR(
- loc, converter, *argExpr, getSymMap(), getStmtCtx());
- mlir::Value ordinal = hlfir::loadTrivialScalar(loc, builder, arg);
- // Produce: min(ordinal + 1, enumeratorCount)
+ // Compute the per-element NEXT/PREVIOUS result and boundary flag from a
+ // scalar ordinal. isNext selects NEXT (min(ordinal+1, count)) versus
+ // PREVIOUS (max(ordinal-1, 1)); the returned atBoundary is an i1.
+ std::pair<mlir::Value, mlir::Value>
+ genEnumOrdinalStep(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value ordinal, mlir::Type resType, int count,
+ bool isNext) {
mlir::Value one = builder.createIntegerConstant(loc, resType, 1);
- mlir::Value incremented =
- mlir::arith::AddIOp::create(builder, loc, ordinal, one);
- mlir::Value maxVal = builder.createIntegerConstant(loc, resType, count);
+ if (isNext) {
+ mlir::Value maxVal = builder.createIntegerConstant(loc, resType, count);
+ mlir::Value incremented =
+ mlir::arith::AddIOp::create(builder, loc, ordinal, one);
+ mlir::Value cmp = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::sle, incremented, maxVal);
+ mlir::Value result =
+ mlir::arith::SelectOp::create(builder, loc, cmp, incremented, maxVal);
+ mlir::Value atBoundary = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, maxVal);
+ return {result, atBoundary};
+ }
+ mlir::Value decremented =
+ mlir::arith::SubIOp::create(builder, loc, ordinal, one);
mlir::Value cmp = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::sle, incremented, maxVal);
+ builder, loc, mlir::arith::CmpIPredicate::sge, decremented, one);
mlir::Value result =
- mlir::arith::SelectOp::create(builder, loc, cmp, incremented, maxVal);
- // Handle STAT: boundary when ordinal == enumeratorCount
+ mlir::arith::SelectOp::create(builder, loc, cmp, decremented, one);
mlir::Value atBoundary = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, maxVal);
- genEnumerationStatHandling(expr, atBoundary, resType);
- return hlfir::EntityWithAttributes{result};
+ builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, one);
+ return {result, atBoundary};
}
- // Lower PREVIOUS(a [, stat]) for non-constant enumeration arguments.
- // Produces: max(ordinal - 1, 1) with STAT handling.
- hlfir::EntityWithAttributes genEnumerationPrevious(
+ // Lower NEXT/PREVIOUS applied to a whole-array (elemental) enumeration
+ // argument. The result is a pure hlfir.elemental; STAT/error-termination
+ // side effects are handled after it, per element.
+ hlfir::EntityWithAttributes genEnumerationArray(
const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
&expr,
- mlir::Type resType) {
+ hlfir::Entity arg, mlir::Type resType, int count, bool isNext) {
mlir::Location loc = getLoc();
fir::FirOpBuilder &builder = getBuilder();
- auto [derived, count] = getEnumerationTypeInfo(expr, "PREVIOUS");
+ mlir::Value shape = hlfir::genShape(loc, builder, arg);
+ // resType is the whole array type here; the ordinal arithmetic and result
+ // element type need the scalar (i32) element type.
+ mlir::Type eleTy = hlfir::getFortranElementType(resType);
+
+ auto resultKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
+ mlir::ValueRange idx) -> hlfir::Entity {
+ mlir::Value ordinal =
+ hlfir::loadTrivialScalar(l, b, hlfir::getElementAt(l, b, arg, idx));
+ auto [result, atBoundary] =
+ genEnumOrdinalStep(b, l, ordinal, eleTy, count, isNext);
+ (void)atBoundary;
+ return hlfir::Entity{result};
+ };
+ mlir::Value resultElem =
+ hlfir::genElementalOp(loc, builder, eleTy, shape, /*typeParams=*/{},
+ resultKernel, /*isUnordered=*/true);
+ fir::FirOpBuilder *bldr = &builder;
+ getStmtCtx().attachCleanup(
+ [=]() { hlfir::DestroyOp::create(*bldr, loc, resultElem); });
+
+ if (expr.arguments().size() >= 2 && expr.arguments()[1]) {
+ // STAT present: elementwise 0/112 into the conformable STAT array.
+ const auto *statExpr = expr.arguments()[1]->UnwrapExpr();
+ assert(statExpr && "STAT argument must be an expression");
+ hlfir::Entity statEntity = Fortran::lower::convertExprToHLFIR(
+ loc, converter, *statExpr, getSymMap(), getStmtCtx());
+ mlir::Type statType = statEntity.getFortranElementType();
+ auto statKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
+ mlir::ValueRange idx) -> hlfir::Entity {
+ mlir::Value ordinal =
+ hlfir::loadTrivialScalar(l, b, hlfir::getElementAt(l, b, arg, idx));
+ auto [result, atBoundary] =
+ genEnumOrdinalStep(b, l, ordinal, eleTy, count, isNext);
+ (void)result;
+ mlir::Value boundaryConst = b.createIntegerConstant(l, statType, 112);
+ mlir::Value zeroConst = b.createIntegerConstant(l, statType, 0);
+ return hlfir::Entity{mlir::arith::SelectOp::create(
+ b, l, atBoundary, boundaryConst, zeroConst)};
+ };
+ mlir::Value statElem = hlfir::genElementalOp(
+ loc, builder, statType, shape, /*typeParams=*/{}, statKernel,
+ /*isUnordered=*/true);
+ hlfir::AssignOp::create(builder, loc, statElem, statEntity);
+ getStmtCtx().attachCleanup(
+ [=]() { hlfir::DestroyOp::create(*bldr, loc, statElem); });
+ } else {
+ // STAT absent: error termination if any element is at a boundary.
+ mlir::Type logType = fir::LogicalType::get(builder.getContext(), 4);
+ auto maskKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
+ mlir::ValueRange idx) -> hlfir::Entity {
+ mlir::Value ordinal =
+ hlfir::loadTrivialScalar(l, b, hlfir::getElementAt(l, b, arg, idx));
+ auto [result, atBoundary] =
+ genEnumOrdinalStep(b, l, ordinal, eleTy, count, isNext);
+ (void)result;
+ return hlfir::Entity{b.createConvert(l, logType, atBoundary)};
+ };
+ mlir::Value mask =
+ hlfir::genElementalOp(loc, builder, logType, shape, /*typeParams=*/{},
+ maskKernel, /*isUnordered=*/true);
+ mlir::Value anyBoundary =
+ hlfir::AnyOp::create(builder, loc, logType, mask,
+ /*dim=*/mlir::Value{});
+ mlir::Value cond =
+ builder.createConvert(loc, builder.getI1Type(), anyBoundary);
+ auto ifOp = fir::IfOp::create(builder, loc, {}, cond,
+ /*withElseRegion=*/false);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ fir::runtime::genReportFatalUserError(
+ builder, loc,
+ "NEXT or PREVIOUS of enumeration type at boundary without STAT=");
+ builder.setInsertionPointAfter(ifOp);
+ hlfir::DestroyOp::create(builder, loc, mask);
+ }
+ return hlfir::EntityWithAttributes{resultElem};
+ }
+
+ // Lower NEXT/PREVIOUS for non-constant enumeration arguments, dispatching to
+ // the scalar or elemental-array path. isNext selects NEXT versus PREVIOUS.
+ hlfir::EntityWithAttributes genEnumerationNextOrPrevious(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr,
+ mlir::Type resType, bool isNext) {
+ mlir::Location loc = getLoc();
+ fir::FirOpBuilder &builder = getBuilder();
+ auto [derived, count] =
+ getEnumerationTypeInfo(expr, isNext ? "NEXT" : "PREVIOUS");
(void)derived;
- (void)count;
- // Lower argument A (the enum variable).
assert(expr.arguments().size() >= 1 && expr.arguments()[0]);
const auto *argExpr = expr.arguments()[0]->UnwrapExpr();
- assert(argExpr && "PREVIOUS argument must be an expression");
+ assert(argExpr && "NEXT/PREVIOUS argument must be an expression");
hlfir::Entity arg = Fortran::lower::convertExprToHLFIR(
loc, converter, *argExpr, getSymMap(), getStmtCtx());
+ if (arg.isArray())
+ return genEnumerationArray(expr, arg, resType, count, isNext);
mlir::Value ordinal = hlfir::loadTrivialScalar(loc, builder, arg);
- // Produce: max(ordinal - 1, 1)
- mlir::Value one = builder.createIntegerConstant(loc, resType, 1);
- mlir::Value decremented =
- mlir::arith::SubIOp::create(builder, loc, ordinal, one);
- mlir::Value cmp = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::sge, decremented, one);
- mlir::Value result =
- mlir::arith::SelectOp::create(builder, loc, cmp, decremented, one);
- // Handle STAT: boundary when ordinal == 1
- mlir::Value atBoundary = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, one);
+ auto [result, atBoundary] =
+ genEnumOrdinalStep(builder, loc, ordinal, resType, count, isNext);
genEnumerationStatHandling(expr, atBoundary, resType);
return hlfir::EntityWithAttributes{result};
}
+ hlfir::EntityWithAttributes genEnumerationNext(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr,
+ mlir::Type resType) {
+ return genEnumerationNextOrPrevious(expr, resType, /*isNext=*/true);
+ }
+
+ hlfir::EntityWithAttributes genEnumerationPrevious(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr,
+ mlir::Type resType) {
+ return genEnumerationNextOrPrevious(expr, resType, /*isNext=*/false);
+ }
+
// Lower HUGE(enumVar) for non-constant enumeration arguments.
// Should always be folded, but handle as a constant just in case.
hlfir::EntityWithAttributes genEnumerationHuge(
diff --git a/flang/test/Lower/enumeration-type.f90 b/flang/test/Lower/enumeration-type.f90
index e9187db225ebc..a1cd66114e7c4 100644
--- a/flang/test/Lower/enumeration-type.f90
+++ b/flang/test/Lower/enumeration-type.f90
@@ -1,6 +1,6 @@
! Test lowering of enumeration types to HLFIR/FIR.
! Enumeration types lower to i32 values representing 1-based ordinal positions.
-! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -fenumeration-type -emit-hlfir %s -o - | FileCheck %s
module enum_mod
enumeration type :: color
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
index 1335090b6c75d..d04a6209f66c3 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -1,7 +1,9 @@
! RUN: not %flang_fc1 -fsyntax-only -fenumeration-type -pedantic %s 2>&1 | FileCheck %s
-! Test intrinsics HUGE, NEXT, PREVIOUS, INT for enumeration types (F2023 7.6.2)
-! NOTE: This test will start failing when the whole PR stack is merged. It will
-! need to have expected results changed and the "not" above removed.
+! Test intrinsics HUGE, NEXT, PREVIOUS, INT for enumeration types (F2023 7.6.2).
+! With lowering/runtime support in place, the previously-gated cases (non-
+! constant argument, STAT=, runtime boundary) now compile cleanly; the only
+! remaining compile-time errors are an unsupported INT kind and NEXT/PREVIOUS
+! boundary hits in a required-constant context.
module enum_intrinsics_mod
enumeration type :: color
@@ -33,19 +35,16 @@ subroutine test_next()
type(color) :: c, nc
integer :: istat
- ! NEXT(a) returns the next enumerator
+ ! NEXT(a) with a non-constant argument now lowers at run time.
c = red
- !CHECK: error: NEXT() with a non-constant argument is not yet supported
nc = next(c)
! NEXT with constants
nc = next(red)
nc = next(green)
- ! NEXT with STAT= argument (temporarily unsupported)
- !CHECK: error: NEXT() with STAT= is not yet supported
+ ! NEXT with STAT= (now supported).
nc = next(c, stat=istat)
- !CHECK: error: NEXT() with STAT= is not yet supported
nc = next(blue, stat=istat)
end subroutine
@@ -54,19 +53,16 @@ subroutine test_previous()
type(color) :: c, pc
integer :: istat
- ! PREVIOUS(a) returns the previous enumerator
+ ! PREVIOUS(a) with a non-constant argument now lowers at run time.
c = blue
- !CHECK: error: PREVIOUS() with a non-constant argument is not yet supported
pc = previous(c)
! PREVIOUS with constants
pc = previous(blue)
pc = previous(green)
- ! PREVIOUS with STAT= argument (temporarily unsupported)
- !CHECK: error: PREVIOUS() with STAT= is not yet supported
+ ! PREVIOUS with STAT= (now supported).
pc = previous(c, stat=istat)
- !CHECK: error: PREVIOUS() with STAT= is not yet supported
pc = previous(red, stat=istat)
end subroutine
@@ -124,10 +120,9 @@ subroutine test_next_boundary_with_stat()
use enum_intrinsics_mod
type(color) :: nc
integer :: istat
- ! NEXT at boundary with STAT — TEMPORARILY rejected until lowering lands in PR 4/5
- !CHECK: error: NEXT() with STAT= is not yet supported
+ ! NEXT at a boundary WITH STAT= is valid: the boundary is reported at run
+ ! time via STAT=, so nothing is diagnosed at compile time.
nc = next(blue, stat=istat)
- !CHECK: error: NEXT() with STAT= is not yet supported
nc = next(huge(red), stat=istat)
end subroutine
@@ -142,55 +137,57 @@ subroutine test_previous_boundary_with_stat()
use enum_intrinsics_mod
type(color) :: pc
integer :: istat
- ! PREVIOUS at boundary with STAT — TEMPORARILY rejected until lowering lands in PR 4/5
- !CHECK: error: PREVIOUS() with STAT= is not yet supported
+ ! PREVIOUS at a boundary WITH STAT= is valid (boundary reported at run time).
pc = previous(red, stat=istat)
end subroutine
subroutine test_next_boundary()
use enum_intrinsics_mod
type(color) :: nc
- ! NEXT at the last enumerator without STAT is, in the final design, a runtime
- ! error termination. Until the lowering handler lands (PR 4/5) the constant
- ! boundary case is temporarily rejected at compile time rather than reaching
- ! the unimplemented lowering path.
- !CHECK: error: NEXT() at the last enumerator is not yet supported
+ ! NEXT at the last enumerator without STAT in a non-constant context is a
+ ! run-time error termination; it is deferred to lowering, so nothing is
+ ! diagnosed here at compile time.
nc = next(blue)
end subroutine
subroutine test_previous_boundary()
use enum_intrinsics_mod
type(color) :: pc
- ! PREVIOUS at the first enumerator without STAT is, in the final design, a
- ! runtime error termination. Temporarily rejected until lowering lands.
- !CHECK: error: PREVIOUS() at the first enumerator is not yet supported
+ ! PREVIOUS at the first enumerator without STAT in a non-constant context is
+ ! deferred to run time; nothing is diagnosed at compile time.
pc = previous(red)
end subroutine
subroutine test_next_previous_array_boundary()
use enum_intrinsics_mod
type(color) :: nc(2), pc(2)
- ! NEXT/PREVIOUS are elemental: a constant array with any element at the
- ! boundary is a runtime error termination without STAT=. Temporarily
- ! rejected until lowering lands (same as the scalar boundary case).
- !CHECK: error: NEXT() at the last enumerator is not yet supported
+ ! NEXT/PREVIOUS are elemental: an array with a boundary element without STAT=
+ ! in a non-constant context is deferred to run-time error termination, so it
+ ! is not diagnosed at compile time.
nc = next([green, blue])
- !CHECK: error: PREVIOUS() at the first enumerator is not yet supported
pc = previous([red, green])
end subroutine
subroutine test_next_previous_boundary_constant()
use enum_intrinsics_mod
- ! A required-constant boundary case would normally be diagnosed as out of
- ! range at compile time. While NEXT/PREVIOUS are temporarily gated (PR 4/5),
- ! the runtime-context gate fires first and reports "not yet supported"
- ! instead; this reverts to "out of range" once the lowering handler lands.
- !CHECK: error: NEXT() at the last enumerator is not yet supported
+ ! A required-constant boundary case cannot be deferred to run time, so it is
+ ! diagnosed as out of range at compile time.
+ !CHECK: error: NEXT() of the last enumerator is out of range
logical, parameter :: nb = next(blue) == green
- !CHECK: error: PREVIOUS() at the first enumerator is not yet supported
+ !CHECK: error: PREVIOUS() of the first enumerator is out of range
logical, parameter :: pb = previous(red) == green
end subroutine
+subroutine test_next_previous_array_boundary_constant()
+ use enum_intrinsics_mod
+ ! Elemental boundary hit in a required-constant array context is likewise
+ ! diagnosed at compile time.
+ !CHECK: error: NEXT() of the last enumerator is out of range
+ type(color), parameter :: nbad(2) = next([green, blue])
+ !CHECK: error: PREVIOUS() of the first enumerator is out of range
+ type(color), parameter :: pbad(2) = previous([red, green])
+end subroutine
+
subroutine test_huge_real_still_works()
! Non-enumeration HUGE still works normally
real :: r
@@ -199,17 +196,25 @@ subroutine test_huge_real_still_works()
i = huge(i)
end subroutine
-! NOTE: This test will need to be modified after completion of the feature.
subroutine test_next_previous_keyword_order()
use enum_intrinsics_mod
type(color) :: nc
integer :: istat
! The enum argument passed by keyword AFTER a non-enum keyword (STAT=) must
- ! still be recognized as the enumeration call. Reaching the STAT handler
- ! (rather than the "must be of enumeration type" diagnostic) proves the
- ! keyword-order dispatch works.
- !CHECK: error: NEXT() with STAT= is not yet supported
+ ! still be recognized as the enumeration call; these now compile cleanly.
nc = next(stat=istat, a=red)
- !CHECK: error: PREVIOUS() with STAT= is not yet supported
nc = previous(stat=istat, a=blue)
end subroutine
+
+subroutine test_next_previous_stat_nonconformant()
+ use enum_intrinsics_mod
+ type(color) :: arr(3), nc(3), pc(3)
+ integer :: stat2(2)
+ ! NEXT/PREVIOUS are elemental with an INTENT(OUT) STAT=, so a STAT= array
+ ! must conform with A; a differently shaped STAT= is caught by the general
+ ! elemental-conformance check on the resolved call.
+ !CHECK: error: Dimension 1 of actual argument (arr) corresponding to dummy argument #1 ('a') has extent 3, but actual argument (stat2) corresponding to dummy argument #2 ('stat') has extent 2
+ nc = next(arr, stat=stat2)
+ !CHECK: error: Dimension 1 of actual argument (arr) corresponding to dummy argument #1 ('a') has extent 3, but actual argument (stat2) corresponding to dummy argument #2 ('stat') has extent 2
+ pc = previous(arr, stat=stat2)
+end subroutine
>From 6689abc103861663a7a23fe32e4e25a0bf05c733 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Tue, 22 Sep 2026 13:01:10 -0500
Subject: [PATCH 05/11] Fixed lowering bugs. This allows complete successful
testing of feature.
---
flang/lib/Lower/CallInterface.cpp | 21 ++++++--
flang/lib/Lower/ConvertExprToHLFIR.cpp | 33 +++++++++++-
flang/lib/Semantics/type.cpp | 3 ++
flang/test/Lower/enumeration-type.f90 | 75 +++++++++++++++++++++++---
4 files changed, 120 insertions(+), 12 deletions(-)
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 2bfe94559cd88..fc620a507ca82 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1062,7 +1062,8 @@ class Fortran::lower::CallInterfaceImpl {
}
} else if (dynamicType.category() ==
Fortran::common::TypeCategory::Derived) {
- if (!dynamicType.GetDerivedTypeSpec().IsVectorType()) {
+ if (!dynamicType.GetDerivedTypeSpec().IsVectorType() &&
+ !isEnumerationDerived(dynamicType)) {
// Derived result need to be allocated by the caller and the result
// value must be saved. Derived type in implicit interface cannot have
// length parameters.
@@ -1174,6 +1175,18 @@ class Fortran::lower::CallInterfaceImpl {
}
}
+ // An F2023 enumeration type has Derived category but lowers to i32 and is
+ // returned by value like an integer, so it must not use the caller-allocated
+ // fir.save_result ABI reserved for record-shaped results.
+ static bool
+ isEnumerationDerived(const Fortran::evaluate::DynamicType &dynamicType) {
+ // GetDerivedTypeSpec() is null-safe: it yields nullptr for polymorphic and
+ // assumed-type results whose category is Derived but have no derived spec.
+ const Fortran::semantics::DerivedTypeSpec *spec{
+ Fortran::evaluate::GetDerivedTypeSpec(dynamicType)};
+ return spec && Fortran::semantics::IsEnumerationType(spec->typeSymbol());
+ }
+
mlir::Type
translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) {
Fortran::common::TypeCategory cat = dynamicType.category();
@@ -1397,8 +1410,10 @@ class Fortran::lower::CallInterfaceImpl {
addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
Property::Value);
// Explicit results require the caller to allocate the storage and save the
- // function result in the storage with a fir.save_result.
- setSaveResult();
+ // function result in the storage with a fir.save_result. Enumeration
+ // results lower to i32 and are returned by value, so they are exempt.
+ if (!isEnumerationDerived(typeAndShape->type()))
+ setSaveResult();
}
// Return nullopt for scalars, empty vector for assumed rank, and a vector
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index 7aeb2f8b3d2da..0907442be20c6 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -2341,13 +2341,42 @@ class HlfirBuilder {
}
// Non-constant ordinal (e.g. color(i) with variable i): lower
// the __ordinal component expression to a runtime scalar value.
- // TODO: when a -fcheck=enum runtime check flag is added, emit a
- // bounds check here that the ordinal is in 1..enumeratorCount.
hlfir::Entity ordinalEntity = gen(*val);
mlir::Value ordinal =
hlfir::loadTrivialScalar(loc, builder, ordinalEntity);
if (ordinal.getType() != ty)
ordinal = builder.createConvert(loc, ty, ordinal);
+ // F2023 7.6.2 para 5 requires the constructor value to be
+ // positive and <= the number of enumerators. This is a plain
+ // "shall" (not a numbered constraint), so the processor is not
+ // required to detect a violation; the standard leaves the
+ // behavior to the processor. We choose to always emit a runtime
+ // range check with error termination. This block could be placed
+ // behind an -fcheck=enum style flag if the community prefers an
+ // opt-in implementation.
+ int count = ctor.derivedTypeSpec()
+ .typeSymbol()
+ .GetUltimate()
+ .get<Fortran::semantics::DerivedTypeDetails>()
+ .enumeratorCount();
+ mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
+ mlir::Value maxVal =
+ builder.createIntegerConstant(loc, ty, count);
+ mlir::Value tooLow = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::slt, ordinal, one);
+ mlir::Value tooHigh = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::sgt, ordinal,
+ maxVal);
+ mlir::Value outOfRange =
+ mlir::arith::OrIOp::create(builder, loc, tooLow, tooHigh);
+ auto ifOp = fir::IfOp::create(builder, loc, {}, outOfRange,
+ /*withElseRegion=*/false);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ fir::runtime::genReportFatalUserError(
+ builder, loc,
+ "enumeration constructor value is out of range (must be "
+ "positive and not greater than the number of enumerators)");
+ builder.setInsertionPointAfter(ifOp);
return hlfir::EntityWithAttributes{ordinal};
}
}
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 2d27879afdaac..26805fe920abb 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -379,6 +379,9 @@ void DerivedTypeSpec::Instantiate(Scope &containingScope) {
if (!mutableTypeScope.derivedTypeSpec()) {
mutableTypeScope.set_derivedTypeSpec(*this);
}
+ // Size the type now so that any enclosing type instantiated before the
+ // whole-program offset pass measures this component correctly.
+ ComputeOffsets(containingScope.context(), mutableTypeScope);
return;
}
diff --git a/flang/test/Lower/enumeration-type.f90 b/flang/test/Lower/enumeration-type.f90
index a1cd66114e7c4..c6488474af415 100644
--- a/flang/test/Lower/enumeration-type.f90
+++ b/flang/test/Lower/enumeration-type.f90
@@ -50,9 +50,39 @@ subroutine test_constructor()
type(color) :: c
! CHECK: %[[C2:.*]] = arith.constant 2 : i32
! CHECK: hlfir.assign %[[C2]]
+ ! Constant argument is range-checked at compile time (semantics), so no
+ ! runtime range check is emitted here.
+ ! CHECK-NOT: fir.call @{{.*}}ReportFatalUserError
c = color(2)
end subroutine
+! -----------------------------------------------------------------------------
+! Test enumeration constructor — color(i) runtime range check
+! -----------------------------------------------------------------------------
+
+! A non-constant argument cannot be range-checked at compile time, so lowering
+! emits an always-on runtime check (1 <= i <= enumeratorCount) with fatal
+! error termination (F2023 7.6.2 para 5).
+
+! CHECK-LABEL: func.func @_QPtest_constructor_runtime(
+! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+subroutine test_constructor_runtime(i)
+ use enum_mod
+ integer, intent(in) :: i
+ type(color) :: c
+ ! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK-DAG: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK-DAG: %[[MAX:.*]] = arith.constant 3 : i32
+ ! CHECK: %[[LOW:.*]] = arith.cmpi slt, %[[ORD]], %[[ONE]] : i32
+ ! CHECK: %[[HIGH:.*]] = arith.cmpi sgt, %[[ORD]], %[[MAX]] : i32
+ ! CHECK: %[[OOR:.*]] = arith.ori %[[LOW]], %[[HIGH]] : i1
+ ! CHECK: fir.if %[[OOR]] {
+ ! CHECK: fir.call @{{.*}}ReportFatalUserError
+ ! CHECK: }
+ ! CHECK: hlfir.assign %[[ORD]]
+ c = color(i)
+end subroutine
+
! -----------------------------------------------------------------------------
! Test enumeration comparisons (relational operators)
! -----------------------------------------------------------------------------
@@ -115,10 +145,10 @@ subroutine test_next(c)
type(color) :: result
integer :: stat
! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
- ! Compute: min(ordinal + 1, 3)
- ! CHECK: %[[ONE:.*]] = arith.constant 1 : i32
+ ! Compute: min(ordinal + 1, 3). Constants are hoisted, so match order-free.
+ ! CHECK-DAG: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK-DAG: %[[MAX:.*]] = arith.constant 3 : i32
! CHECK: %[[INC:.*]] = arith.addi %[[ORD]], %[[ONE]] : i32
- ! CHECK: %[[MAX:.*]] = arith.constant 3 : i32
! CHECK: %[[CMP:.*]] = arith.cmpi sle, %[[INC]], %[[MAX]] : i32
! CHECK: %[[RES:.*]] = arith.select %[[CMP]], %[[INC]], %[[MAX]] : i32
! Boundary check: ordinal == 3
@@ -203,10 +233,6 @@ subroutine test_select_case(c)
end select
end subroutine
-! -----------------------------------------------------------------------------
-! Test enumeration dummy argument passing
-! -----------------------------------------------------------------------------
-
! -----------------------------------------------------------------------------
! Test formatted WRITE of enumeration value
! -----------------------------------------------------------------------------
@@ -239,6 +265,41 @@ subroutine test_formatted_read(c)
read(*, '(I4)') c
end subroutine
+! -----------------------------------------------------------------------------
+! Test enumeration type as a function result
+! -----------------------------------------------------------------------------
+
+! An enumeration result lowers to i32 and is returned by value like an integer;
+! it must not use the caller-allocated fir.save_result ABI reserved for
+! record-shaped derived results.
+
+module enum_func_mod
+ enumeration type :: color2
+ enumerator :: c2red, c2green, c2blue
+ end enumeration type
+contains
+ ! CHECK-LABEL: func.func @_QMenum_func_modPpick() -> i32
+ function pick() result(c)
+ type(color2) :: c
+ c = c2blue
+ end function
+end module
+
+! CHECK-LABEL: func.func @_QPtest_func_result()
+subroutine test_func_result()
+ use enum_func_mod
+ type(color2) :: c
+ logical :: l
+ ! Result returned by value as i32, with no fir.save_result.
+ ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick() {{.*}}: () -> i32
+ ! CHECK-NOT: fir.save_result
+ ! CHECK: hlfir.assign %[[RES]]
+ c = pick()
+ ! The result is a genuine enumeration value: comparison lowers to i32 cmpi.
+ ! CHECK: arith.cmpi eq, %{{.*}}, %{{.*}} : i32
+ l = (c == c2blue)
+end subroutine
+
! -----------------------------------------------------------------------------
! Test enumeration dummy argument passing
! -----------------------------------------------------------------------------
>From f158029acaa1388a9321d515e17e611aac5d37b8 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Tue, 22 Sep 2026 14:51:11 -0500
Subject: [PATCH 06/11] Another bug fix
---
flang/lib/Semantics/check-io.cpp | 66 ++++++----
flang/test/Lower/enumeration-type.f90 | 116 ++++++++++++++++++
.../io-unsafe-direct-component-pdt-order.f90 | 109 ++++++++++++++++
3 files changed, 270 insertions(+), 21 deletions(-)
create mode 100644 flang/test/Semantics/io-unsafe-direct-component-pdt-order.f90
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index bc9181592aeb5..ded4bb342d6a6 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -1184,43 +1184,67 @@ using VisitedSymbolSet = std::unordered_set<const Symbol *>;
// Seeks out an allocatable or pointer ultimate component that is not
// nested in a nonallocatable/nonpointer component with a specific defined I/O
-// procedure. The 'visited' set tracks derived types to break cycles caused by
-// an illegal recursive type definition (F2023 C749).
+// procedure.
+//
+// The walk is memoized on the *instantiated scope* (derived.scope()), the key
+// that distinguishes two parameterized-derived-type instantiations sharing one
+// type symbol -- their defined-I/O shielding (HasDefinedIo) is decided per
+// instantiation. Keying on the type symbol instead, with a set that is never
+// erased on unwind, made the result order-dependent: once the shared type
+// symbol was marked visited while walking a shielded instantiation, an
+// unshielded sibling instantiation was pruned and its unsafe component missed.
+// This is a two-color DFS: 'onPath' holds the scopes on the recursion stack
+// (a repeat entry is a back edge from a recursive type and is pruned without
+// caching), and 'cache' memoizes each fully-walked subtree.
+using UnsafeComponentPathSet = std::unordered_set<const Scope *>;
+using UnsafeComponentCache = std::unordered_map<const Scope *, const Symbol *>;
+
static const Symbol *FindUnsafeIoDirectComponent(common::DefinedIo which,
const DerivedTypeSpec &derived, const Scope &scope,
- VisitedSymbolSet &visited) {
+ UnsafeComponentPathSet &onPath, UnsafeComponentCache &cache) {
if (HasDefinedIo(which, derived, &scope)) {
return nullptr;
}
- if (!visited.insert(&derived.typeSymbol()).second) {
+ const Scope *dtScope{derived.scope()};
+ if (!dtScope) {
return nullptr;
}
- if (const Scope * dtScope{derived.scope()}) {
- for (const auto &pair : *dtScope) {
- const Symbol &symbol{*pair.second};
- if (IsAllocatableOrPointer(symbol)) {
- return &symbol;
- }
- if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
- if (const DeclTypeSpec * type{details->type()}) {
- if (type->category() == DeclTypeSpec::Category::TypeDerived) {
- const DerivedTypeSpec &componentDerived{type->derivedTypeSpec()};
- if (const Symbol *bad{FindUnsafeIoDirectComponent(
- which, componentDerived, scope, visited)}) {
- return bad;
- }
+ if (auto it{cache.find(dtScope)}; it != cache.end()) {
+ return it->second;
+ }
+ if (!onPath.insert(dtScope).second) {
+ return nullptr; // cycle: prune without caching
+ }
+ const Symbol *result{nullptr};
+ for (const auto &pair : *dtScope) {
+ const Symbol &symbol{*pair.second};
+ if (IsAllocatableOrPointer(symbol)) {
+ result = &symbol;
+ break;
+ }
+ if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (const DeclTypeSpec *type{details->type()}) {
+ if (type->category() == DeclTypeSpec::Category::TypeDerived) {
+ const DerivedTypeSpec &componentDerived{type->derivedTypeSpec()};
+ if (const Symbol *bad{FindUnsafeIoDirectComponent(
+ which, componentDerived, scope, onPath, cache)}) {
+ result = bad;
+ break;
}
}
}
}
}
- return nullptr;
+ onPath.erase(dtScope);
+ cache.emplace(dtScope, result);
+ return result;
}
static const Symbol *FindUnsafeIoDirectComponent(common::DefinedIo which,
const DerivedTypeSpec &derived, const Scope &scope) {
- VisitedSymbolSet visited;
- return FindUnsafeIoDirectComponent(which, derived, scope, visited);
+ UnsafeComponentPathSet onPath;
+ UnsafeComponentCache cache;
+ return FindUnsafeIoDirectComponent(which, derived, scope, onPath, cache);
}
// For a type that does not have a defined I/O subroutine, finds a direct
diff --git a/flang/test/Lower/enumeration-type.f90 b/flang/test/Lower/enumeration-type.f90
index c6488474af415..66b5710f14c68 100644
--- a/flang/test/Lower/enumeration-type.f90
+++ b/flang/test/Lower/enumeration-type.f90
@@ -320,3 +320,119 @@ subroutine take_enum(c)
use enum_mod
type(color), intent(in) :: c
end subroutine
+
+! -----------------------------------------------------------------------------
+! Test enumeration-typed scalar PARAMETER
+! -----------------------------------------------------------------------------
+
+! A named constant of enumeration type must lower to an i32 constant, not a
+! record type (previously asserted on cast<fir::RecordType> in ConvertConstant).
+
+! CHECK-LABEL: func.func @_QPtest_enum_parameter()
+subroutine test_enum_parameter()
+ use enum_mod
+ type(color), parameter :: cRed = red
+ type(color) :: c
+ ! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QFtest_enum_parameterECcred"} : (!fir.ref<i32>)
+ ! CHECK: %[[C1:.*]] = arith.constant 1 : i32
+ ! CHECK: hlfir.assign %[[C1]]
+ c = cRed
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test enumeration array constructor
+! -----------------------------------------------------------------------------
+
+! An array constructor of enumerators must lower to an i32 array constant, not a
+! record-typed array (previously asserted on cast<fir::RecordType>).
+
+! CHECK-LABEL: func.func @_QPtest_array_constructor()
+subroutine test_array_constructor()
+ use enum_mod
+ type(color) :: arr(3)
+ ! CHECK: %[[RO:.*]] = fir.address_of(@_QQro.3x_QMenum_modTcolor.{{[0-9]+}}) : !fir.ref<!fir.array<3xi32>>
+ ! CHECK: hlfir.declare %[[RO]]
+ ! CHECK: hlfir.assign
+ arr = [red, green, blue]
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test enumeration array PARAMETER
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_array_parameter()
+subroutine test_array_parameter()
+ use enum_mod
+ type(color), parameter :: pal(3) = [red, green, blue]
+ type(color) :: arr(3)
+ ! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QFtest_array_parameterECpal"} : (!fir.ref<!fir.array<3xi32>>, !fir.shape<1>)
+ ! CHECK: hlfir.assign
+ arr = pal
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() over a whole array (elemental)
+! -----------------------------------------------------------------------------
+
+! NEXT()/PREVIOUS() applied to an array argument lower to an hlfir.elemental over
+! i32 ordinals (previously asserted on getIntOrFloatBitWidth for the array case).
+
+! CHECK-LABEL: func.func @_QPtest_next_array(
+subroutine test_next_array(arr)
+ use enum_mod
+ type(color), intent(in) :: arr(3)
+ type(color) :: narr(3)
+ integer :: stat(3)
+ ! Value elemental: min(ordinal + 1, 3).
+ ! CHECK: hlfir.elemental %{{.*}} unordered : (!fir.shape<1>) -> !hlfir.expr<3xi32> {
+ ! CHECK: %[[ELE:.*]] = hlfir.designate %{{.*}} : (!fir.ref<!fir.array<3xi32>>, index) -> !fir.ref<i32>
+ ! CHECK: %[[ORD:.*]] = fir.load %[[ELE]] : !fir.ref<i32>
+ ! CHECK-DAG: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK-DAG: %[[MAX:.*]] = arith.constant 3 : i32
+ ! CHECK: %[[INC:.*]] = arith.addi %[[ORD]], %[[ONE]] : i32
+ ! CHECK: %[[CMP:.*]] = arith.cmpi sle, %[[INC]], %[[MAX]] : i32
+ ! CHECK: %[[SEL:.*]] = arith.select %[[CMP]], %[[INC]], %[[MAX]] : i32
+ ! CHECK: hlfir.yield_element %[[SEL]] : i32
+ ! STAT elemental: 112 at the last enumerator, else 0.
+ ! CHECK: hlfir.elemental %{{.*}} unordered : (!fir.shape<1>) -> !hlfir.expr<3xi32> {
+ ! CHECK: arith.cmpi eq, %{{.*}}, %{{.*}} : i32
+ ! CHECK-DAG: arith.constant 112 : i32
+ ! CHECK-DAG: arith.constant 0 : i32
+ ! CHECK: arith.select
+ ! CHECK: hlfir.yield_element
+ narr = next(arr, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test PREVIOUS() over a whole array (elemental)
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_previous_array(
+subroutine test_previous_array(arr)
+ use enum_mod
+ type(color), intent(in) :: arr(3)
+ type(color) :: parr(3)
+ integer :: stat(3)
+ ! Value elemental: max(ordinal - 1, 1).
+ ! CHECK: hlfir.elemental %{{.*}} unordered : (!fir.shape<1>) -> !hlfir.expr<3xi32> {
+ ! CHECK: %[[ELE:.*]] = hlfir.designate %{{.*}} : (!fir.ref<!fir.array<3xi32>>, index) -> !fir.ref<i32>
+ ! CHECK: %[[ORD:.*]] = fir.load %[[ELE]] : !fir.ref<i32>
+ ! CHECK: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK: %[[DEC:.*]] = arith.subi %[[ORD]], %[[ONE]] : i32
+ ! CHECK: %[[CMP:.*]] = arith.cmpi sge, %[[DEC]], %[[ONE]] : i32
+ ! CHECK: %[[SEL:.*]] = arith.select %[[CMP]], %[[DEC]], %[[ONE]] : i32
+ ! CHECK: hlfir.yield_element %[[SEL]] : i32
+ parr = previous(arr, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Verify the enum array constructor constant is i32 ordinals 1,2,3
+! -----------------------------------------------------------------------------
+
+! CHECK: fir.global internal @_QQro.3x_QMenum_modTcolor.{{[0-9]+}} {{.*}}constant : !fir.array<3xi32> {
+! CHECK: %[[G1:.*]] = arith.constant 1 : i32
+! CHECK: fir.insert_value %{{.*}}, %[[G1]], [0 : index]
+! CHECK: %[[G2:.*]] = arith.constant 2 : i32
+! CHECK: fir.insert_value %{{.*}}, %[[G2]], [1 : index]
+! CHECK: %[[G3:.*]] = arith.constant 3 : i32
+! CHECK: fir.insert_value %{{.*}}, %[[G3]], [2 : index]
diff --git a/flang/test/Semantics/io-unsafe-direct-component-pdt-order.f90 b/flang/test/Semantics/io-unsafe-direct-component-pdt-order.f90
new file mode 100644
index 0000000000000..bba4d65acf033
--- /dev/null
+++ b/flang/test/Semantics/io-unsafe-direct-component-pdt-order.f90
@@ -0,0 +1,109 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+!
+! Regression test for the order-dependent visited-set bug in
+! FindUnsafeIoDirectComponent (flang/lib/Semantics/check-io.cpp). A derived
+! type used in unformatted I/O may not have an allocatable or pointer direct
+! component unless it is processed by defined I/O. The check memoizes its walk;
+! keying that memo on the shared type symbol (never erased on unwind) let a
+! shielded parameterized-derived-type instantiation prune an unshielded sibling
+! instantiation, silently suppressing the error. The walk is now memoized on
+! the instantiated scope, so the error surfaces regardless of traversal order.
+
+module unsafe_pdt_order_mod
+ type :: leaf(k)
+ integer, kind :: k = 2
+ real, allocatable :: a(:) ! the unsafe direct component
+ end type
+
+ type :: branch(k)
+ integer, kind :: k = 2
+ type(leaf(k)) :: item
+ end type
+
+ ! Defined unformatted output for leaf(1) ONLY, so branch(1) is shielded and
+ ! branch(2) is not.
+ interface write(unformatted)
+ module procedure wleaf1
+ end interface
+
+ ! Scope iterates components in SourceName (alphabetical) order, not
+ ! declaration order. The three containers pin down both traversal orders so
+ ! the test does not silently depend on the component names chosen:
+ ! - In `container`, the shielded branch(1) sorts first (a_safe < b_bad).
+ ! - In `container_rev`, the unshielded branch(2) sorts first (a_bad <
+ ! b_safe).
+ ! - In `container_rev_decl`, the failing branch(2) is declared first but
+ ! sorts last (a_safe < b_bad), so declaration order and traversal order
+ ! disagree and the error must still surface.
+ type :: container
+ type(branch(1)) :: a_safe
+ type(branch(2)) :: b_bad
+ end type
+
+ type :: container_rev
+ type(branch(1)) :: b_safe
+ type(branch(2)) :: a_bad
+ end type
+
+ type :: container_rev_decl
+ type(branch(2)) :: b_bad
+ type(branch(1)) :: a_safe
+ end type
+
+contains
+ subroutine wleaf1(dtv, unit, iostat, iomsg)
+ class(leaf(1)), intent(in) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(*), intent(in out) :: iomsg
+ write(unit, iostat=iostat, iomsg=iomsg) size(dtv%a)
+ end subroutine
+
+ ! Positive control A: a lone shielded instantiation. leaf(1) has matching
+ ! defined unformatted output, so branch(1) is shielded and NO error is
+ ! expected.
+ subroutine test_shielded(u)
+ integer, intent(in) :: u
+ type(branch(1)) :: x
+ write(u) x
+ end subroutine
+
+ ! Positive control B: a lone UNSHIELDED instantiation. leaf(2) has no
+ ! matching defined unformatted output, so its allocatable direct component is
+ ! reached and the write is rejected. This proves the branch(2)/leaf(2)
+ ! subtree really is detectable on its own.
+ subroutine test_unshielded(u)
+ integer, intent(in) :: u
+ type(branch(2)) :: y
+ !ERROR: Derived type 'branch' in I/O cannot have an allocatable or pointer direct component 'a' unless using defined I/O
+ write(u) y
+ end subroutine
+
+ ! The order-dependence: the shielded branch(1) is visited first, but the
+ ! unshielded branch(2) must still be flagged.
+ subroutine test_order_bug(u)
+ integer, intent(in) :: u
+ type(container) :: z
+ !ERROR: Derived type 'container' in I/O cannot have an allocatable or pointer direct component 'a' unless using defined I/O
+ write(u) z
+ end subroutine
+
+ ! Same as above, but the unshielded branch(2) is visited first in SourceName
+ ! order. The error must still be emitted regardless of traversal order.
+ subroutine test_order_bug_rev(u)
+ integer, intent(in) :: u
+ type(container_rev) :: z
+ !ERROR: Derived type 'container_rev' in I/O cannot have an allocatable or pointer direct component 'a' unless using defined I/O
+ write(u) z
+ end subroutine
+
+ ! Failing branch(2) is declared first but sorts last (a_safe < b_bad), so it
+ ! is visited last; the error must still be emitted regardless of the mismatch
+ ! between declaration order and traversal order.
+ subroutine test_order_bug_rev_decl(u)
+ integer, intent(in) :: u
+ type(container_rev_decl) :: z
+ !ERROR: Derived type 'container_rev_decl' in I/O cannot have an allocatable or pointer direct component 'a' unless using defined I/O
+ write(u) z
+ end subroutine
+end module
>From 3775852f2f20dc11195450050239178ca6194f28 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Wed, 23 Sep 2026 12:37:23 -0500
Subject: [PATCH 07/11] - Added additional tests to fully cover feature
semantics. - Corrected bug detected by those tests that allowed duplicate
enumerator names.
---
flang/lib/Semantics/resolve-names.cpp | 9 +++-
.../enumeration-type-component-offset.f90 | 21 ++++++++
.../enumeration-type-component-usage.f90 | 23 ++++++++
.../enumeration-type-declarations.f90 | 36 +++++++++++++
.../enumeration-type-explicit-value.f90 | 12 +++++
.../test/Semantics/enumeration-type-misc.f90 | 52 +++++++++++++++++++
6 files changed, 152 insertions(+), 1 deletion(-)
create mode 100644 flang/test/Semantics/enumeration-type-component-offset.f90
create mode 100644 flang/test/Semantics/enumeration-type-component-usage.f90
create mode 100644 flang/test/Semantics/enumeration-type-explicit-value.f90
create mode 100644 flang/test/Semantics/enumeration-type-misc.f90
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 3d06f7d1fa495..30c7b5510fe63 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6571,7 +6571,7 @@ void DeclarationVisitor::Post(const parser::EnumerationTypeStmt &x) {
// each enumerator name in the enclosing scope with 1-based ordinal init.
bool DeclarationVisitor::Pre(const parser::EnumerationEnumeratorStmt &x) {
Scope &enclosingScope{NonDerivedTypeScope()};
- // The current DerivedType scope's symbol is the enumeration type.
+ // The current DerivedType scope's symbol is the enumeration type.y
Symbol *typeSymbol{currScope().symbol()};
CHECK(typeSymbol);
auto &typeDetails{typeSymbol->get<DerivedTypeDetails>()};
@@ -6581,6 +6581,13 @@ bool DeclarationVisitor::Pre(const parser::EnumerationEnumeratorStmt &x) {
DeclTypeSpec &declType{enclosingScope.MakeDerivedType(
DeclTypeSpec::TypeDerived, std::move(enumTypeSpec))};
for (const parser::Name &name : x.v) {
+ // A repeated enumerator name would make MakeSymbol return the existing
+ // symbol, whose set_details() below would then abort.
+ if (Symbol *prev{FindInScope(enclosingScope, name.source)};
+ prev && !prev->has<UnknownDetails>()) {
+ SayAlreadyDeclared(name, *prev);
+ continue;
+ }
int ordinal{typeDetails.enumeratorCount() + 1};
// Create the enumerator symbol in the enclosing scope, not the
// enumeration type's own DerivedType scope.
diff --git a/flang/test/Semantics/enumeration-type-component-offset.f90 b/flang/test/Semantics/enumeration-type-component-offset.f90
new file mode 100644
index 0000000000000..26928798d1d2d
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-component-offset.f90
@@ -0,0 +1,21 @@
+! RUN: %flang_fc1 -fdebug-dump-symbols -fenumeration-type %s 2>&1 | FileCheck %s
+! Regression test: a derived type with an enumeration-type component must be
+! correctly sized once the enclosing type is instantiated (which happens as
+! soon as a variable of it is declared). Previously the enumeration component
+! collapsed to size 0 / offset 0, freezing the enclosing type at size 0.
+
+subroutine test_enum_component_offset()
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+ type :: holder
+ integer :: n
+ type(color) :: c
+ end type
+ ! Declaring a variable of 'holder' instantiates it.
+ type(holder) :: h
+ ! CHECK: h size=8 offset={{[0-9]+}}: ObjectEntity type: TYPE(holder)
+ ! CHECK: DerivedType scope: holder size=8 alignment=4
+ ! CHECK: c size=4 offset=4: ObjectEntity type: TYPE(color)
+ ! CHECK: n size=4 offset=0: ObjectEntity type: INTEGER(4)
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-component-usage.f90 b/flang/test/Semantics/enumeration-type-component-usage.f90
new file mode 100644
index 0000000000000..55d2595f33600
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-component-usage.f90
@@ -0,0 +1,23 @@
+! RUN: %flang_fc1 -fsyntax-only -fenumeration-type %s
+! An enumeration type used as a derived-type component: default component
+! initialization, whole-structure assignment, component assignment, use of the
+! component in a relational, and arrays of the containing type must all compile.
+
+subroutine test_enum_component_usage()
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+ type :: holder
+ integer :: n = 0
+ type(color) :: c = red ! default component initializer
+ end type
+ type(holder) :: a, b
+ type(holder) :: arr(2)
+ logical :: l
+
+ b = a ! whole-structure assignment
+ a%c = green ! component assignment
+ l = (a%c == green) ! component in a relational
+ arr(1)%c = blue ! array element component
+ arr(2) = a ! whole-element assignment
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-declarations.f90 b/flang/test/Semantics/enumeration-type-declarations.f90
index 3f7aa12536ac2..a4d084728bf5e 100644
--- a/flang/test/Semantics/enumeration-type-declarations.f90
+++ b/flang/test/Semantics/enumeration-type-declarations.f90
@@ -128,3 +128,39 @@ subroutine test_constructor_errors_use()
! ERROR: Enumeration constructor value (4) for 'color' must be positive and less than or equal to the number of enumerators (3)
c = color(4)
end subroutine
+
+! A duplicate enumerator name within an enumeration type is diagnosed as a
+! clean semantic error (previously it aborted during name resolution).
+subroutine test_duplicate_enumerator()
+ !WARNING: ENUMERATION TYPE support is incomplete and should be enabled only for testing
+ enumeration type :: color
+ !ERROR: 'red' is already declared in this scoping unit
+ enumerator :: red, green, red
+ end enumeration type
+end subroutine
+
+! An enumeration type has no implicit conversion to or from INTEGER, and is not
+! numeric: assignment and arithmetic mixing an enumeration value with an
+! integer (or two enumeration values) must be rejected.
+subroutine test_assignment_and_arithmetic()
+ !WARNING: ENUMERATION TYPE support is incomplete and should be enabled only for testing
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+ type(color) :: c
+ integer :: i
+
+ ! No implicit enumeration -> integer conversion (use INT()).
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types INTEGER(4) and TYPE(color)
+ i = red
+
+ ! No implicit integer -> enumeration conversion (use the constructor).
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(color) and INTEGER(4)
+ c = 1
+
+ ! Enumeration values are not numeric.
+ !ERROR: Operands of + must be numeric; have TYPE(color) and INTEGER(4)
+ i = red + 1
+ !ERROR: Operands of + must be numeric; have TYPE(color) and TYPE(color)
+ c = red + green
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-explicit-value.f90 b/flang/test/Semantics/enumeration-type-explicit-value.f90
new file mode 100644
index 0000000000000..be88caed31eef
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-explicit-value.f90
@@ -0,0 +1,12 @@
+! RUN: not %flang_fc1 -fsyntax-only -fenumeration-type %s 2>&1 | FileCheck %s
+! F2023 enumeration types do not permit explicit enumerator values (unlike the
+! ENUM, BIND(C) construct). 'enumerator :: red = 1' must be rejected.
+! NOTE: the expected message is a placeholder; update it to match the real
+! diagnostic if it differs.
+
+subroutine test_explicit_value()
+ ! CHECK: error: expected end of statement
+ enumeration type :: color
+ enumerator :: red = 1, green, blue
+ end enumeration type
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-misc.f90 b/flang/test/Semantics/enumeration-type-misc.f90
new file mode 100644
index 0000000000000..3c99682e8a690
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-misc.f90
@@ -0,0 +1,52 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -fenumeration-type
+! Miscellaneous enumeration-type use cases: a single-enumerator type, MERGE over
+! enumeration values, and enumeration-type argument association.
+
+module enum_misc_mod
+ !WARNING: ENUMERATION TYPE support is incomplete and should be enabled only for testing
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+
+ !WARNING: ENUMERATION TYPE support is incomplete and should be enabled only for testing
+ enumeration type :: direction
+ enumerator :: north, south
+ end enumeration type
+
+ !WARNING: ENUMERATION TYPE support is incomplete and should be enabled only for testing
+ enumeration type :: single
+ enumerator :: only
+ end enumeration type
+
+contains
+ ! Valid: a single-enumerator type.
+ subroutine test_single()
+ type(single) :: x
+ x = only
+ end subroutine
+
+ ! Valid: MERGE selects between two enumerators of the same type.
+ subroutine test_merge()
+ type(color) :: c
+ c = merge(red, green, .true.)
+ end subroutine
+
+ subroutine take_color(c)
+ type(color), intent(in) :: c
+ end subroutine
+
+ ! Valid: passing a matching enumeration type.
+ subroutine test_arg_ok()
+ type(color) :: c
+ c = red
+ call take_color(c)
+ end subroutine
+
+ ! A different enumeration type is not compatible with the dummy argument.
+ subroutine test_arg_mismatch()
+ type(direction) :: d
+ d = north
+ !ERROR: Actual argument type 'direction' is not compatible with dummy argument type 'color'
+ call take_color(d)
+ end subroutine
+end module
>From 944f8481ceee442e70e10eabcfc5d708faf8af4d Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Wed, 23 Sep 2026 15:23:07 -0500
Subject: [PATCH 08/11] Addressing AI review identified issues.
---
flang/lib/Lower/CallInterface.cpp | 11 +-
flang/lib/Lower/ConvertExprToHLFIR.cpp | 163 +++++++++++++++++--------
flang/test/Lower/enumeration-type.f90 | 104 ++++++++++++++++
3 files changed, 219 insertions(+), 59 deletions(-)
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index fc620a507ca82..2e50d204cd518 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1175,9 +1175,8 @@ class Fortran::lower::CallInterfaceImpl {
}
}
- // An F2023 enumeration type has Derived category but lowers to i32 and is
- // returned by value like an integer, so it must not use the caller-allocated
- // fir.save_result ABI reserved for record-shaped results.
+ // An F2023 enumeration type has Derived category but lowers to i32, so a
+ // scalar enumeration result is returned by value like an integer.
static bool
isEnumerationDerived(const Fortran::evaluate::DynamicType &dynamicType) {
// GetDerivedTypeSpec() is null-safe: it yields nullptr for polymorphic and
@@ -1410,10 +1409,8 @@ class Fortran::lower::CallInterfaceImpl {
addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
Property::Value);
// Explicit results require the caller to allocate the storage and save the
- // function result in the storage with a fir.save_result. Enumeration
- // results lower to i32 and are returned by value, so they are exempt.
- if (!isEnumerationDerived(typeAndShape->type()))
- setSaveResult();
+ // function result in the storage with a fir.save_result.
+ setSaveResult();
}
// Return nullopt for scalars, empty vector for assumed rank, and a vector
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index 0907442be20c6..46f5f11c51375 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -1775,6 +1775,67 @@ class HlfirBuilder {
return {derived, count};
}
+ // Return the syntactically supplied STAT expression of NEXT/PREVIOUS, or
+ // nullptr if none was written.
+ const Fortran::lower::SomeExpr *getEnumerationStatExpr(
+ const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
+ &expr) {
+ if (expr.arguments().size() < 2 || !expr.arguments()[1])
+ return nullptr;
+ const auto *statExpr = expr.arguments()[1]->UnwrapExpr();
+ assert(statExpr && "STAT argument must be an expression");
+ return statExpr;
+ }
+
+ // Return an i1 telling whether STAT is present at runtime, or a null value
+ // if it is always present. An absent optional dummy or an unallocated or
+ // disassociated allocatable/pointer actual makes STAT not present.
+ mlir::Value
+ genEnumerationStatIsPresent(const Fortran::lower::SomeExpr &statExpr,
+ hlfir::Entity stat) {
+ if (!Fortran::evaluate::MayBePassedAsAbsentOptional(statExpr))
+ return {};
+ mlir::Location loc = getLoc();
+ fir::FirOpBuilder &builder = getBuilder();
+ if (Fortran::evaluate::IsAllocatableOrPointerObject(statExpr))
+ return builder.genIsNotNullAddr(
+ loc, hlfir::genVariableRawAddress(loc, builder, stat));
+ return fir::IsPresentOp::create(builder, loc, builder.getI1Type(), stat)
+ .getResult();
+ }
+
+ // Emit genPresent() when STAT is present at runtime and genAbsent()
+ // otherwise. A null isPresent means STAT is always present.
+ template <typename PresentFn, typename AbsentFn>
+ void genIfEnumerationStatPresent(mlir::Value isPresent, PresentFn genPresent,
+ AbsentFn genAbsent) {
+ if (!isPresent) {
+ genPresent();
+ return;
+ }
+ fir::FirOpBuilder &builder = getBuilder();
+ auto ifOp = fir::IfOp::create(builder, getLoc(), {}, isPresent,
+ /*withElseRegion=*/true);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ genPresent();
+ builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
+ genAbsent();
+ builder.setInsertionPointAfter(ifOp);
+ }
+
+ // Error termination if cond (i1) is true; used when STAT is not present.
+ void genEnumerationBoundaryFatal(mlir::Value cond) {
+ mlir::Location loc = getLoc();
+ fir::FirOpBuilder &builder = getBuilder();
+ auto ifOp = fir::IfOp::create(builder, loc, {}, cond,
+ /*withElseRegion=*/false);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ fir::runtime::genReportFatalUserError(
+ builder, loc,
+ "NEXT or PREVIOUS of enumeration type at boundary without STAT=");
+ builder.setInsertionPointAfter(ifOp);
+ }
+
// Helper to lower STAT argument handling for NEXT/PREVIOUS.
// atBoundary is a boolean indicating whether the boundary condition was hit.
void genEnumerationStatHandling(
@@ -1783,12 +1844,15 @@ class HlfirBuilder {
mlir::Value atBoundary, mlir::Type resType) {
mlir::Location loc = getLoc();
fir::FirOpBuilder &builder = getBuilder();
- if (expr.arguments().size() >= 2 && expr.arguments()[1]) {
- // STAT is present — assign 0 or FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY (112)
- const auto *statExpr = expr.arguments()[1]->UnwrapExpr();
- assert(statExpr && "STAT argument must be an expression");
- hlfir::Entity statAddr = Fortran::lower::convertExprToHLFIR(
- loc, converter, *statExpr, getSymMap(), getStmtCtx());
+ const Fortran::lower::SomeExpr *statExpr = getEnumerationStatExpr(expr);
+ if (!statExpr) {
+ genEnumerationBoundaryFatal(atBoundary);
+ return;
+ }
+ hlfir::Entity statAddr = Fortran::lower::convertExprToHLFIR(
+ loc, converter, *statExpr, getSymMap(), getStmtCtx());
+ auto genStatAssign = [&]() {
+ // Assign 0 or FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY (112).
mlir::Type statType = statAddr.getFortranElementType();
mlir::Value boundaryConst = builder.createIntegerConstant(
loc, statType, 112 /* FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY */);
@@ -1796,16 +1860,10 @@ class HlfirBuilder {
mlir::Value statVal = mlir::arith::SelectOp::create(
builder, loc, atBoundary, boundaryConst, zeroConst);
hlfir::AssignOp::create(builder, loc, statVal, statAddr);
- } else {
- // STAT absent — error termination if at boundary
- auto ifOp = fir::IfOp::create(builder, loc, {}, atBoundary,
- /*withElseRegion=*/false);
- builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
- fir::runtime::genReportFatalUserError(
- builder, loc,
- "NEXT or PREVIOUS of enumeration type at boundary without STAT=");
- builder.setInsertionPointAfter(ifOp);
- }
+ };
+ genIfEnumerationStatPresent(
+ genEnumerationStatIsPresent(*statExpr, statAddr), genStatAssign,
+ [&]() { genEnumerationBoundaryFatal(atBoundary); });
}
// Compute the per-element NEXT/PREVIOUS result and boundary flag from a
@@ -1869,33 +1927,8 @@ class HlfirBuilder {
getStmtCtx().attachCleanup(
[=]() { hlfir::DestroyOp::create(*bldr, loc, resultElem); });
- if (expr.arguments().size() >= 2 && expr.arguments()[1]) {
- // STAT present: elementwise 0/112 into the conformable STAT array.
- const auto *statExpr = expr.arguments()[1]->UnwrapExpr();
- assert(statExpr && "STAT argument must be an expression");
- hlfir::Entity statEntity = Fortran::lower::convertExprToHLFIR(
- loc, converter, *statExpr, getSymMap(), getStmtCtx());
- mlir::Type statType = statEntity.getFortranElementType();
- auto statKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
- mlir::ValueRange idx) -> hlfir::Entity {
- mlir::Value ordinal =
- hlfir::loadTrivialScalar(l, b, hlfir::getElementAt(l, b, arg, idx));
- auto [result, atBoundary] =
- genEnumOrdinalStep(b, l, ordinal, eleTy, count, isNext);
- (void)result;
- mlir::Value boundaryConst = b.createIntegerConstant(l, statType, 112);
- mlir::Value zeroConst = b.createIntegerConstant(l, statType, 0);
- return hlfir::Entity{mlir::arith::SelectOp::create(
- b, l, atBoundary, boundaryConst, zeroConst)};
- };
- mlir::Value statElem = hlfir::genElementalOp(
- loc, builder, statType, shape, /*typeParams=*/{}, statKernel,
- /*isUnordered=*/true);
- hlfir::AssignOp::create(builder, loc, statElem, statEntity);
- getStmtCtx().attachCleanup(
- [=]() { hlfir::DestroyOp::create(*bldr, loc, statElem); });
- } else {
- // STAT absent: error termination if any element is at a boundary.
+ // STAT not present: error termination if any element is at a boundary.
+ auto genBoundaryFatal = [&]() {
mlir::Type logType = fir::LogicalType::get(builder.getContext(), 4);
auto maskKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
mlir::ValueRange idx) -> hlfir::Entity {
@@ -1912,17 +1945,43 @@ class HlfirBuilder {
mlir::Value anyBoundary =
hlfir::AnyOp::create(builder, loc, logType, mask,
/*dim=*/mlir::Value{});
- mlir::Value cond =
- builder.createConvert(loc, builder.getI1Type(), anyBoundary);
- auto ifOp = fir::IfOp::create(builder, loc, {}, cond,
- /*withElseRegion=*/false);
- builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
- fir::runtime::genReportFatalUserError(
- builder, loc,
- "NEXT or PREVIOUS of enumeration type at boundary without STAT=");
- builder.setInsertionPointAfter(ifOp);
+ genEnumerationBoundaryFatal(
+ builder.createConvert(loc, builder.getI1Type(), anyBoundary));
hlfir::DestroyOp::create(builder, loc, mask);
+ };
+
+ const Fortran::lower::SomeExpr *statExpr = getEnumerationStatExpr(expr);
+ if (!statExpr) {
+ genBoundaryFatal();
+ return hlfir::EntityWithAttributes{resultElem};
}
+ hlfir::Entity statEntity = Fortran::lower::convertExprToHLFIR(
+ loc, converter, *statExpr, getSymMap(), getStmtCtx());
+ // STAT present: elementwise 0/112 into the conformable STAT array. The
+ // temporary is destroyed inline since it may live inside a fir.if region.
+ auto genStatAssign = [&]() {
+ mlir::Type statType = statEntity.getFortranElementType();
+ auto statKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
+ mlir::ValueRange idx) -> hlfir::Entity {
+ mlir::Value ordinal =
+ hlfir::loadTrivialScalar(l, b, hlfir::getElementAt(l, b, arg, idx));
+ auto [result, atBoundary] =
+ genEnumOrdinalStep(b, l, ordinal, eleTy, count, isNext);
+ (void)result;
+ mlir::Value boundaryConst = b.createIntegerConstant(l, statType, 112);
+ mlir::Value zeroConst = b.createIntegerConstant(l, statType, 0);
+ return hlfir::Entity{mlir::arith::SelectOp::create(
+ b, l, atBoundary, boundaryConst, zeroConst)};
+ };
+ mlir::Value statElem = hlfir::genElementalOp(
+ loc, builder, statType, shape, /*typeParams=*/{}, statKernel,
+ /*isUnordered=*/true);
+ hlfir::AssignOp::create(builder, loc, statElem, statEntity);
+ hlfir::DestroyOp::create(builder, loc, statElem);
+ };
+ genIfEnumerationStatPresent(
+ genEnumerationStatIsPresent(*statExpr, statEntity), genStatAssign,
+ genBoundaryFatal);
return hlfir::EntityWithAttributes{resultElem};
}
diff --git a/flang/test/Lower/enumeration-type.f90 b/flang/test/Lower/enumeration-type.f90
index 66b5710f14c68..63ba707be50c9 100644
--- a/flang/test/Lower/enumeration-type.f90
+++ b/flang/test/Lower/enumeration-type.f90
@@ -153,6 +153,8 @@ subroutine test_next(c)
! CHECK: %[[RES:.*]] = arith.select %[[CMP]], %[[INC]], %[[MAX]] : i32
! Boundary check: ordinal == 3
! CHECK: %[[BOUND:.*]] = arith.cmpi eq, %[[ORD]], %[[MAX]] : i32
+ ! A non-optional local STAT needs no runtime presence check.
+ ! CHECK-NOT: fir.is_present
! STAT handling: select 112 or 0
! CHECK: arith.constant 112
! CHECK: arith.constant 0
@@ -209,6 +211,49 @@ subroutine test_next_no_stat(c)
result = next(c)
end subroutine
+! -----------------------------------------------------------------------------
+! Test NEXT() with a STAT that may be absent at runtime
+! -----------------------------------------------------------------------------
+
+! An absent optional dummy (or unallocated allocatable) forwarded as STAT= is
+! not present: STAT must not be written and the boundary is a fatal error.
+
+! CHECK-LABEL: func.func @_QPtest_next_optional_stat(
+subroutine test_next_optional_stat(c, stat)
+ use enum_mod
+ type(color), intent(in) :: c
+ integer, optional, intent(out) :: stat
+ type(color) :: result
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_optional_statEstat"}
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: %[[PRES:.*]] = fir.is_present %[[STAT]]#0 : (!fir.ref<i32>) -> i1
+ ! CHECK: fir.if %[[PRES]] {
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign %{{.*}} to %[[STAT]]#0
+ ! CHECK: } else {
+ ! CHECK: fir.if %[[BOUND]] {
+ ! CHECK: fir.call @{{.*}}ReportFatalUserError
+ result = next(c, stat=stat)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_next_allocatable_stat(
+subroutine test_next_allocatable_stat(c, stat)
+ use enum_mod
+ type(color), intent(in) :: c
+ integer, allocatable, intent(inout) :: stat
+ type(color) :: result
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: fir.box_addr
+ ! CHECK: %[[PRES:.*]] = arith.cmpi ne
+ ! CHECK: fir.if %[[PRES]] {
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign
+ ! CHECK: } else {
+ ! CHECK: fir.if %[[BOUND]] {
+ ! CHECK: fir.call @{{.*}}ReportFatalUserError
+ result = next(c, stat=stat)
+end subroutine
+
! -----------------------------------------------------------------------------
! Test SELECT CASE with enumeration type
! -----------------------------------------------------------------------------
@@ -283,6 +328,16 @@ function pick() result(c)
type(color2) :: c
c = c2blue
end function
+ ! CHECK-LABEL: func.func @_QMenum_func_modPpick_array() -> !fir.array<3xi32>
+ function pick_array() result(c)
+ type(color2) :: c(3)
+ c = [c2red, c2green, c2blue]
+ end function
+ ! CHECK-LABEL: func.func @_QMenum_func_modPpick_alloc() -> !fir.box<!fir.heap<!fir.array<?xi32>>>
+ function pick_alloc() result(c)
+ type(color2), allocatable :: c(:)
+ c = [c2red, c2green, c2blue]
+ end function
end module
! CHECK-LABEL: func.func @_QPtest_func_result()
@@ -300,6 +355,30 @@ subroutine test_func_result()
l = (c == c2blue)
end subroutine
+! Non-scalar enumeration results (array, allocatable) use the normal
+! caller-allocated fir.save_result ABI, like integer arrays.
+
+! CHECK-LABEL: func.func @_QPtest_func_result_array()
+subroutine test_func_result_array()
+ use enum_func_mod
+ type(color2) :: c(3)
+ ! CHECK: hlfir.eval_in_mem {{.*}} -> !hlfir.expr<3xi32> {
+ ! CHECK: ^bb0(%[[TMP:.*]]: !fir.ref<!fir.array<3xi32>>):
+ ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick_array() {{.*}}: () -> !fir.array<3xi32>
+ ! CHECK: fir.save_result %[[RES]] to %[[TMP]]
+ c = pick_array()
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_func_result_alloc()
+subroutine test_func_result_alloc()
+ use enum_func_mod
+ type(color2), allocatable :: c(:)
+ ! CHECK: %[[TMP:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> {bindc_name = ".result"}
+ ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick_alloc() {{.*}}: () -> !fir.box<!fir.heap<!fir.array<?xi32>>>
+ ! CHECK: fir.save_result %[[RES]] to %{{.*}} : !fir.box<!fir.heap<!fir.array<?xi32>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+ c = pick_alloc()
+end subroutine
+
! -----------------------------------------------------------------------------
! Test enumeration dummy argument passing
! -----------------------------------------------------------------------------
@@ -425,6 +504,31 @@ subroutine test_previous_array(arr)
parr = previous(arr, stat=stat)
end subroutine
+! -----------------------------------------------------------------------------
+! Test NEXT() over an array with a STAT that may be absent
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_next_array_optional_stat(
+subroutine test_next_array_optional_stat(arr, stat)
+ use enum_mod
+ type(color), intent(in) :: arr(3)
+ integer, optional, intent(out) :: stat(3)
+ type(color) :: narr(3)
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_array_optional_statEstat"}
+ ! CHECK: hlfir.elemental
+ ! CHECK: %[[PRES:.*]] = fir.is_present %[[STAT]]#0 : (!fir.ref<!fir.array<3xi32>>) -> i1
+ ! CHECK: fir.if %[[PRES]] {
+ ! CHECK: %[[SE:.*]] = hlfir.elemental
+ ! CHECK: hlfir.assign %[[SE]] to %[[STAT]]#0
+ ! CHECK: hlfir.destroy %[[SE]]
+ ! CHECK: } else {
+ ! CHECK: %[[MASK:.*]] = hlfir.elemental
+ ! CHECK: hlfir.any %[[MASK]]
+ ! CHECK: fir.call @{{.*}}ReportFatalUserError
+ ! CHECK: hlfir.destroy %[[MASK]]
+ narr = next(arr, stat=stat)
+end subroutine
+
! -----------------------------------------------------------------------------
! Verify the enum array constructor constant is i32 ordinals 1,2,3
! -----------------------------------------------------------------------------
>From cf72b5809ad5c98eb1fdecf9f43da9d527e07755 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 24 Sep 2026 11:36:01 -0500
Subject: [PATCH 09/11] Corrected comments
---
flang/lib/Lower/ConvertExprToHLFIR.cpp | 12 +++++-------
flang/lib/Semantics/check-io.cpp | 12 +++---------
flang/lib/Semantics/resolve-names.cpp | 2 +-
.../Semantics/enumeration-type-component-offset.f90 | 3 +--
.../test/Semantics/enumeration-type-declarations.f90 | 2 +-
.../Semantics/enumeration-type-explicit-value.f90 | 2 --
flang/test/Semantics/enumeration-type-intrinsics.f90 | 4 ----
.../io-unsafe-direct-component-pdt-order.f90 | 2 +-
8 files changed, 12 insertions(+), 27 deletions(-)
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index 46f5f11c51375..f2ae7717935b3 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -2406,13 +2406,11 @@ class HlfirBuilder {
if (ordinal.getType() != ty)
ordinal = builder.createConvert(loc, ty, ordinal);
// F2023 7.6.2 para 5 requires the constructor value to be
- // positive and <= the number of enumerators. This is a plain
- // "shall" (not a numbered constraint), so the processor is not
- // required to detect a violation; the standard leaves the
- // behavior to the processor. We choose to always emit a runtime
- // range check with error termination. This block could be placed
- // behind an -fcheck=enum style flag if the community prefers an
- // opt-in implementation.
+ // positive and <= the number of enumerators. We choose to always
+ // emit a runtime range check with error termination. This block
+ // could be placed behind an -fcheck=enum style flag if the
+ // community prefers an opt-in implementation like gfortran's
+ // -fcheck=bounds.
int count = ctor.derivedTypeSpec()
.typeSymbol()
.GetUltimate()
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index ded4bb342d6a6..0e6b04087be45 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -1186,16 +1186,10 @@ using VisitedSymbolSet = std::unordered_set<const Symbol *>;
// nested in a nonallocatable/nonpointer component with a specific defined I/O
// procedure.
//
-// The walk is memoized on the *instantiated scope* (derived.scope()), the key
-// that distinguishes two parameterized-derived-type instantiations sharing one
-// type symbol -- their defined-I/O shielding (HasDefinedIo) is decided per
-// instantiation. Keying on the type symbol instead, with a set that is never
-// erased on unwind, made the result order-dependent: once the shared type
-// symbol was marked visited while walking a shielded instantiation, an
-// unshielded sibling instantiation was pruned and its unsafe component missed.
-// This is a two-color DFS: 'onPath' holds the scopes on the recursion stack
+// This is a two-color DFS to prevent missing unsafe components following a
+// shielded instantiation: 'onPath' holds the scopes on the recursion stack
// (a repeat entry is a back edge from a recursive type and is pruned without
-// caching), and 'cache' memoizes each fully-walked subtree.
+// caching), and 'cache' memorizes each fully-walked subtree.
using UnsafeComponentPathSet = std::unordered_set<const Scope *>;
using UnsafeComponentCache = std::unordered_map<const Scope *, const Symbol *>;
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 30c7b5510fe63..e48de9c4b410c 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6571,7 +6571,7 @@ void DeclarationVisitor::Post(const parser::EnumerationTypeStmt &x) {
// each enumerator name in the enclosing scope with 1-based ordinal init.
bool DeclarationVisitor::Pre(const parser::EnumerationEnumeratorStmt &x) {
Scope &enclosingScope{NonDerivedTypeScope()};
- // The current DerivedType scope's symbol is the enumeration type.y
+ // The current DerivedType scope's symbol is the enumeration type.
Symbol *typeSymbol{currScope().symbol()};
CHECK(typeSymbol);
auto &typeDetails{typeSymbol->get<DerivedTypeDetails>()};
diff --git a/flang/test/Semantics/enumeration-type-component-offset.f90 b/flang/test/Semantics/enumeration-type-component-offset.f90
index 26928798d1d2d..8cec31cfe4d7a 100644
--- a/flang/test/Semantics/enumeration-type-component-offset.f90
+++ b/flang/test/Semantics/enumeration-type-component-offset.f90
@@ -1,8 +1,7 @@
! RUN: %flang_fc1 -fdebug-dump-symbols -fenumeration-type %s 2>&1 | FileCheck %s
! Regression test: a derived type with an enumeration-type component must be
! correctly sized once the enclosing type is instantiated (which happens as
-! soon as a variable of it is declared). Previously the enumeration component
-! collapsed to size 0 / offset 0, freezing the enclosing type at size 0.
+! soon as a variable of it is declared).
subroutine test_enum_component_offset()
enumeration type :: color
diff --git a/flang/test/Semantics/enumeration-type-declarations.f90 b/flang/test/Semantics/enumeration-type-declarations.f90
index a4d084728bf5e..4f1e5dbc50687 100644
--- a/flang/test/Semantics/enumeration-type-declarations.f90
+++ b/flang/test/Semantics/enumeration-type-declarations.f90
@@ -130,7 +130,7 @@ subroutine test_constructor_errors_use()
end subroutine
! A duplicate enumerator name within an enumeration type is diagnosed as a
-! clean semantic error (previously it aborted during name resolution).
+! clean semantic error.
subroutine test_duplicate_enumerator()
!WARNING: ENUMERATION TYPE support is incomplete and should be enabled only for testing
enumeration type :: color
diff --git a/flang/test/Semantics/enumeration-type-explicit-value.f90 b/flang/test/Semantics/enumeration-type-explicit-value.f90
index be88caed31eef..839e5fed024c0 100644
--- a/flang/test/Semantics/enumeration-type-explicit-value.f90
+++ b/flang/test/Semantics/enumeration-type-explicit-value.f90
@@ -1,8 +1,6 @@
! RUN: not %flang_fc1 -fsyntax-only -fenumeration-type %s 2>&1 | FileCheck %s
! F2023 enumeration types do not permit explicit enumerator values (unlike the
! ENUM, BIND(C) construct). 'enumerator :: red = 1' must be rejected.
-! NOTE: the expected message is a placeholder; update it to match the real
-! diagnostic if it differs.
subroutine test_explicit_value()
! CHECK: error: expected end of statement
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
index d04a6209f66c3..13b76f48fc92a 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -1,9 +1,5 @@
! RUN: not %flang_fc1 -fsyntax-only -fenumeration-type -pedantic %s 2>&1 | FileCheck %s
! Test intrinsics HUGE, NEXT, PREVIOUS, INT for enumeration types (F2023 7.6.2).
-! With lowering/runtime support in place, the previously-gated cases (non-
-! constant argument, STAT=, runtime boundary) now compile cleanly; the only
-! remaining compile-time errors are an unsupported INT kind and NEXT/PREVIOUS
-! boundary hits in a required-constant context.
module enum_intrinsics_mod
enumeration type :: color
diff --git a/flang/test/Semantics/io-unsafe-direct-component-pdt-order.f90 b/flang/test/Semantics/io-unsafe-direct-component-pdt-order.f90
index bba4d65acf033..2361171ea3ca0 100644
--- a/flang/test/Semantics/io-unsafe-direct-component-pdt-order.f90
+++ b/flang/test/Semantics/io-unsafe-direct-component-pdt-order.f90
@@ -6,7 +6,7 @@
! component unless it is processed by defined I/O. The check memoizes its walk;
! keying that memo on the shared type symbol (never erased on unwind) let a
! shielded parameterized-derived-type instantiation prune an unshielded sibling
-! instantiation, silently suppressing the error. The walk is now memoized on
+! instantiation, silently suppressing the error. The walk is now memorized on
! the instantiated scope, so the error surfaces regardless of traversal order.
module unsafe_pdt_order_mod
>From 095d1945f7700776c0f8f0ed00640133a8c285f2 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 24 Sep 2026 14:44:07 -0500
Subject: [PATCH 10/11] Update fir.alloca CHECK for inherent-attribute syntax
---
flang/test/Lower/enumeration-type.f90 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/flang/test/Lower/enumeration-type.f90 b/flang/test/Lower/enumeration-type.f90
index 63ba707be50c9..9093ae8fe7d92 100644
--- a/flang/test/Lower/enumeration-type.f90
+++ b/flang/test/Lower/enumeration-type.f90
@@ -373,7 +373,7 @@ subroutine test_func_result_array()
subroutine test_func_result_alloc()
use enum_func_mod
type(color2), allocatable :: c(:)
- ! CHECK: %[[TMP:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> {bindc_name = ".result"}
+ ! CHECK: %[[TMP:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> <{bindc_name = ".result"}>
! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick_alloc() {{.*}}: () -> !fir.box<!fir.heap<!fir.array<?xi32>>>
! CHECK: fir.save_result %[[RES]] to %{{.*}} : !fir.box<!fir.heap<!fir.array<?xi32>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
c = pick_alloc()
>From dbedf984c6e73d6f31b90288b4551c656a18348f Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 1 Oct 2026 11:51:51 -0500
Subject: [PATCH 11/11] [flang] Lower enumeration types as named records with a
type descriptor
Represent an F2023 enumeration type as !fir.type<...{__ordinal:i32}>
with a real .dt descriptor, instead of a bare i32. Enumeration values
can now be boxed, passed as polymorphic (SELECT TYPE, ALLOCATE, I/O),
and are distinct from INTEGER in descriptors. Ordinary scalar uses
access __ordinal directly through hlfir.designate, with no extra
boxing.
This new approach should address all the review findings thus far.
---
flang/include/flang/Evaluate/tools.h | 4 +
.../include/flang/Lower/ConvertExprToHLFIR.h | 13 +
flang/lib/Evaluate/intrinsics.cpp | 22 +-
flang/lib/Evaluate/tools.cpp | 56 +-
flang/lib/Lower/Bridge.cpp | 26 +-
flang/lib/Lower/CallInterface.cpp | 14 +-
flang/lib/Lower/ConvertCall.cpp | 188 +++++++
flang/lib/Lower/ConvertConstant.cpp | 38 --
flang/lib/Lower/ConvertExprToHLFIR.cpp | 490 ++++++------------
flang/lib/Lower/ConvertType.cpp | 11 -
flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 1 -
.../Lower/enumeration-type-next-previous.f90 | 400 ++++++++++++++
flang/test/Lower/enumeration-type.f90 | 456 +++++++---------
.../Semantics/enumeration-type-intrinsics.f90 | 20 +
14 files changed, 1039 insertions(+), 700 deletions(-)
create mode 100644 flang/test/Lower/enumeration-type-next-previous.f90
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 71544a3ba5597..9ea85edc35389 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1723,6 +1723,10 @@ std::optional<int> CountDerivedTypeAncestors(const semantics::Scope &);
// constant or structure constructor of an enumeration-type value.
std::optional<Expr<SomeType>> GetEnumerationOrdinal(Expr<SomeDerived> &);
+// Build INT(x), a default INTEGER reference to x's ordinal. The caller must
+// ensure x is of enumeration type.
+Expr<SomeType> MakeEnumerationIntCall(Expr<SomeDerived> &&);
+
} // namespace Fortran::evaluate
namespace Fortran::semantics {
diff --git a/flang/include/flang/Lower/ConvertExprToHLFIR.h b/flang/include/flang/Lower/ConvertExprToHLFIR.h
index d98d0a94a9956..412cdfe887dcb 100644
--- a/flang/include/flang/Lower/ConvertExprToHLFIR.h
+++ b/flang/include/flang/Lower/ConvertExprToHLFIR.h
@@ -145,6 +145,19 @@ hlfir::Entity genVectorSubscriptedDesignatorFirstElementAddress(
const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
Fortran::lower::StatementContext &stmtCtx);
+/// Address the ordinal component of a scalar or array variable of an F2023
+/// enumeration type.
+hlfir::Entity genEnumerationOrdinalDesignator(mlir::Location loc,
+ fir::FirOpBuilder &builder,
+ hlfir::Entity enumVar);
+
+/// Create a scalar temporary of enumeration type recTy holding ordinal.
+hlfir::EntityWithAttributes genEnumerationTemp(mlir::Location loc,
+ fir::FirOpBuilder &builder,
+ fir::RecordType recTy,
+ mlir::Value ordinal,
+ llvm::StringRef name);
+
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_CONVERTEXPRTOHLFIR_H
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index a687a4f0aea46..c58a6a00dd5f0 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -3743,6 +3743,24 @@ IntrinsicProcTable::Implementation::HandleEnumerationHuge(
std::move(arguments)};
}
+// STAT= of NEXT/PREVIOUS: any integer with a decimal exponent range >= 4.
+static DynamicType GetEnumerationStatType(const ActualArguments &arguments,
+ const char *procName, const common::IntrinsicTypeDefaultKinds &defaults,
+ FoldingContext &context) {
+ if (arguments.size() > 1 && arguments[1]) {
+ if (auto type{arguments[1]->GetType()}) {
+ if (type->category() != TypeCategory::Integer || type->kind() < 2) {
+ context.messages().Say(arguments[1]->sourceLocation(),
+ "STAT= argument to %s() must be an integer with a decimal exponent range of at least four"_err_en_US,
+ procName);
+ }
+ return *type;
+ }
+ }
+ return DynamicType{
+ TypeCategory::Integer, defaults.GetDefaultKind(TypeCategory::Integer)};
+}
+
// NEXT(a [, stat]) for enumeration types — returns the next enumerator
std::optional<SpecificCall>
IntrinsicProcTable::Implementation::HandleEnumerationNext(
@@ -3761,7 +3779,7 @@ IntrinsicProcTable::Implementation::HandleEnumerationNext(
characteristics::TypeAndShape{enumerationType}};
ddoA.intent = common::Intent::In;
DynamicType statType{
- TypeCategory::Integer, defaults_.GetDefaultKind(TypeCategory::Integer)};
+ GetEnumerationStatType(arguments, "NEXT", defaults_, context)};
characteristics::DummyDataObject ddoStat{
characteristics::TypeAndShape{statType}};
ddoStat.intent = common::Intent::Out;
@@ -3798,7 +3816,7 @@ IntrinsicProcTable::Implementation::HandleEnumerationPrevious(
characteristics::TypeAndShape{enumerationType}};
ddoA.intent = common::Intent::In;
DynamicType statType{
- TypeCategory::Integer, defaults_.GetDefaultKind(TypeCategory::Integer)};
+ GetEnumerationStatType(arguments, "PREVIOUS", defaults_, context)};
characteristics::DummyDataObject ddoStat{
characteristics::TypeAndShape{statType}};
ddoStat.intent = common::Intent::Out;
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 78be2932e30f9..3ec7ee02318f3 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -713,6 +713,29 @@ std::optional<Expr<SomeType>> GetEnumerationOrdinal(Expr<SomeDerived> &expr) {
return std::nullopt;
}
+Expr<SomeType> MakeEnumerationIntCall(Expr<SomeDerived> &&operand) {
+ using IntType = Type<TypeCategory::Integer, 4>;
+ const semantics::DerivedTypeSpec *derived{
+ GetDerivedTypeSpec(operand.GetType())};
+ CHECK(derived);
+ DynamicType enumType{*derived};
+ DynamicType intResultType{TypeCategory::Integer, 4};
+ characteristics::DummyDataObject ddo{characteristics::TypeAndShape{enumType}};
+ ddo.intent = common::Intent::In;
+ characteristics::Procedure::Attrs attrs{
+ characteristics::Procedure::Attr::Pure,
+ characteristics::Procedure::Attr::Elemental};
+ characteristics::DummyArguments dummies;
+ dummies.emplace_back("a"s, std::move(ddo));
+ SpecificIntrinsic intSpec{"int"s,
+ characteristics::Procedure{characteristics::FunctionResult{intResultType},
+ std::move(dummies), attrs}};
+ ActualArguments intArgs;
+ intArgs.emplace_back(AsGenericExpr(std::move(operand)));
+ return AsGenericExpr(Expr<SomeInteger>(Expr<IntType>(FunctionRef<IntType>{
+ ProcedureDesignator{std::move(intSpec)}, std::move(intArgs)})));
+}
+
std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {
return common::visit(
@@ -797,35 +820,10 @@ std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
return Relate(
messages, opr, std::move(*xOrd), std::move(*yOrd));
}
- // Non-constant operands: wrap in INT() to convert to
- // integer comparison. Build FunctionRef<Int4> for each
- // operand representing INT(enumExpr).
- auto makeIntCall =
- [&](Expr<SomeDerived> &&operand) -> Expr<SomeType> {
- using IntType = Type<TypeCategory::Integer, 4>;
- DynamicType enumType{*xDerived};
- DynamicType intResultType{TypeCategory::Integer, 4};
- characteristics::DummyDataObject ddo{
- characteristics::TypeAndShape{enumType}};
- ddo.intent = common::Intent::In;
- characteristics::Procedure::Attrs attrs{
- characteristics::Procedure::Attr::Pure,
- characteristics::Procedure::Attr::Elemental};
- characteristics::DummyArguments dummies;
- dummies.emplace_back("a"s, std::move(ddo));
- SpecificIntrinsic intSpec{"int"s,
- characteristics::Procedure{
- characteristics::FunctionResult{intResultType},
- std::move(dummies), attrs}};
- ActualArguments intArgs;
- intArgs.emplace_back(AsGenericExpr(std::move(operand)));
- return AsGenericExpr(
- Expr<SomeInteger>(Expr<IntType>(FunctionRef<IntType>{
- ProcedureDesignator{std::move(intSpec)},
- std::move(intArgs)})));
- };
- return Relate(messages, opr, makeIntCall(std::move(dx)),
- makeIntCall(std::move(dy)));
+ // Non-constant operands: compare INT(x) and INT(y).
+ return Relate(messages, opr,
+ MakeEnumerationIntCall(std::move(dx)),
+ MakeEnumerationIntCall(std::move(dy)));
}
}
DIE("invalid types for relational operator");
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index f3881a3f59d22..ef27475ad4522 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -4182,6 +4182,17 @@ class FirConverter : public Fortran::lower::AbstractConverter {
activeConstructStack.back().stmtCtx;
const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(
std::get<Fortran::parser::Scalar<Fortran::parser::Expr>>(stmt.t));
+ // Semantics already turned enumeration CASE values into ordinals.
+ std::optional<Fortran::lower::SomeExpr> enumOrdinal;
+ if (const auto *derived = std::get_if<
+ Fortran::evaluate::Expr<Fortran::evaluate::SomeDerived>>(&expr->u))
+ if (const auto *spec =
+ Fortran::evaluate::GetDerivedTypeSpec(derived->GetType());
+ spec && Fortran::semantics::IsEnumerationType(spec->typeSymbol())) {
+ enumOrdinal = Fortran::evaluate::MakeEnumerationIntCall(
+ Fortran::evaluate::Expr<Fortran::evaluate::SomeDerived>{*derived});
+ expr = &*enumOrdinal;
+ }
bool isCharSelector = isCharacterCategory(expr->GetType()->category());
bool isLogicalSelector = isLogicalCategory(expr->GetType()->category());
mlir::MLIRContext *context = builder->getContext();
@@ -6845,22 +6856,9 @@ class FirConverter : public Fortran::lower::AbstractConverter {
Fortran::common::TypeCategory::Derived) {
if (const auto *constant =
std::get_if<Fortran::evaluate::Constant<
- Fortran::evaluate::SomeDerived>>(&x.u)) {
- const auto &spec = constant->GetType().GetDerivedTypeSpec();
- const auto *dtDetails =
- spec.typeSymbol()
- .template detailsIf<
- Fortran::semantics::DerivedTypeDetails>();
- if (dtDetails && dtDetails->isEnumerationType())
- // Enumeration types lower to i32 (no RecordType); mangle the
- // name from the type spec instead of the element type.
- return Fortran::lower::mangle::mangleArrayLiteral(
- constant->values().size() * sizeof(constant->values()[0]),
- constant->shape(), Fortran::common::TypeCategory::Derived,
- /*kind=*/0, /*charLen=*/-1, mangleName(spec));
+ Fortran::evaluate::SomeDerived>>(&x.u))
return Fortran::lower::mangle::mangleArrayLiteral(eleTy,
*constant);
- }
fir::emitFatalError(loc,
"non a constant derived type expression");
} else {
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 2e50d204cd518..2bfe94559cd88 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1062,8 +1062,7 @@ class Fortran::lower::CallInterfaceImpl {
}
} else if (dynamicType.category() ==
Fortran::common::TypeCategory::Derived) {
- if (!dynamicType.GetDerivedTypeSpec().IsVectorType() &&
- !isEnumerationDerived(dynamicType)) {
+ if (!dynamicType.GetDerivedTypeSpec().IsVectorType()) {
// Derived result need to be allocated by the caller and the result
// value must be saved. Derived type in implicit interface cannot have
// length parameters.
@@ -1175,17 +1174,6 @@ class Fortran::lower::CallInterfaceImpl {
}
}
- // An F2023 enumeration type has Derived category but lowers to i32, so a
- // scalar enumeration result is returned by value like an integer.
- static bool
- isEnumerationDerived(const Fortran::evaluate::DynamicType &dynamicType) {
- // GetDerivedTypeSpec() is null-safe: it yields nullptr for polymorphic and
- // assumed-type results whose category is Derived but have no derived spec.
- const Fortran::semantics::DerivedTypeSpec *spec{
- Fortran::evaluate::GetDerivedTypeSpec(dynamicType)};
- return spec && Fortran::semantics::IsEnumerationType(spec->typeSymbol());
- }
-
mlir::Type
translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) {
Fortran::common::TypeCategory cat = dynamicType.category();
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index de17170614ad5..48a0176aecc80 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -32,6 +32,7 @@
#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Builder/Runtime/CUDA/Descriptor.h"
#include "flang/Optimizer/Builder/Runtime/Derived.h"
+#include "flang/Optimizer/Builder/Runtime/Stop.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/CUF/CUFOps.h"
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
@@ -2884,6 +2885,123 @@ class ElementalIntrinsicCallBuilder
fir::IntrinsicHandlerEntry intrinsicEntry;
const bool isFunction;
};
+
+// Compute the NEXT (min(ordinal+1, count)) or PREVIOUS (max(ordinal-1, 1))
+// ordinal, and an i1 telling whether ordinal was at the last/first enumerator.
+static std::pair<mlir::Value, mlir::Value>
+genEnumOrdinalStep(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value ordinal, mlir::Type resType, int count,
+ bool isNext) {
+ mlir::Value one = builder.createIntegerConstant(loc, resType, 1);
+ if (isNext) {
+ mlir::Value maxVal = builder.createIntegerConstant(loc, resType, count);
+ mlir::Value incremented =
+ mlir::arith::AddIOp::create(builder, loc, ordinal, one);
+ mlir::Value cmp = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::sle, incremented, maxVal);
+ mlir::Value result =
+ mlir::arith::SelectOp::create(builder, loc, cmp, incremented, maxVal);
+ mlir::Value atBoundary = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, maxVal);
+ return {result, atBoundary};
+ }
+ mlir::Value decremented =
+ mlir::arith::SubIOp::create(builder, loc, ordinal, one);
+ mlir::Value cmp = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::sge, decremented, one);
+ mlir::Value result =
+ mlir::arith::SelectOp::create(builder, loc, cmp, decremented, one);
+ mlir::Value atBoundary = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, one);
+ return {result, atBoundary};
+}
+
+// NEXT/PREVIOUS of an F2023 enumeration type. STAT is an elemental INTENT(OUT)
+// argument, and a boundary without STAT is an error stop, so array calls are
+// ordered loops performing these side effects element by element.
+class EnumerationStepCallBuilder
+ : public ElementalCallBuilder<EnumerationStepCallBuilder> {
+public:
+ EnumerationStepCallBuilder(int count, bool isNext)
+ : count{count}, isNext{isNext} {}
+
+ std::optional<hlfir::Entity>
+ genElementalKernel(Fortran::lower::PreparedActualArguments &loweredActuals,
+ CallContext &callContext) {
+ mlir::Location loc = callContext.loc;
+ fir::FirOpBuilder &builder = callContext.getBuilder();
+ hlfir::Entity arg = loweredActuals[0]->getActual(loc, builder);
+ mlir::Value ordinal = hlfir::loadTrivialScalar(
+ loc, builder,
+ Fortran::lower::genEnumerationOrdinalDesignator(loc, builder, arg));
+ std::pair<mlir::Value, mlir::Value> step = genEnumOrdinalStep(
+ builder, loc, ordinal, ordinal.getType(), count, isNext);
+ mlir::Value result = step.first;
+ mlir::Value atBoundary = step.second;
+ auto genBoundaryFatal = [&]() {
+ builder.genIfThen(loc, atBoundary)
+ .genThen([&]() {
+ fir::runtime::genReportFatalUserError(
+ builder, loc,
+ "NEXT or PREVIOUS of enumeration type at boundary without "
+ "STAT=");
+ })
+ .end();
+ };
+ std::optional<Fortran::lower::PreparedActualArgument> &stat =
+ loweredActuals[1];
+ if (!stat) {
+ genBoundaryFatal();
+ } else {
+ auto genStatAssign = [&]() {
+ hlfir::Entity statVar = stat->getActual(loc, builder);
+ mlir::Type statType = statVar.getFortranElementType();
+ mlir::Value statValue = mlir::arith::SelectOp::create(
+ builder, loc, atBoundary,
+ builder.createIntegerConstant(
+ loc, statType, 112 /* FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY */),
+ builder.createIntegerConstant(loc, statType, 0));
+ hlfir::AssignOp::create(builder, loc, statValue, statVar);
+ };
+ if (stat->handleDynamicOptional())
+ builder.genIfThenElse(loc, stat->getIsPresent())
+ .genThen(genStatAssign)
+ .genElse(genBoundaryFatal)
+ .end();
+ else
+ genStatAssign();
+ }
+ auto recTy = mlir::cast<fir::RecordType>(
+ hlfir::getFortranElementType(*callContext.resultType));
+ hlfir::Entity temp = Fortran::lower::genEnumerationTemp(
+ loc, builder, recTy, result, ".tmp.intrinsic_result");
+ return hlfir::Entity{hlfir::AsExprOp::create(
+ builder, loc, temp, /*mustFree=*/builder.createBool(loc, false))};
+ }
+
+ bool argMayBeModifiedByCall(unsigned argIdx) const { return argIdx == 1; }
+ bool canLoadActualArgumentBeforeLoop(unsigned) const { return false; }
+
+ mlir::Value
+ computeDynamicCharacterResultLength(Fortran::lower::PreparedActualArguments &,
+ CallContext &callContext) {
+ fir::emitFatalError(callContext.loc,
+ "NEXT/PREVIOUS cannot have a character result");
+ }
+
+ mlir::Value
+ getPolymorphicResultMold(Fortran::lower::PreparedActualArguments &,
+ CallContext &callContext) {
+ fir::emitFatalError(callContext.loc,
+ "NEXT/PREVIOUS cannot have a polymorphic result");
+ }
+
+ bool resultMayRequireFinalization(CallContext &) const { return false; }
+
+private:
+ int count;
+ bool isNext;
+};
} // namespace
static std::optional<mlir::Value>
@@ -2916,6 +3034,74 @@ genIsPresentIfArgMaybeAbsent(mlir::Location loc, hlfir::Entity actual,
.getResult();
}
+// Lower NEXT/PREVIOUS of an enumeration type (F2023 16.9.151 and 16.9.164).
+static std::optional<hlfir::EntityWithAttributes> genEnumerationNextOrPrevious(
+ const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+ CallContext &callContext) {
+ mlir::Location loc = callContext.loc;
+ fir::FirOpBuilder &builder = callContext.getBuilder();
+ const auto &args = callContext.procRef.arguments();
+ const Fortran::lower::SomeExpr *argExpr =
+ !args.empty() && args[0] ? args[0]->UnwrapExpr() : nullptr;
+ assert(argExpr && "NEXT/PREVIOUS requires argument A");
+ hlfir::Entity arg = Fortran::lower::convertExprToHLFIR(
+ loc, callContext.converter, *argExpr, callContext.symMap,
+ callContext.stmtCtx);
+ if (arg.isScalar() && !arg.isVariable()) {
+ hlfir::AssociateOp associate =
+ hlfir::genAssociateExpr(loc, builder, arg, arg.getType(), ".enum.arg");
+ arg = hlfir::Entity{associate.getBase()};
+ fir::FirOpBuilder *bldr = &builder;
+ callContext.stmtCtx.attachCleanup(
+ [=]() { hlfir::EndAssociateOp::create(*bldr, loc, associate); });
+ }
+ Fortran::lower::PreparedActualArguments loweredActuals;
+ loweredActuals.emplace_back(
+ Fortran::lower::PreparedActualArgument{arg, /*isPresent=*/std::nullopt});
+ const Fortran::lower::SomeExpr *statExpr =
+ args.size() > 1 && args[1] ? args[1]->UnwrapExpr() : nullptr;
+ if (!statExpr) {
+ loweredActuals.emplace_back(std::nullopt);
+ } else if (Fortran::evaluate::HasVectorSubscript(*statExpr)) {
+ // Elemental INTENT(OUT): write through each element address (F2023
+ // 15.5.2.4 p21 applies only to nonelemental procedures).
+ loweredActuals.emplace_back(Fortran::lower::PreparedActualArgument{
+ Fortran::lower::convertVectorSubscriptedExprToElementalAddr(
+ loc, callContext.converter, *statExpr, callContext.symMap,
+ callContext.stmtCtx)});
+ } else {
+ hlfir::Entity stat = Fortran::lower::convertExprToHLFIR(
+ loc, callContext.converter, *statExpr, callContext.symMap,
+ callContext.stmtCtx);
+ std::optional<mlir::Value> isPresent =
+ genIsPresentIfArgMaybeAbsent(loc, stat, *statExpr, callContext,
+ /*passAsAllocatableOrPointer=*/false);
+ loweredActuals.emplace_back(
+ Fortran::lower::PreparedActualArgument{stat, isPresent});
+ }
+ const Fortran::semantics::DerivedTypeSpec *spec =
+ Fortran::evaluate::GetDerivedTypeSpec(
+ callContext.procRef.proc().GetType());
+ assert(spec && "NEXT/PREVIOUS result must be an enumeration type");
+ int count = spec->typeSymbol()
+ .GetUltimate()
+ .get<Fortran::semantics::DerivedTypeDetails>()
+ .enumeratorCount();
+ EnumerationStepCallBuilder stepBuilder{count, intrinsic.name == "next"};
+ if (callContext.isElementalProcWithArrayArgs())
+ return stepBuilder.genElementalCall(loweredActuals, /*isImpure=*/true,
+ callContext);
+ for (auto &actual : loweredActuals)
+ if (actual)
+ actual->derefPointersAndAllocatables(loc, builder);
+ hlfir::EntityWithAttributes result{
+ *stepBuilder.genElementalKernel(loweredActuals, callContext)};
+ fir::FirOpBuilder *bldr = &builder;
+ callContext.stmtCtx.attachCleanup(
+ [=]() { hlfir::DestroyOp::create(*bldr, loc, result); });
+ return result;
+}
+
// Lower a reference to an elemental intrinsic procedure with array arguments
// and custom optional handling
static std::optional<hlfir::EntityWithAttributes>
@@ -3137,6 +3323,8 @@ genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,
CallContext &callContext) {
mlir::Location loc = callContext.loc;
auto &converter = callContext.converter;
+ if (intrinsic && (intrinsic->name == "next" || intrinsic->name == "previous"))
+ return genEnumerationNextOrPrevious(*intrinsic, callContext);
if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
callContext.procRef, *intrinsic, converter)) {
if (callContext.isElementalProcWithArrayArgs())
diff --git a/flang/lib/Lower/ConvertConstant.cpp b/flang/lib/Lower/ConvertConstant.cpp
index 9f6046a2fd8c4..f48dc9931e627 100644
--- a/flang/lib/Lower/ConvertConstant.cpp
+++ b/flang/lib/Lower/ConvertConstant.cpp
@@ -510,44 +510,12 @@ static mlir::Value genStructureComponentInit(
return res;
}
-// Extract __ordinal integer value from an enumeration StructureConstructor.
-// Returns std::nullopt if not an enumeration type or ordinal not found.
-static std::optional<int64_t>
-getEnumerationOrdinal(const Fortran::evaluate::StructureConstructor &ctor) {
- const auto &derivedSpec = ctor.derivedTypeSpec();
- // Check the type symbol's DerivedTypeDetails for the enumeration flag,
- // rather than the DerivedTypeSpec::category(), because some DerivedTypeSpec
- // copies created during name resolution may not have the
- // EnumerationType category set.
- const auto *dtDetails =
- derivedSpec.typeSymbol()
- .detailsIf<Fortran::semantics::DerivedTypeDetails>();
- if (!dtDetails || !dtDetails->isEnumerationType())
- return std::nullopt;
- if (const auto *scope = derivedSpec.GetScope()) {
- auto it = scope->find(Fortran::parser::CharBlock{"__ordinal", 9});
- if (it != scope->end()) {
- if (auto val = ctor.Find(it->second.get())) {
- return Fortran::evaluate::ToInt64(*val);
- }
- }
- }
- return std::nullopt;
-}
-
// Generate a StructureConstructor inlined (returns raw fir.type<T> value,
// not the address of a global constant).
static mlir::Value genInlinedStructureCtorLitImpl(
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
const Fortran::evaluate::StructureConstructor &ctor, mlir::Type type) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
-
- // Enumeration type: produce an i32 constant from the __ordinal value.
- if (auto ordinal = getEnumerationOrdinal(ctor)) {
- mlir::Type i32Ty = mlir::IntegerType::get(builder.getContext(), 32);
- return builder.createIntegerConstant(loc, i32Ty, *ordinal);
- }
-
auto recTy = mlir::cast<fir::RecordType>(type);
auto fieldTy = fir::FieldType::get(recTy.getContext());
@@ -841,12 +809,6 @@ fir::ExtendedValue Fortran::lower::ConstantBuilder<T>::gen(
loc, builder.getCharacterLengthType(), constant.LEN());
return fir::CharBoxValue{value, len};
} else if constexpr (T::category == Fortran::common::TypeCategory::Derived) {
- // Enumeration types: produce i32 constant directly.
- if (auto ordinal = getEnumerationOrdinal(*opt)) {
- fir::FirOpBuilder &builder = converter.getFirOpBuilder();
- mlir::Type i32Ty = mlir::IntegerType::get(builder.getContext(), 32);
- return builder.createIntegerConstant(loc, i32Ty, *ordinal);
- }
mlir::Type eleTy = Fortran::lower::translateDerivedTypeToFIRType(
converter, opt->GetType().GetDerivedTypeSpec());
return genScalarLit(converter, loc, *opt, eleTy,
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index f2ae7717935b3..a0cf48ff844b6 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -1729,20 +1729,21 @@ class HlfirBuilder {
mlir::Type resType =
Fortran::lower::TypeBuilder<T>::genType(getConverter(), expr);
- // Intercept enumeration-type intrinsics (NEXT, PREVIOUS, HUGE) that return
- // SomeDerived but lower to i32 operations.
if constexpr (std::is_same_v<T, Fortran::evaluate::SomeDerived>) {
- if (const auto *intrinsic = expr.proc().GetSpecificIntrinsic()) {
- if (intrinsic->name == "next") {
- return genEnumerationNext(expr, resType);
- }
- if (intrinsic->name == "previous") {
- return genEnumerationPrevious(expr, resType);
- }
- if (intrinsic->name == "huge") {
- return genEnumerationHuge(expr, resType);
- }
- }
+ if (const auto *intrinsic = expr.proc().GetSpecificIntrinsic();
+ intrinsic && intrinsic->name == "huge")
+ return genEnumerationHuge(expr, resType);
+ }
+
+ if constexpr (T::category == Fortran::common::TypeCategory::Integer) {
+ if (const auto *intrinsic = expr.proc().GetSpecificIntrinsic();
+ intrinsic && intrinsic->name == "int" && !expr.arguments().empty() &&
+ expr.arguments()[0])
+ if (const auto *arg = expr.arguments()[0]->UnwrapExpr())
+ if (const auto *spec =
+ Fortran::evaluate::GetDerivedTypeSpec(arg->GetType());
+ spec && Fortran::semantics::IsEnumerationType(spec->typeSymbol()))
+ return genEnumerationInt(*arg, resType);
}
auto result = Fortran::lower::convertCallToHLFIR(
@@ -1751,10 +1752,8 @@ class HlfirBuilder {
return *result;
}
- // Helper to extract enumeration type info from a NEXT/PREVIOUS/HUGE
- // intrinsic's result type.
- std::pair<const Fortran::semantics::DerivedTypeSpec *, int>
- getEnumerationTypeInfo(
+ // Number of enumerators of the enumeration type returned by expr.
+ int getEnumerationEnumeratorCount(
const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
&expr,
llvm::StringRef name) {
@@ -1768,274 +1767,132 @@ class HlfirBuilder {
.detailsIf<Fortran::semantics::DerivedTypeDetails>()
->isEnumerationType() &&
(name + " result must be enumeration type").str().c_str());
- int count = derived->typeSymbol()
- .GetUltimate()
- .get<Fortran::semantics::DerivedTypeDetails>()
- .enumeratorCount();
- return {derived, count};
+ return derived->typeSymbol()
+ .GetUltimate()
+ .get<Fortran::semantics::DerivedTypeDetails>()
+ .enumeratorCount();
}
- // Return the syntactically supplied STAT expression of NEXT/PREVIOUS, or
- // nullptr if none was written.
- const Fortran::lower::SomeExpr *getEnumerationStatExpr(
+ // Lower HUGE(enumVar) for non-constant enumeration arguments.
+ // Should always be folded, but handle as a constant just in case.
+ hlfir::EntityWithAttributes genEnumerationHuge(
const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
- &expr) {
- if (expr.arguments().size() < 2 || !expr.arguments()[1])
- return nullptr;
- const auto *statExpr = expr.arguments()[1]->UnwrapExpr();
- assert(statExpr && "STAT argument must be an expression");
- return statExpr;
- }
-
- // Return an i1 telling whether STAT is present at runtime, or a null value
- // if it is always present. An absent optional dummy or an unallocated or
- // disassociated allocatable/pointer actual makes STAT not present.
- mlir::Value
- genEnumerationStatIsPresent(const Fortran::lower::SomeExpr &statExpr,
- hlfir::Entity stat) {
- if (!Fortran::evaluate::MayBePassedAsAbsentOptional(statExpr))
- return {};
+ &expr,
+ mlir::Type resType) {
mlir::Location loc = getLoc();
fir::FirOpBuilder &builder = getBuilder();
- if (Fortran::evaluate::IsAllocatableOrPointerObject(statExpr))
- return builder.genIsNotNullAddr(
- loc, hlfir::genVariableRawAddress(loc, builder, stat));
- return fir::IsPresentOp::create(builder, loc, builder.getI1Type(), stat)
- .getResult();
- }
-
- // Emit genPresent() when STAT is present at runtime and genAbsent()
- // otherwise. A null isPresent means STAT is always present.
- template <typename PresentFn, typename AbsentFn>
- void genIfEnumerationStatPresent(mlir::Value isPresent, PresentFn genPresent,
- AbsentFn genAbsent) {
- if (!isPresent) {
- genPresent();
- return;
- }
- fir::FirOpBuilder &builder = getBuilder();
- auto ifOp = fir::IfOp::create(builder, getLoc(), {}, isPresent,
- /*withElseRegion=*/true);
- builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
- genPresent();
- builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
- genAbsent();
- builder.setInsertionPointAfter(ifOp);
+ int count = getEnumerationEnumeratorCount(expr, "HUGE");
+ mlir::Value last =
+ builder.createIntegerConstant(loc, builder.getI32Type(), count);
+ return Fortran::lower::genEnumerationTemp(
+ loc, builder, mlir::cast<fir::RecordType>(resType), last, "ctor.temp");
}
- // Error termination if cond (i1) is true; used when STAT is not present.
- void genEnumerationBoundaryFatal(mlir::Value cond) {
+ // Build an enumeration value in a temporary. A non-constant ordinal is range
+ // checked (F2023 7.6.2 p5) in its original kind, before narrowing.
+ hlfir::EntityWithAttributes
+ genEnumerationConstructor(const Fortran::evaluate::StructureConstructor &ctor,
+ fir::RecordType recTy) {
+ using Int4 =
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 4>;
mlir::Location loc = getLoc();
fir::FirOpBuilder &builder = getBuilder();
- auto ifOp = fir::IfOp::create(builder, loc, {}, cond,
- /*withElseRegion=*/false);
- builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
- fir::runtime::genReportFatalUserError(
- builder, loc,
- "NEXT or PREVIOUS of enumeration type at boundary without STAT=");
- builder.setInsertionPointAfter(ifOp);
- }
-
- // Helper to lower STAT argument handling for NEXT/PREVIOUS.
- // atBoundary is a boolean indicating whether the boundary condition was hit.
- void genEnumerationStatHandling(
- const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
- &expr,
- mlir::Value atBoundary, mlir::Type resType) {
+ assert(ctor.values().size() == 1 &&
+ "enumeration constructor must have exactly one value");
+ const auto &[ordSym, ordValue] = *ctor.values().begin();
+ const Fortran::lower::SomeExpr &ordExpr = ordValue.value();
+ std::string fieldName = converter.getRecordTypeFieldName(*ordSym);
+ mlir::Type ordTy = recTy.getType(fieldName);
+ assert(ordTy && "enumeration type must have an ordinal component");
+
+ mlir::Value ordinal;
+ if (std::optional<std::int64_t> constOrdinal =
+ Fortran::evaluate::ToInt64(ordExpr)) {
+ ordinal = builder.createIntegerConstant(loc, ordTy, *constOrdinal);
+ } else {
+ const Fortran::evaluate::Convert<Int4> *narrowing = nullptr;
+ if (const auto *intExpr = std::get_if<
+ Fortran::evaluate::Expr<Fortran::evaluate::SomeInteger>>(
+ &ordExpr.u))
+ if (const auto *int4Expr =
+ std::get_if<Fortran::evaluate::Expr<Int4>>(&intExpr->u))
+ narrowing =
+ std::get_if<Fortran::evaluate::Convert<Int4>>(&int4Expr->u);
+ hlfir::Entity original =
+ narrowing ? gen(narrowing->left()) : gen(ordExpr);
+ mlir::Value value = hlfir::loadTrivialScalar(loc, builder, original);
+ mlir::Type valueTy = value.getType();
+ int count = ctor.derivedTypeSpec()
+ .typeSymbol()
+ .GetUltimate()
+ .get<Fortran::semantics::DerivedTypeDetails>()
+ .enumeratorCount();
+ mlir::Value one = builder.createIntegerConstant(loc, valueTy, 1);
+ mlir::Value maxVal = builder.createIntegerConstant(loc, valueTy, count);
+ mlir::Value tooLow = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::slt, value, one);
+ mlir::Value tooHigh = mlir::arith::CmpIOp::create(
+ builder, loc, mlir::arith::CmpIPredicate::sgt, value, maxVal);
+ mlir::Value outOfRange =
+ mlir::arith::OrIOp::create(builder, loc, tooLow, tooHigh);
+ auto ifOp = fir::IfOp::create(builder, loc, {}, outOfRange,
+ /*withElseRegion=*/false);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ fir::runtime::genReportFatalUserError(
+ builder, loc,
+ "enumeration constructor value is out of range (must be "
+ "positive and not greater than the number of enumerators)");
+ builder.setInsertionPointAfter(ifOp);
+ ordinal = builder.createConvert(loc, ordTy, value);
+ }
+ return Fortran::lower::genEnumerationTemp(loc, builder, recTy, ordinal,
+ "ctor.temp");
+ }
+
+ // Address the __ordinal component of an enumeration expression as an
+ // INTEGER(4) variable (a strided view for arrays).
+ hlfir::Entity
+ genEnumerationOrdinal(const Fortran::lower::SomeExpr &enumExpr) {
mlir::Location loc = getLoc();
fir::FirOpBuilder &builder = getBuilder();
- const Fortran::lower::SomeExpr *statExpr = getEnumerationStatExpr(expr);
- if (!statExpr) {
- genEnumerationBoundaryFatal(atBoundary);
- return;
- }
- hlfir::Entity statAddr = Fortran::lower::convertExprToHLFIR(
- loc, converter, *statExpr, getSymMap(), getStmtCtx());
- auto genStatAssign = [&]() {
- // Assign 0 or FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY (112).
- mlir::Type statType = statAddr.getFortranElementType();
- mlir::Value boundaryConst = builder.createIntegerConstant(
- loc, statType, 112 /* FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY */);
- mlir::Value zeroConst = builder.createIntegerConstant(loc, statType, 0);
- mlir::Value statVal = mlir::arith::SelectOp::create(
- builder, loc, atBoundary, boundaryConst, zeroConst);
- hlfir::AssignOp::create(builder, loc, statVal, statAddr);
- };
- genIfEnumerationStatPresent(
- genEnumerationStatIsPresent(*statExpr, statAddr), genStatAssign,
- [&]() { genEnumerationBoundaryFatal(atBoundary); });
- }
-
- // Compute the per-element NEXT/PREVIOUS result and boundary flag from a
- // scalar ordinal. isNext selects NEXT (min(ordinal+1, count)) versus
- // PREVIOUS (max(ordinal-1, 1)); the returned atBoundary is an i1.
- std::pair<mlir::Value, mlir::Value>
- genEnumOrdinalStep(fir::FirOpBuilder &builder, mlir::Location loc,
- mlir::Value ordinal, mlir::Type resType, int count,
- bool isNext) {
- mlir::Value one = builder.createIntegerConstant(loc, resType, 1);
- if (isNext) {
- mlir::Value maxVal = builder.createIntegerConstant(loc, resType, count);
- mlir::Value incremented =
- mlir::arith::AddIOp::create(builder, loc, ordinal, one);
- mlir::Value cmp = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::sle, incremented, maxVal);
- mlir::Value result =
- mlir::arith::SelectOp::create(builder, loc, cmp, incremented, maxVal);
- mlir::Value atBoundary = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, maxVal);
- return {result, atBoundary};
+ hlfir::Entity base = hlfir::derefPointersAndAllocatables(
+ loc, builder, hlfir::Entity{gen(enumExpr)});
+ if (!base.isVariable()) {
+ hlfir::AssociateOp associate = hlfir::genAssociateExpr(
+ loc, builder, base, base.getType(), ".enum.tmp");
+ base = hlfir::Entity{associate.getBase()};
+ fir::FirOpBuilder *bldr = &builder;
+ getStmtCtx().attachCleanup(
+ [=]() { hlfir::EndAssociateOp::create(*bldr, loc, associate); });
}
- mlir::Value decremented =
- mlir::arith::SubIOp::create(builder, loc, ordinal, one);
- mlir::Value cmp = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::sge, decremented, one);
- mlir::Value result =
- mlir::arith::SelectOp::create(builder, loc, cmp, decremented, one);
- mlir::Value atBoundary = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::eq, ordinal, one);
- return {result, atBoundary};
- }
-
- // Lower NEXT/PREVIOUS applied to a whole-array (elemental) enumeration
- // argument. The result is a pure hlfir.elemental; STAT/error-termination
- // side effects are handled after it, per element.
- hlfir::EntityWithAttributes genEnumerationArray(
- const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
- &expr,
- hlfir::Entity arg, mlir::Type resType, int count, bool isNext) {
+ return Fortran::lower::genEnumerationOrdinalDesignator(loc, builder, base);
+ }
+
+ // Lower INT(enumeration [, KIND]); resType already reflects KIND.
+ hlfir::EntityWithAttributes
+ genEnumerationInt(const Fortran::lower::SomeExpr &enumExpr,
+ mlir::Type resType) {
mlir::Location loc = getLoc();
fir::FirOpBuilder &builder = getBuilder();
- mlir::Value shape = hlfir::genShape(loc, builder, arg);
- // resType is the whole array type here; the ordinal arithmetic and result
- // element type need the scalar (i32) element type.
mlir::Type eleTy = hlfir::getFortranElementType(resType);
-
- auto resultKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
- mlir::ValueRange idx) -> hlfir::Entity {
- mlir::Value ordinal =
- hlfir::loadTrivialScalar(l, b, hlfir::getElementAt(l, b, arg, idx));
- auto [result, atBoundary] =
- genEnumOrdinalStep(b, l, ordinal, eleTy, count, isNext);
- (void)atBoundary;
- return hlfir::Entity{result};
+ hlfir::Entity ordinal = genEnumerationOrdinal(enumExpr);
+ if (!ordinal.isArray())
+ return hlfir::EntityWithAttributes{builder.createConvert(
+ loc, eleTy, hlfir::loadTrivialScalar(loc, builder, ordinal))};
+ mlir::Value shape = hlfir::genShape(loc, builder, ordinal);
+ auto kernel = [&](mlir::Location l, fir::FirOpBuilder &b,
+ mlir::ValueRange idx) -> hlfir::Entity {
+ mlir::Value elem = hlfir::loadTrivialScalar(
+ l, b, hlfir::getElementAt(l, b, ordinal, idx));
+ return hlfir::Entity{b.createConvert(l, eleTy, elem)};
};
- mlir::Value resultElem =
+ mlir::Value elemental =
hlfir::genElementalOp(loc, builder, eleTy, shape, /*typeParams=*/{},
- resultKernel, /*isUnordered=*/true);
+ kernel, /*isUnordered=*/true);
fir::FirOpBuilder *bldr = &builder;
getStmtCtx().attachCleanup(
- [=]() { hlfir::DestroyOp::create(*bldr, loc, resultElem); });
-
- // STAT not present: error termination if any element is at a boundary.
- auto genBoundaryFatal = [&]() {
- mlir::Type logType = fir::LogicalType::get(builder.getContext(), 4);
- auto maskKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
- mlir::ValueRange idx) -> hlfir::Entity {
- mlir::Value ordinal =
- hlfir::loadTrivialScalar(l, b, hlfir::getElementAt(l, b, arg, idx));
- auto [result, atBoundary] =
- genEnumOrdinalStep(b, l, ordinal, eleTy, count, isNext);
- (void)result;
- return hlfir::Entity{b.createConvert(l, logType, atBoundary)};
- };
- mlir::Value mask =
- hlfir::genElementalOp(loc, builder, logType, shape, /*typeParams=*/{},
- maskKernel, /*isUnordered=*/true);
- mlir::Value anyBoundary =
- hlfir::AnyOp::create(builder, loc, logType, mask,
- /*dim=*/mlir::Value{});
- genEnumerationBoundaryFatal(
- builder.createConvert(loc, builder.getI1Type(), anyBoundary));
- hlfir::DestroyOp::create(builder, loc, mask);
- };
-
- const Fortran::lower::SomeExpr *statExpr = getEnumerationStatExpr(expr);
- if (!statExpr) {
- genBoundaryFatal();
- return hlfir::EntityWithAttributes{resultElem};
- }
- hlfir::Entity statEntity = Fortran::lower::convertExprToHLFIR(
- loc, converter, *statExpr, getSymMap(), getStmtCtx());
- // STAT present: elementwise 0/112 into the conformable STAT array. The
- // temporary is destroyed inline since it may live inside a fir.if region.
- auto genStatAssign = [&]() {
- mlir::Type statType = statEntity.getFortranElementType();
- auto statKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
- mlir::ValueRange idx) -> hlfir::Entity {
- mlir::Value ordinal =
- hlfir::loadTrivialScalar(l, b, hlfir::getElementAt(l, b, arg, idx));
- auto [result, atBoundary] =
- genEnumOrdinalStep(b, l, ordinal, eleTy, count, isNext);
- (void)result;
- mlir::Value boundaryConst = b.createIntegerConstant(l, statType, 112);
- mlir::Value zeroConst = b.createIntegerConstant(l, statType, 0);
- return hlfir::Entity{mlir::arith::SelectOp::create(
- b, l, atBoundary, boundaryConst, zeroConst)};
- };
- mlir::Value statElem = hlfir::genElementalOp(
- loc, builder, statType, shape, /*typeParams=*/{}, statKernel,
- /*isUnordered=*/true);
- hlfir::AssignOp::create(builder, loc, statElem, statEntity);
- hlfir::DestroyOp::create(builder, loc, statElem);
- };
- genIfEnumerationStatPresent(
- genEnumerationStatIsPresent(*statExpr, statEntity), genStatAssign,
- genBoundaryFatal);
- return hlfir::EntityWithAttributes{resultElem};
- }
-
- // Lower NEXT/PREVIOUS for non-constant enumeration arguments, dispatching to
- // the scalar or elemental-array path. isNext selects NEXT versus PREVIOUS.
- hlfir::EntityWithAttributes genEnumerationNextOrPrevious(
- const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
- &expr,
- mlir::Type resType, bool isNext) {
- mlir::Location loc = getLoc();
- fir::FirOpBuilder &builder = getBuilder();
- auto [derived, count] =
- getEnumerationTypeInfo(expr, isNext ? "NEXT" : "PREVIOUS");
- (void)derived;
- assert(expr.arguments().size() >= 1 && expr.arguments()[0]);
- const auto *argExpr = expr.arguments()[0]->UnwrapExpr();
- assert(argExpr && "NEXT/PREVIOUS argument must be an expression");
- hlfir::Entity arg = Fortran::lower::convertExprToHLFIR(
- loc, converter, *argExpr, getSymMap(), getStmtCtx());
- if (arg.isArray())
- return genEnumerationArray(expr, arg, resType, count, isNext);
- mlir::Value ordinal = hlfir::loadTrivialScalar(loc, builder, arg);
- auto [result, atBoundary] =
- genEnumOrdinalStep(builder, loc, ordinal, resType, count, isNext);
- genEnumerationStatHandling(expr, atBoundary, resType);
- return hlfir::EntityWithAttributes{result};
- }
-
- hlfir::EntityWithAttributes genEnumerationNext(
- const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
- &expr,
- mlir::Type resType) {
- return genEnumerationNextOrPrevious(expr, resType, /*isNext=*/true);
- }
-
- hlfir::EntityWithAttributes genEnumerationPrevious(
- const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
- &expr,
- mlir::Type resType) {
- return genEnumerationNextOrPrevious(expr, resType, /*isNext=*/false);
- }
-
- // Lower HUGE(enumVar) for non-constant enumeration arguments.
- // Should always be folded, but handle as a constant just in case.
- hlfir::EntityWithAttributes genEnumerationHuge(
- const Fortran::evaluate::FunctionRef<Fortran::evaluate::SomeDerived>
- &expr,
- mlir::Type resType) {
- mlir::Location loc = getLoc();
- fir::FirOpBuilder &builder = getBuilder();
- auto [derived, count] = getEnumerationTypeInfo(expr, "HUGE");
- (void)derived;
- mlir::Value result = builder.createIntegerConstant(loc, resType, count);
- return hlfir::EntityWithAttributes{result};
+ [=]() { hlfir::DestroyOp::create(*bldr, loc, elemental); });
+ return hlfir::EntityWithAttributes{elemental};
}
template <typename T>
@@ -2380,67 +2237,9 @@ class HlfirBuilder {
fir::FirOpBuilder &builder = getBuilder();
mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor));
- // Enumeration types lower to i32 — extract the __ordinal value.
- // Check via the type symbol's DerivedTypeDetails rather than
- // DerivedTypeSpec::IsEnumerationType(), which may not be set on
- // all DerivedTypeSpec instances.
- if (const auto *dtDetails =
- ctor.derivedTypeSpec()
- .typeSymbol()
- .detailsIf<Fortran::semantics::DerivedTypeDetails>()) {
- if (dtDetails->isEnumerationType()) {
- if (const auto *scope = ctor.derivedTypeSpec().GetScope()) {
- auto it = scope->find(Fortran::parser::CharBlock{"__ordinal", 9});
- if (it != scope->end()) {
- if (auto val = ctor.Find(it->second.get())) {
- if (auto ordinal = Fortran::evaluate::ToInt64(*val)) {
- mlir::Value result =
- builder.createIntegerConstant(loc, ty, *ordinal);
- return hlfir::EntityWithAttributes{result};
- }
- // Non-constant ordinal (e.g. color(i) with variable i): lower
- // the __ordinal component expression to a runtime scalar value.
- hlfir::Entity ordinalEntity = gen(*val);
- mlir::Value ordinal =
- hlfir::loadTrivialScalar(loc, builder, ordinalEntity);
- if (ordinal.getType() != ty)
- ordinal = builder.createConvert(loc, ty, ordinal);
- // F2023 7.6.2 para 5 requires the constructor value to be
- // positive and <= the number of enumerators. We choose to always
- // emit a runtime range check with error termination. This block
- // could be placed behind an -fcheck=enum style flag if the
- // community prefers an opt-in implementation like gfortran's
- // -fcheck=bounds.
- int count = ctor.derivedTypeSpec()
- .typeSymbol()
- .GetUltimate()
- .get<Fortran::semantics::DerivedTypeDetails>()
- .enumeratorCount();
- mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
- mlir::Value maxVal =
- builder.createIntegerConstant(loc, ty, count);
- mlir::Value tooLow = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::slt, ordinal, one);
- mlir::Value tooHigh = mlir::arith::CmpIOp::create(
- builder, loc, mlir::arith::CmpIPredicate::sgt, ordinal,
- maxVal);
- mlir::Value outOfRange =
- mlir::arith::OrIOp::create(builder, loc, tooLow, tooHigh);
- auto ifOp = fir::IfOp::create(builder, loc, {}, outOfRange,
- /*withElseRegion=*/false);
- builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
- fir::runtime::genReportFatalUserError(
- builder, loc,
- "enumeration constructor value is out of range (must be "
- "positive and not greater than the number of enumerators)");
- builder.setInsertionPointAfter(ifOp);
- return hlfir::EntityWithAttributes{ordinal};
- }
- }
- }
- fir::emitFatalError(loc, "failed to extract enumeration ordinal");
- }
- }
+ if (Fortran::semantics::IsEnumerationType(
+ ctor.derivedTypeSpec().typeSymbol()))
+ return genEnumerationConstructor(ctor, mlir::cast<fir::RecordType>(ty));
auto recTy = mlir::cast<fir::RecordType>(ty);
@@ -2716,6 +2515,43 @@ hlfir::EntityWithAttributes Fortran::lower::convertExprToHLFIR(
return HlfirBuilder(loc, converter, symMap, stmtCtx).gen(expr);
}
+hlfir::Entity Fortran::lower::genEnumerationOrdinalDesignator(
+ mlir::Location loc, fir::FirOpBuilder &builder, hlfir::Entity enumVar) {
+ assert(enumVar.isVariable() && "expected an enumeration variable");
+ auto recTy = mlir::cast<fir::RecordType>(enumVar.getFortranElementType());
+ assert(recTy.getNumFields() == 1 && "expected an enumeration type");
+ auto [fieldName, ordTy] = recTy.getTypeList().front();
+ mlir::Type designatorType = builder.getRefType(ordTy);
+ mlir::Value shape;
+ if (enumVar.isArray()) {
+ auto seqTy =
+ mlir::cast<fir::SequenceType>(enumVar.getElementOrSequenceType());
+ designatorType =
+ fir::BoxType::get(fir::SequenceType::get(seqTy.getShape(), ordTy));
+ shape = hlfir::genShape(loc, builder, enumVar);
+ }
+ mlir::Value designate = hlfir::DesignateOp::create(
+ builder, loc, designatorType, enumVar, fieldName,
+ /*compShape=*/mlir::Value{}, hlfir::DesignateOp::Subscripts{},
+ /*substring=*/mlir::ValueRange{},
+ /*complexPart=*/std::nullopt, shape,
+ /*typeParams=*/mlir::ValueRange{}, fir::FortranVariableFlagsAttr{});
+ return hlfir::Entity{designate};
+}
+
+hlfir::EntityWithAttributes Fortran::lower::genEnumerationTemp(
+ mlir::Location loc, fir::FirOpBuilder &builder, fir::RecordType recTy,
+ mlir::Value ordinal, llvm::StringRef name) {
+ mlir::Value storage = builder.createTemporary(loc, recTy);
+ hlfir::EntityWithAttributes temp{
+ hlfir::DeclareOp::create(builder, loc, storage, name)};
+ hlfir::Entity field = genEnumerationOrdinalDesignator(loc, builder, temp);
+ mlir::Value value =
+ builder.createConvert(loc, field.getFortranElementType(), ordinal);
+ hlfir::AssignOp::create(builder, loc, value, field);
+ return temp;
+}
+
fir::ExtendedValue Fortran::lower::convertToBox(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
hlfir::Entity entity, Fortran::lower::StatementContext &stmtCtx,
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index b6938aa6b97f9..0fdbdfcc74424 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -385,17 +385,6 @@ struct TypeBuilderImpl {
if (tySpec.IsVectorType()) {
return genVectorType(tySpec);
}
- // Check the type symbol's DerivedTypeDetails for the enumeration flag,
- // because some DerivedTypeSpec instances may not have the
- // EnumerationType category set (e.g., those created during USE
- // association or variable declarations).
- if (const auto *dtDetails =
- tySpec.typeSymbol()
- .detailsIf<Fortran::semantics::DerivedTypeDetails>()) {
- if (dtDetails->isEnumerationType()) {
- return mlir::IntegerType::get(&converter.getMLIRContext(), 32);
- }
- }
const Fortran::semantics::Symbol &typeSymbol = tySpec.typeSymbol();
const Fortran::semantics::Scope &derivedScope = DEREF(tySpec.GetScope());
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index 39f079f3b0ea1..a6a9551993e1e 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -534,7 +534,6 @@ static constexpr IntrinsicHandler handlers[]{
{"substring", asAddr},
{"back", asValue, handleDynamicOptional},
{"kind", asValue}}}},
- {"int", &I::genConversion},
{"ior", &I::genIor},
{"iparity",
&I::genIparity,
diff --git a/flang/test/Lower/enumeration-type-next-previous.f90 b/flang/test/Lower/enumeration-type-next-previous.f90
new file mode 100644
index 0000000000000..c1e2167e5a4f7
--- /dev/null
+++ b/flang/test/Lower/enumeration-type-next-previous.f90
@@ -0,0 +1,400 @@
+! Test lowering of the NEXT and PREVIOUS intrinsics for enumeration types.
+! RUN: %flang_fc1 -fenumeration-type -emit-hlfir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -fenumeration-type -emit-fir %s -o /dev/null
+
+module enum_np_mod
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end module
+
+! -----------------------------------------------------------------------------
+! Test NEXT() with a scalar argument and STAT
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_next(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>>
+subroutine test_next(c)
+ use enum_np_mod
+ type(color), intent(in) :: c
+ type(color) :: result
+ integer :: stat
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_nextEc"}
+ ! CHECK: %[[RESULT:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_nextEresult"}
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_nextEstat"}
+ ! CHECK: %[[F:.*]] = hlfir.designate %[[C]]#0{"__ordinal"}
+ ! CHECK: %[[ORD:.*]] = fir.load %[[F]] : !fir.ref<i32>
+ ! Result ordinal is min(ordinal + 1, 3).
+ ! CHECK-DAG: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK-DAG: %[[MAX:.*]] = arith.constant 3 : i32
+ ! CHECK: %[[INC:.*]] = arith.addi %[[ORD]], %[[ONE]] : i32
+ ! CHECK: %[[CMP:.*]] = arith.cmpi sle, %[[INC]], %[[MAX]] : i32
+ ! CHECK: %[[NEXT:.*]] = arith.select %[[CMP]], %[[INC]], %[[MAX]] : i32
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq, %[[ORD]], %[[MAX]] : i32
+ ! A non-optional local STAT needs no presence check.
+ ! CHECK-NOT: fir.is_present
+ ! CHECK-DAG: %[[C112:.*]] = arith.constant 112 : i32
+ ! CHECK-DAG: %[[C0:.*]] = arith.constant 0 : i32
+ ! CHECK: %[[S:.*]] = arith.select %[[BOUND]], %[[C112]], %[[C0]] : i32
+ ! CHECK: hlfir.assign %[[S]] to %[[STAT]]#0 : i32, !fir.ref<i32>
+ ! CHECK: %[[TMP:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = ".tmp.intrinsic_result"}
+ ! CHECK: %[[TF:.*]] = hlfir.designate %[[TMP]]#0{"__ordinal"}
+ ! CHECK: hlfir.assign %[[NEXT]] to %[[TF]] : i32, !fir.ref<i32>
+ ! CHECK: %[[E:.*]] = hlfir.as_expr %[[TMP]]#0
+ ! CHECK: hlfir.assign %[[E]] to %[[RESULT]]#0
+ ! CHECK: hlfir.destroy %[[E]]
+ result = next(c, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test PREVIOUS() with a scalar argument and STAT
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_previous(
+subroutine test_previous(c)
+ use enum_np_mod
+ type(color), intent(in) :: c
+ type(color) :: result
+ integer :: stat
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_previousEc"}
+ ! CHECK: %[[F:.*]] = hlfir.designate %[[C]]#0{"__ordinal"}
+ ! CHECK: %[[ORD:.*]] = fir.load %[[F]] : !fir.ref<i32>
+ ! Result ordinal is max(ordinal - 1, 1).
+ ! CHECK: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK: %[[DEC:.*]] = arith.subi %[[ORD]], %[[ONE]] : i32
+ ! CHECK: %[[CMP:.*]] = arith.cmpi sge, %[[DEC]], %[[ONE]] : i32
+ ! CHECK: %[[PREV:.*]] = arith.select %[[CMP]], %[[DEC]], %[[ONE]] : i32
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq, %[[ORD]], %[[ONE]] : i32
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign
+ ! CHECK: %[[TMP:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = ".tmp.intrinsic_result"}
+ ! CHECK: %[[TF:.*]] = hlfir.designate %[[TMP]]#0{"__ordinal"}
+ ! CHECK: hlfir.assign %[[PREV]] to %[[TF]] : i32, !fir.ref<i32>
+ result = previous(c, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() without STAT
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_next_no_stat(
+subroutine test_next_no_stat(c)
+ use enum_np_mod
+ type(color), intent(in) :: c
+ type(color) :: result
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: fir.if %[[BOUND]] {
+ ! CHECK: fir.call @_FortranAReportFatalUserError
+ ! CHECK: }
+ ! CHECK-NOT: arith.constant 112
+ ! CHECK: hlfir.declare %{{.*}} {uniq_name = ".tmp.intrinsic_result"}
+ result = next(c)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() with a STAT that may be absent at run time
+! -----------------------------------------------------------------------------
+
+! An absent optional dummy, an unallocated allocatable, or a disassociated
+! pointer forwarded as STAT= is not present: STAT is not written and the
+! boundary is a fatal error.
+
+! CHECK-LABEL: func.func @_QPtest_next_optional_stat(
+subroutine test_next_optional_stat(c, stat)
+ use enum_np_mod
+ type(color), intent(in) :: c
+ integer, optional, intent(out) :: stat
+ type(color) :: result
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_optional_statEstat"}
+ ! CHECK: %[[PRES:.*]] = fir.is_present %[[STAT]]#0 : (!fir.ref<i32>) -> i1
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: fir.if %[[PRES]] {
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign %{{.*}} to %[[STAT]]#0
+ ! CHECK: } else {
+ ! CHECK: fir.if %[[BOUND]] {
+ ! CHECK: fir.call @_FortranAReportFatalUserError
+ result = next(c, stat=stat)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_next_allocatable_stat(
+subroutine test_next_allocatable_stat(c, stat)
+ use enum_np_mod
+ type(color), intent(in) :: c
+ integer, allocatable, intent(inout) :: stat
+ type(color) :: result
+ ! CHECK: fir.box_addr
+ ! CHECK: %[[PRES:.*]] = arith.cmpi ne
+ ! CHECK: %[[ADDR:.*]] = fir.box_addr %{{.*}} : (!fir.box<!fir.heap<i32>>) -> !fir.heap<i32>
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: fir.if %[[PRES]] {
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign %{{.*}} to %[[ADDR]] : i32, !fir.heap<i32>
+ ! CHECK: } else {
+ ! CHECK: fir.if %[[BOUND]] {
+ ! CHECK: fir.call @_FortranAReportFatalUserError
+ result = next(c, stat=stat)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_next_pointer_stat(
+subroutine test_next_pointer_stat(c, stat)
+ use enum_np_mod
+ type(color), intent(in) :: c
+ integer, pointer, intent(in) :: stat
+ type(color) :: nc
+ ! CHECK: fir.box_addr
+ ! CHECK: %[[PRES:.*]] = arith.cmpi ne
+ ! CHECK: %[[ADDR:.*]] = fir.box_addr %{{.*}} : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: fir.if %[[PRES]] {
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign %{{.*}} to %[[ADDR]] : i32, !fir.ptr<i32>
+ ! CHECK: } else {
+ ! CHECK: fir.if %[[BOUND]] {
+ ! CHECK: fir.call @_FortranAReportFatalUserError
+ nc = next(c, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() and PREVIOUS() with an allocatable or pointer A
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_next_allocatable_a(
+subroutine test_next_allocatable_a(a)
+ use enum_np_mod
+ type(color), allocatable, intent(in) :: a
+ type(color) :: nc
+ ! CHECK: %[[A:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_allocatable_aEa"}
+ ! CHECK: %[[BOX:.*]] = fir.load %[[A]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>>>>
+ ! CHECK: %[[ADDR:.*]] = fir.box_addr %[[BOX]]
+ ! CHECK: %[[F:.*]] = hlfir.designate %[[ADDR]]{"__ordinal"} : (!fir.heap<!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>>) -> !fir.ref<i32>
+ ! CHECK: fir.load %[[F]] : !fir.ref<i32>
+ nc = next(a)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_next_allocatable_array_a(
+subroutine test_next_allocatable_array_a(a)
+ use enum_np_mod
+ type(color), allocatable, intent(in) :: a(:)
+ type(color) :: narr(3)
+ integer :: stat(3)
+ ! CHECK: %[[A:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_allocatable_array_aEa"}
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_next_allocatable_array_aEstat"}
+ ! CHECK: %[[BOX:.*]] = fir.load %[[A]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>>>>>
+ ! CHECK: %[[DIMS:.*]]:3 = fir.box_dims %[[BOX]], %{{.*}}
+ ! CHECK: %[[SHAPE:.*]] = fir.shape %[[DIMS]]#1
+ ! CHECK: hlfir.elemental %[[SHAPE]] : (!fir.shape<1>) -> !hlfir.expr<?x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>> {
+ ! CHECK: ^bb0(%[[I:.*]]: index):
+ ! CHECK: %[[ELT:.*]] = hlfir.designate %[[BOX]] (%{{.*}})
+ ! CHECK: hlfir.designate %[[ELT]]{"__ordinal"}
+ ! CHECK: %[[SE:.*]] = hlfir.designate %[[STAT]]#0 (%[[I]])
+ ! CHECK: hlfir.assign %{{.*}} to %[[SE]] : i32, !fir.ref<i32>
+ narr = next(a, stat=stat)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_previous_pointer_a(
+subroutine test_previous_pointer_a(p)
+ use enum_np_mod
+ type(color), pointer, intent(in) :: p(:)
+ type(color) :: parr(3)
+ ! CHECK: %[[P:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_previous_pointer_aEp"}
+ ! CHECK: %[[BOX:.*]] = fir.load %[[P]]#0
+ ! CHECK: %[[DIMS:.*]]:3 = fir.box_dims %[[BOX]], %{{.*}}
+ ! CHECK: %[[SHAPE:.*]] = fir.shape %[[DIMS]]#1
+ ! CHECK: hlfir.elemental %[[SHAPE]] : (!fir.shape<1>) -> !hlfir.expr<?x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>> {
+ ! CHECK: %[[ELT:.*]] = hlfir.designate %[[BOX]] (%{{.*}})
+ ! CHECK: hlfir.designate %[[ELT]]{"__ordinal"}
+ ! CHECK: arith.subi
+ parr = previous(p)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() and PREVIOUS() over whole arrays
+! -----------------------------------------------------------------------------
+
+! An array call is an ordered hlfir.elemental over the record type (no
+! "unordered"): the call may terminate at a boundary, so elements must be
+! evaluated in order and only where needed.
+
+! CHECK-LABEL: func.func @_QPtest_next_array(
+subroutine test_next_array(arr)
+ use enum_np_mod
+ type(color), intent(in) :: arr(3)
+ type(color) :: narr(3)
+ integer :: stat(3)
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_next_arrayEstat"}
+ ! CHECK: %[[RES:.*]] = hlfir.elemental %{{[0-9]+}} : (!fir.shape<1>) -> !hlfir.expr<3x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>> {
+ ! CHECK: ^bb0(%[[I:.*]]: index):
+ ! CHECK: %[[ELT:.*]] = hlfir.designate %{{.*}} (%[[I]])
+ ! CHECK: %[[F:.*]] = hlfir.designate %[[ELT]]{"__ordinal"}
+ ! CHECK: %[[ORD:.*]] = fir.load %[[F]] : !fir.ref<i32>
+ ! CHECK: arith.addi %[[ORD]]
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq, %[[ORD]]
+ ! CHECK: %[[SE:.*]] = hlfir.designate %[[STAT]]#0 (%[[I]])
+ ! CHECK: %[[S:.*]] = arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign %[[S]] to %[[SE]] : i32, !fir.ref<i32>
+ ! CHECK: hlfir.yield_element %{{.*}} : !hlfir.expr<!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>>
+ ! CHECK: }
+ ! CHECK: hlfir.assign %[[RES]] to
+ ! CHECK: hlfir.destroy %[[RES]]
+ narr = next(arr, stat=stat)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_previous_array(
+subroutine test_previous_array(arr)
+ use enum_np_mod
+ type(color), intent(in) :: arr(3)
+ type(color) :: parr(3)
+ integer :: stat(3)
+ ! CHECK: hlfir.elemental %{{[0-9]+}} : (!fir.shape<1>) -> !hlfir.expr<3x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>> {
+ ! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK: %[[ONE:.*]] = arith.constant 1 : i32
+ ! CHECK: %[[DEC:.*]] = arith.subi %[[ORD]], %[[ONE]] : i32
+ ! CHECK: %[[CMP:.*]] = arith.cmpi sge, %[[DEC]], %[[ONE]] : i32
+ ! CHECK: arith.select %[[CMP]], %[[DEC]], %[[ONE]] : i32
+ ! CHECK: hlfir.yield_element
+ parr = previous(arr, stat=stat)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPtest_next_array_optional_stat(
+subroutine test_next_array_optional_stat(arr, stat)
+ use enum_np_mod
+ type(color), intent(in) :: arr(3)
+ integer, optional, intent(out) :: stat(3)
+ type(color) :: narr(3)
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_array_optional_statEstat"}
+ ! CHECK: %[[PRES:.*]] = fir.is_present %[[STAT]]#0 : (!fir.ref<!fir.array<3xi32>>) -> i1
+ ! CHECK: hlfir.elemental %{{[0-9]+}} : (!fir.shape<1>)
+ ! CHECK: ^bb0(%[[I:.*]]: index):
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: fir.if %[[PRES]] {
+ ! CHECK: %[[SE:.*]] = hlfir.designate %[[STAT]]#0 (%[[I]])
+ ! CHECK: arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign %{{.*}} to %[[SE]] : i32, !fir.ref<i32>
+ ! CHECK: } else {
+ ! CHECK: fir.if %[[BOUND]] {
+ ! CHECK: fir.call @_FortranAReportFatalUserError
+ narr = next(arr, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() inside WHERE
+! -----------------------------------------------------------------------------
+
+! The ordered elemental is only evaluated for elements where the mask is true,
+! so a boundary in a masked-off element does not terminate.
+
+! CHECK-LABEL: func.func @_QPtest_next_where(
+subroutine test_next_where(arr, mask)
+ use enum_np_mod
+ type(color), intent(in) :: arr(3)
+ logical, intent(in) :: mask(3)
+ type(color) :: narr(3)
+ ! CHECK: hlfir.where {
+ ! CHECK: } do {
+ ! CHECK: hlfir.region_assign {
+ ! CHECK: hlfir.elemental %{{[0-9]+}} : (!fir.shape<1>) -> !hlfir.expr<3x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>> {
+ ! CHECK: fir.call @_FortranAReportFatalUserError
+ ! CHECK: hlfir.yield_element
+ where (mask) narr = next(arr)
+end subroutine
+
+! The STAT write is inside the masked elemental, so STAT elements where the
+! mask is false are left unchanged.
+
+! CHECK-LABEL: func.func @_QPtest_next_where_stat(
+subroutine test_next_where_stat(arr, mask)
+ use enum_np_mod
+ type(color), intent(in) :: arr(3)
+ logical, intent(in) :: mask(3)
+ type(color) :: narr(3)
+ integer :: stat(3)
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_next_where_statEstat"}
+ ! CHECK: hlfir.where {
+ ! CHECK: } do {
+ ! CHECK: hlfir.region_assign {
+ ! CHECK: hlfir.elemental %{{[0-9]+}} : (!fir.shape<1>) -> !hlfir.expr<3x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>> {
+ ! CHECK: ^bb0(%[[I:.*]]: index):
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: %[[SE:.*]] = hlfir.designate %[[STAT]]#0 (%[[I]])
+ ! CHECK: %[[S:.*]] = arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign %[[S]] to %[[SE]] : i32, !fir.ref<i32>
+ ! CHECK: hlfir.yield_element
+ ! CHECK: } to {
+ where (mask) narr = next(arr, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() with a scalar A and an array STAT
+! -----------------------------------------------------------------------------
+
+! The result shape comes from STAT, and A is read in every iteration.
+
+! CHECK-LABEL: func.func @_QPtest_next_scalar_a_array_stat(
+subroutine test_next_scalar_a_array_stat(c)
+ use enum_np_mod
+ type(color), intent(in) :: c
+ type(color) :: narr(3)
+ integer :: stat(3)
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_scalar_a_array_statEc"}
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}}(%[[SHAPE:.*]]) {uniq_name = "_QFtest_next_scalar_a_array_statEstat"}
+ ! CHECK: hlfir.elemental %[[SHAPE]] : (!fir.shape<1>) -> !hlfir.expr<3x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>> {
+ ! CHECK: ^bb0(%[[I:.*]]: index):
+ ! CHECK: hlfir.designate %[[C]]#0{"__ordinal"}
+ ! CHECK: %[[SE:.*]] = hlfir.designate %[[STAT]]#0 (%[[I]])
+ ! CHECK: hlfir.assign %{{.*}} to %[[SE]] : i32, !fir.ref<i32>
+ narr = next(c, stat=stat)
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test NEXT() with a vector-subscripted STAT
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_next_vector_subscript_stat(
+subroutine test_next_vector_subscript_stat(arr, idx)
+ use enum_np_mod
+ type(color), intent(in) :: arr(3)
+ integer, intent(in) :: idx(3)
+ type(color) :: narr(3)
+ integer :: stat(5)
+ ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_next_vector_subscript_statEstat"}
+ ! CHECK: %[[IDX:.*]] = hlfir.elemental %{{.*}} unordered : (!fir.shape<1>) -> !hlfir.expr<3xi64> {
+ ! CHECK: hlfir.elemental %{{[0-9]+}} : (!fir.shape<1>) -> !hlfir.expr<3x!fir.type<_QMenum_np_modTcolor{__ordinal:i32}>> {
+ ! CHECK: ^bb0(%[[I:.*]]: index):
+ ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
+ ! CHECK: %[[J:.*]] = hlfir.apply %[[IDX]], %[[I]] : (!hlfir.expr<3xi64>, index) -> i64
+ ! CHECK: %[[SE:.*]] = hlfir.designate %[[STAT]]#0 (%[[J]])
+ ! CHECK: %[[S:.*]] = arith.select %[[BOUND]]
+ ! CHECK: hlfir.assign %[[S]] to %[[SE]] : i32, !fir.ref<i32>
+ ! CHECK: hlfir.destroy %[[IDX]]
+ narr = next(arr, stat=stat(idx))
+end subroutine
+
+! -----------------------------------------------------------------------------
+! Test STAT of non-default integer kinds
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func.func @_QPtest_next_stat_kinds(
+subroutine test_next_stat_kinds(c, arr)
+ use enum_np_mod
+ type(color), intent(in) :: c, arr(3)
+ type(color) :: nc, parr(3)
+ integer(8) :: stat8
+ integer(2) :: stat2(3)
+ ! CHECK: %[[S2:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_next_stat_kindsEstat2"} : (!fir.ref<!fir.array<3xi16>>
+ ! CHECK: %[[S8:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_next_stat_kindsEstat8"} : (!fir.ref<i64>)
+ ! CHECK-DAG: %[[C112_8:.*]] = arith.constant 112 : i64
+ ! CHECK-DAG: %[[C0_8:.*]] = arith.constant 0 : i64
+ ! CHECK: %[[V8:.*]] = arith.select %{{.*}}, %[[C112_8]], %[[C0_8]] : i64
+ ! CHECK: hlfir.assign %[[V8]] to %[[S8]]#0 : i64, !fir.ref<i64>
+ nc = next(c, stat=stat8)
+ ! CHECK: hlfir.elemental
+ ! CHECK: %[[E2:.*]] = hlfir.designate %[[S2]]#0 (%{{.*}}) : (!fir.ref<!fir.array<3xi16>>, index) -> !fir.ref<i16>
+ ! CHECK-DAG: %[[C112_2:.*]] = arith.constant 112 : i16
+ ! CHECK-DAG: %[[C0_2:.*]] = arith.constant 0 : i16
+ ! CHECK: %[[V2:.*]] = arith.select %{{.*}}, %[[C112_2]], %[[C0_2]] : i16
+ ! CHECK: hlfir.assign %[[V2]] to %[[E2]] : i16, !fir.ref<i16>
+ parr = previous(arr, stat=stat2)
+end subroutine
+
+! CHECK: fir.string_lit "NEXT or PREVIOUS of enumeration type at boundary without STAT=\00"
diff --git a/flang/test/Lower/enumeration-type.f90 b/flang/test/Lower/enumeration-type.f90
index 9093ae8fe7d92..905a375c17a40 100644
--- a/flang/test/Lower/enumeration-type.f90
+++ b/flang/test/Lower/enumeration-type.f90
@@ -1,6 +1,8 @@
-! Test lowering of enumeration types to HLFIR/FIR.
-! Enumeration types lower to i32 values representing 1-based ordinal positions.
+! Test lowering of enumeration types to HLFIR.
+! An enumeration type lowers to a record type with a single i32 component,
+! __ordinal, holding the 1-based ordinal of the enumerator.
! RUN: %flang_fc1 -fenumeration-type -emit-hlfir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -fenumeration-type -emit-fir %s -o /dev/null
module enum_mod
enumeration type :: color
@@ -9,47 +11,52 @@ module enum_mod
end module
! -----------------------------------------------------------------------------
-! Test enumeration type maps to i32 (not fir.type)
+! Test enumeration variable is a record type
! -----------------------------------------------------------------------------
! CHECK-LABEL: func.func @_QPtest_enum_variable()
subroutine test_enum_variable()
use enum_mod
type(color) :: c
- ! CHECK: %[[ALLOC:.*]] = fir.alloca i32
+ ! CHECK: %[[ALLOC:.*]] = fir.alloca !fir.type<_QMenum_modTcolor{__ordinal:i32}> <{bindc_name = "c"
! CHECK: hlfir.declare %[[ALLOC]]
c = red
end subroutine
! -----------------------------------------------------------------------------
-! Test enumerator constants lower to i32 constants
+! Test enumerator constants lower to record constants
! -----------------------------------------------------------------------------
+! The ordinal of each read-only constant is checked with the globals at the end
+! of the file.
+
! CHECK-LABEL: func.func @_QPtest_enumerator_constants()
subroutine test_enumerator_constants()
use enum_mod
type(color) :: c
- ! CHECK: %[[RED:.*]] = arith.constant 1 : i32
- ! CHECK: hlfir.assign %[[RED]]
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_enumerator_constantsEc"}
+ ! CHECK: %[[RED_ADDR:.*]] = fir.address_of(@[[RED:_QQro\._QMenum_modTcolor\.[0-9]+]])
+ ! CHECK: %[[RED_DECL:.*]]:2 = hlfir.declare %[[RED_ADDR]]
+ ! CHECK: hlfir.assign %[[RED_DECL]]#0 to %[[C]]#0 : !fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>, !fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>
c = red
- ! CHECK: %[[GREEN:.*]] = arith.constant 2 : i32
- ! CHECK: hlfir.assign %[[GREEN]]
+ ! CHECK: fir.address_of(@[[GREEN:_QQro\._QMenum_modTcolor\.[0-9]+]])
+ ! CHECK: hlfir.assign
c = green
- ! CHECK: %[[BLUE:.*]] = arith.constant 3 : i32
- ! CHECK: hlfir.assign %[[BLUE]]
+ ! CHECK: fir.address_of(@[[BLUE:_QQro\._QMenum_modTcolor\.[0-9]+]])
+ ! CHECK: hlfir.assign
c = blue
end subroutine
! -----------------------------------------------------------------------------
-! Test enumeration constructor — color(n) → i32 constant
+! Test enumeration constructor with a constant argument
! -----------------------------------------------------------------------------
! CHECK-LABEL: func.func @_QPtest_constructor()
subroutine test_constructor()
use enum_mod
type(color) :: c
- ! CHECK: %[[C2:.*]] = arith.constant 2 : i32
- ! CHECK: hlfir.assign %[[C2]]
+ ! CHECK: fir.address_of(@[[CTOR2:_QQro\._QMenum_modTcolor\.[0-9]+]])
+ ! CHECK: hlfir.assign
! Constant argument is range-checked at compile time (semantics), so no
! runtime range check is emitted here.
! CHECK-NOT: fir.call @{{.*}}ReportFatalUserError
@@ -65,11 +72,12 @@ subroutine test_constructor()
! error termination (F2023 7.6.2 para 5).
! CHECK-LABEL: func.func @_QPtest_constructor_runtime(
-! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+! CHECK-SAME: %{{.*}}: !fir.ref<i32>
subroutine test_constructor_runtime(i)
use enum_mod
integer, intent(in) :: i
type(color) :: c
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_constructor_runtimeEc"}
! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
! CHECK-DAG: %[[ONE:.*]] = arith.constant 1 : i32
! CHECK-DAG: %[[MAX:.*]] = arith.constant 3 : i32
@@ -79,7 +87,35 @@ subroutine test_constructor_runtime(i)
! CHECK: fir.if %[[OOR]] {
! CHECK: fir.call @{{.*}}ReportFatalUserError
! CHECK: }
- ! CHECK: hlfir.assign %[[ORD]]
+ ! CHECK: %[[TMP:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "ctor.temp"}
+ ! CHECK: %[[F:.*]] = hlfir.designate %[[TMP]]#0{"__ordinal"}
+ ! CHECK: hlfir.assign %[[ORD]] to %[[F]] : i32, !fir.ref<i32>
+ ! CHECK: hlfir.assign %[[TMP]]#0 to %[[C]]#0
+ c = color(i)
+end subroutine
+
+! The range check uses the argument's own kind, before it is narrowed to the
+! i32 ordinal, so a large INTEGER(8) value cannot wrap into range.
+
+! CHECK-LABEL: func.func @_QPtest_constructor_int8(
+! CHECK-SAME: %{{.*}}: !fir.ref<i64>
+subroutine test_constructor_int8(i)
+ use enum_mod
+ integer(8), intent(in) :: i
+ type(color) :: c
+ ! CHECK: %[[I:.*]] = fir.load %{{.*}} : !fir.ref<i64>
+ ! CHECK-DAG: %[[ONE:.*]] = arith.constant 1 : i64
+ ! CHECK-DAG: %[[MAX:.*]] = arith.constant 3 : i64
+ ! CHECK: %[[LOW:.*]] = arith.cmpi slt, %[[I]], %[[ONE]] : i64
+ ! CHECK: %[[HIGH:.*]] = arith.cmpi sgt, %[[I]], %[[MAX]] : i64
+ ! CHECK: %[[OOR:.*]] = arith.ori %[[LOW]], %[[HIGH]] : i1
+ ! CHECK: fir.if %[[OOR]] {
+ ! CHECK: fir.call @{{.*}}ReportFatalUserError
+ ! CHECK: }
+ ! CHECK: %[[ORD:.*]] = fir.convert %[[I]] : (i64) -> i32
+ ! CHECK: %[[TMP:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "ctor.temp"}
+ ! CHECK: %[[F:.*]] = hlfir.designate %[[TMP]]#0{"__ordinal"}
+ ! CHECK: hlfir.assign %[[ORD]] to %[[F]] : i32, !fir.ref<i32>
c = color(i)
end subroutine
@@ -88,13 +124,17 @@ subroutine test_constructor_runtime(i)
! -----------------------------------------------------------------------------
! CHECK-LABEL: func.func @_QPtest_comparisons(
-! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<i32>{{.*}}, %[[ARG1:.*]]: !fir.ref<i32>{{.*}})
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>> {fir.bindc_name = "c1"}, %{{.*}}: !fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>> {fir.bindc_name = "c2"})
subroutine test_comparisons(c1, c2)
use enum_mod
type(color), intent(in) :: c1, c2
logical :: l
- ! CHECK: %[[V1:.*]] = fir.load %{{.*}} : !fir.ref<i32>
- ! CHECK: %[[V2:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK: %[[C1:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_comparisonsEc1"}
+ ! CHECK: %[[C2:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_comparisonsEc2"}
+ ! CHECK: %[[F1:.*]] = hlfir.designate %[[C1]]#0{"__ordinal"}
+ ! CHECK: %[[V1:.*]] = fir.load %[[F1]] : !fir.ref<i32>
+ ! CHECK: %[[F2:.*]] = hlfir.designate %[[C2]]#0{"__ordinal"}
+ ! CHECK: %[[V2:.*]] = fir.load %[[F2]] : !fir.ref<i32>
! CHECK: arith.cmpi eq, %[[V1]], %[[V2]] : i32
l = (c1 == c2)
! CHECK: arith.cmpi slt
@@ -117,141 +157,51 @@ subroutine test_comparisons(c1, c2)
subroutine test_int_conversion()
use enum_mod
integer :: i
+ ! CHECK: %[[I:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_int_conversionEi"}
! CHECK: %[[C1:.*]] = arith.constant 1 : i32
+ ! CHECK: hlfir.assign %[[C1]] to %[[I]]#0 : i32, !fir.ref<i32>
i = int(red)
end subroutine
-! -----------------------------------------------------------------------------
-! Test HUGE() — returns enumerator count as i32 constant
-! -----------------------------------------------------------------------------
-
-! CHECK-LABEL: func.func @_QPtest_huge()
-subroutine test_huge()
- use enum_mod
- type(color) :: c
- ! CHECK: arith.constant 3 : i32
- c = huge(red)
-end subroutine
-
-! -----------------------------------------------------------------------------
-! Test NEXT() with variable argument
-! -----------------------------------------------------------------------------
-
-! CHECK-LABEL: func.func @_QPtest_next(
-! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
-subroutine test_next(c)
+! CHECK-LABEL: func.func @_QPtest_int_variable(
+subroutine test_int_variable(c, arr)
use enum_mod
- type(color), intent(in) :: c
- type(color) :: result
- integer :: stat
- ! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
- ! Compute: min(ordinal + 1, 3). Constants are hoisted, so match order-free.
- ! CHECK-DAG: %[[ONE:.*]] = arith.constant 1 : i32
- ! CHECK-DAG: %[[MAX:.*]] = arith.constant 3 : i32
- ! CHECK: %[[INC:.*]] = arith.addi %[[ORD]], %[[ONE]] : i32
- ! CHECK: %[[CMP:.*]] = arith.cmpi sle, %[[INC]], %[[MAX]] : i32
- ! CHECK: %[[RES:.*]] = arith.select %[[CMP]], %[[INC]], %[[MAX]] : i32
- ! Boundary check: ordinal == 3
- ! CHECK: %[[BOUND:.*]] = arith.cmpi eq, %[[ORD]], %[[MAX]] : i32
- ! A non-optional local STAT needs no runtime presence check.
- ! CHECK-NOT: fir.is_present
- ! STAT handling: select 112 or 0
- ! CHECK: arith.constant 112
- ! CHECK: arith.constant 0
- ! CHECK: arith.select %[[BOUND]]
- ! CHECK: hlfir.assign
- result = next(c, stat=stat)
+ type(color), intent(in) :: c, arr(3)
+ integer :: i, iarr(3)
+ integer(8) :: j
+ ! CHECK: %[[ARR:.*]]:2 = hlfir.declare %{{.*}}(%[[SHAPE:[0-9]+]]) dummy_scope %{{.*}} {{.*}}uniq_name = "_QFtest_int_variableEarr"}
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_int_variableEc"}
+ ! CHECK: %[[I:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_int_variableEi"}
+ ! CHECK: %[[IARR:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_int_variableEiarr"}
+ ! CHECK: %[[J:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_int_variableEj"}
+ ! CHECK: %[[F1:.*]] = hlfir.designate %[[C]]#0{"__ordinal"}
+ ! CHECK: %[[V1:.*]] = fir.load %[[F1]] : !fir.ref<i32>
+ ! CHECK: hlfir.assign %[[V1]] to %[[I]]#0 : i32, !fir.ref<i32>
+ i = int(c)
+ ! CHECK: %[[F2:.*]] = hlfir.designate %[[C]]#0{"__ordinal"}
+ ! CHECK: %[[V2:.*]] = fir.load %[[F2]] : !fir.ref<i32>
+ ! CHECK: %[[V2_8:.*]] = fir.convert %[[V2]] : (i32) -> i64
+ ! CHECK: hlfir.assign %[[V2_8]] to %[[J]]#0 : i64, !fir.ref<i64>
+ j = int(c, kind=8)
+ ! CHECK: %[[FA:.*]] = hlfir.designate %[[ARR]]#0{"__ordinal"} shape %[[SHAPE]] : {{.*}} -> !fir.box<!fir.array<3xi32>>
+ ! CHECK: %[[EL:.*]] = hlfir.elemental %[[SHAPE]] unordered : (!fir.shape<1>) -> !hlfir.expr<3xi32> {
+ ! CHECK: hlfir.designate %[[FA]] (%{{.*}})
+ ! CHECK: hlfir.yield_element %{{.*}} : i32
+ ! CHECK: hlfir.assign %[[EL]] to %[[IARR]]#0
+ iarr = int(arr)
end subroutine
! -----------------------------------------------------------------------------
-! Test PREVIOUS() with variable argument
+! Test HUGE() — returns the last enumerator
! -----------------------------------------------------------------------------
-! CHECK-LABEL: func.func @_QPtest_previous(
-! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
-subroutine test_previous(c)
+! CHECK-LABEL: func.func @_QPtest_huge()
+subroutine test_huge()
use enum_mod
- type(color), intent(in) :: c
- type(color) :: result
- integer :: stat
- ! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
- ! Compute: max(ordinal - 1, 1)
- ! CHECK: %[[ONE:.*]] = arith.constant 1 : i32
- ! CHECK: %[[DEC:.*]] = arith.subi %[[ORD]], %[[ONE]] : i32
- ! CHECK: %[[CMP:.*]] = arith.cmpi sge, %[[DEC]], %[[ONE]] : i32
- ! CHECK: %[[RES:.*]] = arith.select %[[CMP]], %[[DEC]], %[[ONE]] : i32
- ! Boundary check: ordinal == 1
- ! CHECK: %[[BOUND:.*]] = arith.cmpi eq, %[[ORD]], %[[ONE]] : i32
- ! STAT handling: select 112 or 0
- ! CHECK: arith.constant 112
- ! CHECK: arith.constant 0
- ! CHECK: arith.select %[[BOUND]]
+ type(color) :: c
+ ! CHECK: fir.address_of(@[[BLUE]])
! CHECK: hlfir.assign
- result = previous(c, stat=stat)
-end subroutine
-
-! -----------------------------------------------------------------------------
-! Test NEXT() without STAT — generates fatal error path
-! -----------------------------------------------------------------------------
-
-! CHECK-LABEL: func.func @_QPtest_next_no_stat(
-subroutine test_next_no_stat(c)
- use enum_mod
- type(color), intent(in) :: c
- type(color) :: result
- ! CHECK: %[[ORD:.*]] = fir.load %{{.*}} : !fir.ref<i32>
- ! CHECK: arith.addi
- ! CHECK: arith.cmpi sle
- ! CHECK: arith.select
- ! Boundary without STAT — fir.if for fatal error
- ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
- ! CHECK: fir.if %[[BOUND]]
- ! CHECK: fir.call @{{.*}}ReportFatalUserError
- ! CHECK: }
- result = next(c)
-end subroutine
-
-! -----------------------------------------------------------------------------
-! Test NEXT() with a STAT that may be absent at runtime
-! -----------------------------------------------------------------------------
-
-! An absent optional dummy (or unallocated allocatable) forwarded as STAT= is
-! not present: STAT must not be written and the boundary is a fatal error.
-
-! CHECK-LABEL: func.func @_QPtest_next_optional_stat(
-subroutine test_next_optional_stat(c, stat)
- use enum_mod
- type(color), intent(in) :: c
- integer, optional, intent(out) :: stat
- type(color) :: result
- ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_optional_statEstat"}
- ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
- ! CHECK: %[[PRES:.*]] = fir.is_present %[[STAT]]#0 : (!fir.ref<i32>) -> i1
- ! CHECK: fir.if %[[PRES]] {
- ! CHECK: arith.select %[[BOUND]]
- ! CHECK: hlfir.assign %{{.*}} to %[[STAT]]#0
- ! CHECK: } else {
- ! CHECK: fir.if %[[BOUND]] {
- ! CHECK: fir.call @{{.*}}ReportFatalUserError
- result = next(c, stat=stat)
-end subroutine
-
-! CHECK-LABEL: func.func @_QPtest_next_allocatable_stat(
-subroutine test_next_allocatable_stat(c, stat)
- use enum_mod
- type(color), intent(in) :: c
- integer, allocatable, intent(inout) :: stat
- type(color) :: result
- ! CHECK: %[[BOUND:.*]] = arith.cmpi eq
- ! CHECK: fir.box_addr
- ! CHECK: %[[PRES:.*]] = arith.cmpi ne
- ! CHECK: fir.if %[[PRES]] {
- ! CHECK: arith.select %[[BOUND]]
- ! CHECK: hlfir.assign
- ! CHECK: } else {
- ! CHECK: fir.if %[[BOUND]] {
- ! CHECK: fir.call @{{.*}}ReportFatalUserError
- result = next(c, stat=stat)
+ c = huge(red)
end subroutine
! -----------------------------------------------------------------------------
@@ -263,7 +213,9 @@ subroutine test_select_case(c)
use enum_mod
type(color), intent(in) :: c
integer :: result
- ! CHECK: %[[SEL:.*]] = fir.load %{{.*}} : !fir.ref<i32>
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_select_caseEc"}
+ ! CHECK: %[[F:.*]] = hlfir.designate %[[C]]#0{"__ordinal"}
+ ! CHECK: %[[SEL:.*]] = fir.load %[[F]] : !fir.ref<i32>
! CHECK: %[[C1:.*]] = arith.constant 1 : i32
! CHECK: %[[C2:.*]] = arith.constant 2 : i32
! CHECK: %[[C3:.*]] = arith.constant 3 : i32
@@ -283,13 +235,15 @@ subroutine test_select_case(c)
! -----------------------------------------------------------------------------
! CHECK-LABEL: func.func @_QPtest_formatted_write(
-! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>
subroutine test_formatted_write(c)
use enum_mod
type(color), intent(in) :: c
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_formatted_writeEc"}
! CHECK: fir.call @_FortranAioBeginExternalFormattedOutput
- ! CHECK: %[[VAL:.*]] = fir.load %{{.*}} : !fir.ref<i32>
- ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[VAL]])
+ ! CHECK: %[[BOX:.*]] = fir.embox %[[C]]#0 : (!fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>) -> !fir.box<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>
+ ! CHECK: %[[ARG:.*]] = fir.convert %[[BOX]]
+ ! CHECK: fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[ARG]], %{{.*}})
! CHECK: fir.call @_FortranAioEndIoStatement
write(*, '(I4)') c
end subroutine
@@ -299,13 +253,15 @@ subroutine test_formatted_write(c)
! -----------------------------------------------------------------------------
! CHECK-LABEL: func.func @_QPtest_formatted_read(
-! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>
subroutine test_formatted_read(c)
use enum_mod
type(color), intent(inout) :: c
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_formatted_readEc"}
! CHECK: fir.call @_FortranAioBeginExternalFormattedInput
- ! CHECK: %[[CONV:.*]] = fir.convert %{{.*}} : (!fir.ref<i32>) -> !fir.ref<i64>
- ! CHECK: fir.call @_FortranAioInputInteger(%{{.*}}, %[[CONV]], %{{.*}})
+ ! CHECK: %[[BOX:.*]] = fir.embox %[[C]]#0 : (!fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>) -> !fir.box<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>
+ ! CHECK: %[[ARG:.*]] = fir.convert %[[BOX]]
+ ! CHECK: fir.call @_FortranAioInputDerivedType(%{{.*}}, %[[ARG]], %{{.*}})
! CHECK: fir.call @_FortranAioEndIoStatement
read(*, '(I4)') c
end subroutine
@@ -314,26 +270,22 @@ subroutine test_formatted_read(c)
! Test enumeration type as a function result
! -----------------------------------------------------------------------------
-! An enumeration result lowers to i32 and is returned by value like an integer;
-! it must not use the caller-allocated fir.save_result ABI reserved for
-! record-shaped derived results.
-
module enum_func_mod
enumeration type :: color2
enumerator :: c2red, c2green, c2blue
end enumeration type
contains
- ! CHECK-LABEL: func.func @_QMenum_func_modPpick() -> i32
+ ! CHECK-LABEL: func.func @_QMenum_func_modPpick() -> !fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>
function pick() result(c)
type(color2) :: c
c = c2blue
end function
- ! CHECK-LABEL: func.func @_QMenum_func_modPpick_array() -> !fir.array<3xi32>
+ ! CHECK-LABEL: func.func @_QMenum_func_modPpick_array() -> !fir.array<3x!fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>>
function pick_array() result(c)
type(color2) :: c(3)
c = [c2red, c2green, c2blue]
end function
- ! CHECK-LABEL: func.func @_QMenum_func_modPpick_alloc() -> !fir.box<!fir.heap<!fir.array<?xi32>>>
+ ! CHECK-LABEL: func.func @_QMenum_func_modPpick_alloc() -> !fir.box<!fir.heap<!fir.array<?x!fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>>>>
function pick_alloc() result(c)
type(color2), allocatable :: c(:)
c = [c2red, c2green, c2blue]
@@ -345,26 +297,27 @@ subroutine test_func_result()
use enum_func_mod
type(color2) :: c
logical :: l
- ! Result returned by value as i32, with no fir.save_result.
- ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick() {{.*}}: () -> i32
- ! CHECK-NOT: fir.save_result
- ! CHECK: hlfir.assign %[[RES]]
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_func_resultEc"}
+ ! CHECK: %[[TMP:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = ".tmp.func_result"}
+ ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick() {{.*}}: () -> !fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>
+ ! CHECK: fir.save_result %[[RES]] to %[[TMP]]#0
+ ! CHECK: %[[E:.*]] = hlfir.as_expr %[[TMP]]#0
+ ! CHECK: hlfir.assign %[[E]] to %[[C]]#0
c = pick()
- ! The result is a genuine enumeration value: comparison lowers to i32 cmpi.
- ! CHECK: arith.cmpi eq, %{{.*}}, %{{.*}} : i32
+ ! CHECK: %[[F:.*]] = hlfir.designate %[[C]]#0{"__ordinal"}
+ ! CHECK: %[[V:.*]] = fir.load %[[F]] : !fir.ref<i32>
+ ! CHECK: %[[THREE:.*]] = arith.constant 3 : i32
+ ! CHECK: arith.cmpi eq, %[[V]], %[[THREE]] : i32
l = (c == c2blue)
end subroutine
-! Non-scalar enumeration results (array, allocatable) use the normal
-! caller-allocated fir.save_result ABI, like integer arrays.
-
! CHECK-LABEL: func.func @_QPtest_func_result_array()
subroutine test_func_result_array()
use enum_func_mod
type(color2) :: c(3)
- ! CHECK: hlfir.eval_in_mem {{.*}} -> !hlfir.expr<3xi32> {
- ! CHECK: ^bb0(%[[TMP:.*]]: !fir.ref<!fir.array<3xi32>>):
- ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick_array() {{.*}}: () -> !fir.array<3xi32>
+ ! CHECK: hlfir.eval_in_mem {{.*}} -> !hlfir.expr<3x!fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>> {
+ ! CHECK: ^bb0(%[[TMP:.*]]: !fir.ref<!fir.array<3x!fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>>>):
+ ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick_array() {{.*}}: () -> !fir.array<3x!fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>>
! CHECK: fir.save_result %[[RES]] to %[[TMP]]
c = pick_array()
end subroutine
@@ -373,9 +326,8 @@ subroutine test_func_result_array()
subroutine test_func_result_alloc()
use enum_func_mod
type(color2), allocatable :: c(:)
- ! CHECK: %[[TMP:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> <{bindc_name = ".result"}>
- ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick_alloc() {{.*}}: () -> !fir.box<!fir.heap<!fir.array<?xi32>>>
- ! CHECK: fir.save_result %[[RES]] to %{{.*}} : !fir.box<!fir.heap<!fir.array<?xi32>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+ ! CHECK: %[[RES:.*]] = fir.call @_QMenum_func_modPpick_alloc() {{.*}}: () -> !fir.box<!fir.heap<!fir.array<?x!fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>>>>
+ ! CHECK: fir.save_result %[[RES]] to %{{.*}} : !fir.box<!fir.heap<!fir.array<?x!fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.type<_QMenum_func_modTcolor2{__ordinal:i32}>>>>>
c = pick_alloc()
end subroutine
@@ -387,14 +339,15 @@ subroutine test_func_result_alloc()
subroutine test_enum_arg_pass()
use enum_mod
type(color) :: c
+ ! CHECK: %[[C:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = "_QFtest_enum_arg_passEc"}
+ ! CHECK: hlfir.assign %{{.*}} to %[[C]]#0
+ ! CHECK: fir.call @_QPtake_enum(%[[C]]#0) {{.*}}: (!fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>) -> ()
c = green
- ! CHECK: %[[C2:.*]] = arith.constant 2 : i32
- ! CHECK: fir.call @_QPtake_enum
call take_enum(c)
end subroutine
! CHECK-LABEL: func.func @_QPtake_enum(
-! CHECK-SAME: %[[ARG:.*]]: !fir.ref<i32>
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>> {fir.bindc_name = "c"}
subroutine take_enum(c)
use enum_mod
type(color), intent(in) :: c
@@ -404,17 +357,14 @@ subroutine take_enum(c)
! Test enumeration-typed scalar PARAMETER
! -----------------------------------------------------------------------------
-! A named constant of enumeration type must lower to an i32 constant, not a
-! record type (previously asserted on cast<fir::RecordType> in ConvertConstant).
-
! CHECK-LABEL: func.func @_QPtest_enum_parameter()
subroutine test_enum_parameter()
use enum_mod
type(color), parameter :: cRed = red
type(color) :: c
- ! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QFtest_enum_parameterECcred"} : (!fir.ref<i32>)
- ! CHECK: %[[C1:.*]] = arith.constant 1 : i32
- ! CHECK: hlfir.assign %[[C1]]
+ ! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QFtest_enum_parameterECcred"} : (!fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>)
+ ! CHECK: fir.address_of(@[[RED]])
+ ! CHECK: hlfir.assign
c = cRed
end subroutine
@@ -422,14 +372,11 @@ subroutine test_enum_parameter()
! Test enumeration array constructor
! -----------------------------------------------------------------------------
-! An array constructor of enumerators must lower to an i32 array constant, not a
-! record-typed array (previously asserted on cast<fir::RecordType>).
-
! CHECK-LABEL: func.func @_QPtest_array_constructor()
subroutine test_array_constructor()
use enum_mod
type(color) :: arr(3)
- ! CHECK: %[[RO:.*]] = fir.address_of(@_QQro.3x_QMenum_modTcolor.{{[0-9]+}}) : !fir.ref<!fir.array<3xi32>>
+ ! CHECK: %[[RO:.*]] = fir.address_of(@[[ARR:_QQro\.3x_QMenum_modTcolor\.[0-9]+]]) : !fir.ref<!fir.array<3x!fir.type<_QMenum_modTcolor{__ordinal:i32}>>>
! CHECK: hlfir.declare %[[RO]]
! CHECK: hlfir.assign
arr = [red, green, blue]
@@ -444,99 +391,78 @@ subroutine test_array_parameter()
use enum_mod
type(color), parameter :: pal(3) = [red, green, blue]
type(color) :: arr(3)
- ! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QFtest_array_parameterECpal"} : (!fir.ref<!fir.array<3xi32>>, !fir.shape<1>)
+ ! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QFtest_array_parameterECpal"} : (!fir.ref<!fir.array<3x!fir.type<_QMenum_modTcolor{__ordinal:i32}>>>, !fir.shape<1>)
! CHECK: hlfir.assign
arr = pal
end subroutine
! -----------------------------------------------------------------------------
-! Test NEXT() over a whole array (elemental)
+! Test SELECT TYPE and ALLOCATE with an enumeration type
! -----------------------------------------------------------------------------
-! NEXT()/PREVIOUS() applied to an array argument lower to an hlfir.elemental over
-! i32 ordinals (previously asserted on getIntOrFloatBitWidth for the array case).
+! An enumeration type is a distinct dynamic type: TYPE IS (color) and
+! TYPE IS (integer) must be separate guards.
-! CHECK-LABEL: func.func @_QPtest_next_array(
-subroutine test_next_array(arr)
+! CHECK-LABEL: func.func @_QPtest_select_type(
+subroutine test_select_type(x)
use enum_mod
- type(color), intent(in) :: arr(3)
- type(color) :: narr(3)
- integer :: stat(3)
- ! Value elemental: min(ordinal + 1, 3).
- ! CHECK: hlfir.elemental %{{.*}} unordered : (!fir.shape<1>) -> !hlfir.expr<3xi32> {
- ! CHECK: %[[ELE:.*]] = hlfir.designate %{{.*}} : (!fir.ref<!fir.array<3xi32>>, index) -> !fir.ref<i32>
- ! CHECK: %[[ORD:.*]] = fir.load %[[ELE]] : !fir.ref<i32>
- ! CHECK-DAG: %[[ONE:.*]] = arith.constant 1 : i32
- ! CHECK-DAG: %[[MAX:.*]] = arith.constant 3 : i32
- ! CHECK: %[[INC:.*]] = arith.addi %[[ORD]], %[[ONE]] : i32
- ! CHECK: %[[CMP:.*]] = arith.cmpi sle, %[[INC]], %[[MAX]] : i32
- ! CHECK: %[[SEL:.*]] = arith.select %[[CMP]], %[[INC]], %[[MAX]] : i32
- ! CHECK: hlfir.yield_element %[[SEL]] : i32
- ! STAT elemental: 112 at the last enumerator, else 0.
- ! CHECK: hlfir.elemental %{{.*}} unordered : (!fir.shape<1>) -> !hlfir.expr<3xi32> {
- ! CHECK: arith.cmpi eq, %{{.*}}, %{{.*}} : i32
- ! CHECK-DAG: arith.constant 112 : i32
- ! CHECK-DAG: arith.constant 0 : i32
- ! CHECK: arith.select
- ! CHECK: hlfir.yield_element
- narr = next(arr, stat=stat)
-end subroutine
-
-! -----------------------------------------------------------------------------
-! Test PREVIOUS() over a whole array (elemental)
-! -----------------------------------------------------------------------------
-
-! CHECK-LABEL: func.func @_QPtest_previous_array(
-subroutine test_previous_array(arr)
- use enum_mod
- type(color), intent(in) :: arr(3)
- type(color) :: parr(3)
- integer :: stat(3)
- ! Value elemental: max(ordinal - 1, 1).
- ! CHECK: hlfir.elemental %{{.*}} unordered : (!fir.shape<1>) -> !hlfir.expr<3xi32> {
- ! CHECK: %[[ELE:.*]] = hlfir.designate %{{.*}} : (!fir.ref<!fir.array<3xi32>>, index) -> !fir.ref<i32>
- ! CHECK: %[[ORD:.*]] = fir.load %[[ELE]] : !fir.ref<i32>
- ! CHECK: %[[ONE:.*]] = arith.constant 1 : i32
- ! CHECK: %[[DEC:.*]] = arith.subi %[[ORD]], %[[ONE]] : i32
- ! CHECK: %[[CMP:.*]] = arith.cmpi sge, %[[DEC]], %[[ONE]] : i32
- ! CHECK: %[[SEL:.*]] = arith.select %[[CMP]], %[[DEC]], %[[ONE]] : i32
- ! CHECK: hlfir.yield_element %[[SEL]] : i32
- parr = previous(arr, stat=stat)
+ class(*), intent(in) :: x
+ integer :: r
+ ! CHECK: fir.select_type %{{.*}} : !fir.class<none> [#fir.type_is<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>, ^{{.*}}, #fir.type_is<i32>, ^{{.*}}, unit, ^{{.*}}]
+ ! CHECK: fir.box_addr %{{.*}} : (!fir.class<none>) -> !fir.ref<!fir.type<_QMenum_modTcolor{__ordinal:i32}>>
+ ! CHECK: fir.box_addr %{{.*}} : (!fir.class<none>) -> !fir.ref<i32>
+ select type (x)
+ type is (color)
+ r = 1
+ type is (integer)
+ r = 2
+ end select
end subroutine
-! -----------------------------------------------------------------------------
-! Test NEXT() over an array with a STAT that may be absent
-! -----------------------------------------------------------------------------
-
-! CHECK-LABEL: func.func @_QPtest_next_array_optional_stat(
-subroutine test_next_array_optional_stat(arr, stat)
+! CHECK-LABEL: func.func @_QPtest_allocate_color()
+subroutine test_allocate_color()
use enum_mod
- type(color), intent(in) :: arr(3)
- integer, optional, intent(out) :: stat(3)
- type(color) :: narr(3)
- ! CHECK: %[[STAT:.*]]:2 = hlfir.declare %{{.*}} {{.*}}uniq_name = "_QFtest_next_array_optional_statEstat"}
- ! CHECK: hlfir.elemental
- ! CHECK: %[[PRES:.*]] = fir.is_present %[[STAT]]#0 : (!fir.ref<!fir.array<3xi32>>) -> i1
- ! CHECK: fir.if %[[PRES]] {
- ! CHECK: %[[SE:.*]] = hlfir.elemental
- ! CHECK: hlfir.assign %[[SE]] to %[[STAT]]#0
- ! CHECK: hlfir.destroy %[[SE]]
- ! CHECK: } else {
- ! CHECK: %[[MASK:.*]] = hlfir.elemental
- ! CHECK: hlfir.any %[[MASK]]
- ! CHECK: fir.call @{{.*}}ReportFatalUserError
- ! CHECK: hlfir.destroy %[[MASK]]
- narr = next(arr, stat=stat)
+ class(*), allocatable :: x
+ ! CHECK: %[[TD:.*]] = fir.type_desc !fir.type<_QMenum_modTcolor{__ordinal:i32}>
+ ! CHECK: %[[TDARG:.*]] = fir.convert %[[TD]]
+ ! CHECK: fir.call @_FortranAAllocatableInitDerivedForAllocate(%{{.*}}, %[[TDARG]], %{{.*}}, %{{.*}})
+ ! CHECK: fir.call @_FortranAAllocatableAllocate(
+ allocate(color :: x)
end subroutine
! -----------------------------------------------------------------------------
-! Verify the enum array constructor constant is i32 ordinals 1,2,3
-! -----------------------------------------------------------------------------
-
-! CHECK: fir.global internal @_QQro.3x_QMenum_modTcolor.{{[0-9]+}} {{.*}}constant : !fir.array<3xi32> {
-! CHECK: %[[G1:.*]] = arith.constant 1 : i32
-! CHECK: fir.insert_value %{{.*}}, %[[G1]], [0 : index]
-! CHECK: %[[G2:.*]] = arith.constant 2 : i32
-! CHECK: fir.insert_value %{{.*}}, %[[G2]], [1 : index]
-! CHECK: %[[G3:.*]] = arith.constant 3 : i32
-! CHECK: fir.insert_value %{{.*}}, %[[G3]], [2 : index]
+! Verify the enumeration globals
+! -----------------------------------------------------------------------------
+
+! CHECK: fir.global linkonce_odr @_QMenum_modECred constant : !fir.type<_QMenum_modTcolor{__ordinal:i32}> {
+! CHECK: arith.constant 1 : i32
+! CHECK-NEXT: fir.insert_value
+! CHECK-NEXT: fir.has_value
+
+! The runtime type descriptor for the enumeration type.
+! CHECK: fir.global linkonce_odr @_QMenum_modE.dt.color constant target : !fir.type<_QM__fortran_type_infoTderivedtype
+
+! CHECK: fir.global internal @[[RED]] constant : !fir.type<_QMenum_modTcolor{__ordinal:i32}> {
+! CHECK: arith.constant 1 : i32
+! CHECK-NEXT: fir.insert_value
+! CHECK-NEXT: fir.has_value
+! CHECK: fir.global internal @[[GREEN]] constant : !fir.type<_QMenum_modTcolor{__ordinal:i32}> {
+! CHECK: arith.constant 2 : i32
+! CHECK-NEXT: fir.insert_value
+! CHECK-NEXT: fir.has_value
+! CHECK: fir.global internal @[[BLUE]] constant : !fir.type<_QMenum_modTcolor{__ordinal:i32}> {
+! CHECK: arith.constant 3 : i32
+! CHECK-NEXT: fir.insert_value
+! CHECK-NEXT: fir.has_value
+! CHECK: fir.global internal @[[CTOR2]] constant : !fir.type<_QMenum_modTcolor{__ordinal:i32}> {
+! CHECK: arith.constant 2 : i32
+! CHECK-NEXT: fir.insert_value
+! CHECK-NEXT: fir.has_value
+
+! CHECK: fir.global internal @[[ARR]] {{.*}}constant : !fir.array<3x!fir.type<_QMenum_modTcolor{__ordinal:i32}>> {
+! CHECK: arith.constant 1 : i32
+! CHECK: fir.insert_value %{{.*}}, [0 : index]
+! CHECK: arith.constant 2 : i32
+! CHECK: fir.insert_value %{{.*}}, [1 : index]
+! CHECK: arith.constant 3 : i32
+! CHECK: fir.insert_value %{{.*}}, [2 : index]
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
index 13b76f48fc92a..43f1a5329d2a0 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -214,3 +214,23 @@ subroutine test_next_previous_stat_nonconformant()
!CHECK: error: Dimension 1 of actual argument (arr) corresponding to dummy argument #1 ('a') has extent 3, but actual argument (stat2) corresponding to dummy argument #2 ('stat') has extent 2
pc = previous(arr, stat=stat2)
end subroutine
+
+subroutine test_next_previous_stat_kinds()
+ use enum_intrinsics_mod
+ type(color) :: c, nc, arr(3), narr(3)
+ integer(2) :: s2, s2arr(3)
+ integer(8) :: s8, s8arr(3)
+ integer(1) :: s1
+ real :: sr
+ ! STAT= may be any integer with a decimal exponent range of at least four.
+ nc = next(c, stat=s2)
+ nc = previous(c, stat=s8)
+ narr = next(arr, stat=s2arr)
+ narr = previous(arr, stat=s8arr)
+ !CHECK: error: STAT= argument to NEXT() must be an integer with a decimal exponent range of at least four
+ nc = next(c, stat=s1)
+ !CHECK: error: STAT= argument to PREVIOUS() must be an integer with a decimal exponent range of at least four
+ nc = previous(c, stat=s1)
+ !CHECK: error: STAT= argument to NEXT() must be an integer with a decimal exponent range of at least four
+ nc = next(c, stat=sr)
+end subroutine
More information about the flang-commits
mailing list