[flang-commits] [flang] [llvm] [flang] Enumeration Type: (PR 3/5) Intrinsics + I/O + Modules (PR #193235)
via flang-commits
flang-commits at lists.llvm.org
Thu Jul 2 10:23:56 PDT 2026
https://github.com/kwyatt-ext updated https://github.com/llvm/llvm-project/pull/193235
>From f73f81cb2d0d858433973879dff869a64deb7f72 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 16 Apr 2026 13:38:20 -0500
Subject: [PATCH 1/4] Enumeration Type Sem-3: Intrinsics + I/O + Module Files
(PRs 6-8)
Adds enumeration type intrinsics (HUGE, NEXT, PREVIOUS, INT) with
constant folding, STAT argument support with boundary detection,
formatted I/O rejection for enumeration types, module file round-trip
support, and runtime STAT_ENUM_BOUNDARY error code.
Files from original PRs 6-8 (including PREVIOUS intrinsic from PR 7).
---
flang-rt/include/flang-rt/runtime/stat.h | 1 +
flang-rt/lib/runtime/stat.cpp | 3 +
flang/include/flang/Runtime/magic-numbers.h | 5 +
flang/lib/Evaluate/fold-implementation.h | 75 ++++++-
flang/lib/Evaluate/intrinsics.cpp | 228 +++++++++++++++++++-
flang/lib/Semantics/check-io.cpp | 73 +++++++
flang/lib/Semantics/mod-file.cpp | 86 ++++++++
flang/lib/Semantics/mod-file.h | 3 +
flang/lib/Semantics/type.cpp | 5 +
9 files changed, 477 insertions(+), 2 deletions(-)
diff --git a/flang-rt/include/flang-rt/runtime/stat.h b/flang-rt/include/flang-rt/runtime/stat.h
index dc372de53506a..72d45a29c71fc 100644
--- a/flang-rt/include/flang-rt/runtime/stat.h
+++ b/flang-rt/include/flang-rt/runtime/stat.h
@@ -53,6 +53,7 @@ enum Stat {
StatMoveAllocSameAllocatable =
FORTRAN_RUNTIME_STAT_MOVE_ALLOC_SAME_ALLOCATABLE,
StatBadPointerDeallocation = FORTRAN_RUNTIME_STAT_BAD_POINTER_DEALLOCATION,
+ StatEnumBoundary = FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY,
// Dummy status for work queue continuation, declared here to perhaps
// avoid collisions
diff --git a/flang-rt/lib/runtime/stat.cpp b/flang-rt/lib/runtime/stat.cpp
index 1d4aae2e49736..076b5b81b71d2 100644
--- a/flang-rt/lib/runtime/stat.cpp
+++ b/flang-rt/lib/runtime/stat.cpp
@@ -70,6 +70,9 @@ RT_API_ATTRS const char *StatErrorString(int stat) {
return "DEALLOCATE of a pointer that is not the whole content of a pointer "
"ALLOCATE";
+ case StatEnumBoundary:
+ return "NEXT or PREVIOUS of enumeration type at boundary";
+
default:
return nullptr;
}
diff --git a/flang/include/flang/Runtime/magic-numbers.h b/flang/include/flang/Runtime/magic-numbers.h
index 6788ba098bcf9..2c15103a21bc2 100644
--- a/flang/include/flang/Runtime/magic-numbers.h
+++ b/flang/include/flang/Runtime/magic-numbers.h
@@ -73,6 +73,11 @@ Status codes for GETCWD.
#endif
#define FORTRAN_RUNTIME_STAT_MISSING_CWD 111
+#if 0
+Status code for NEXT/PREVIOUS at enumeration type boundary.
+#endif
+#define FORTRAN_RUNTIME_STAT_ENUM_BOUNDARY 112
+
#if 0
ieee_class_type values
The sequence is that of F18 Clause 17.2p3, but nothing depends on that.
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 2df2b9e5a300b..c59b0ed68289b 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1290,7 +1290,80 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
return Folder<T>{context}.UNPACK(std::move(funcRef));
}
// TODO: extends_type_of, same_type_as
- if constexpr (!std::is_same_v<T, SomeDerived>) {
+ if constexpr (std::is_same_v<T, SomeDerived>) {
+ // Fold enumeration type intrinsics: HUGE(enum), NEXT(enum),
+ // PREVIOUS(enum)
+ if (name == "huge") {
+ // HUGE was eagerly folded — the first arg is the constant result
+ if (args.size() >= 1 && args[0]) {
+ if (auto *expr{UnwrapExpr<Expr<SomeDerived>>(args[0])}) {
+ return std::move(*expr);
+ }
+ }
+ } else if (name == "next" || name == "previous") {
+ // Don't fold if STAT is present — STAT assignment is a side effect
+ if (args.size() >= 2 && args[1]) {
+ return Expr<T>{std::move(funcRef)};
+ }
+ if (args.size() >= 1 && args[0]) {
+ if (auto *expr{UnwrapExpr<Expr<SomeDerived>>(args[0])}) {
+ if (auto type{expr->GetType()}) {
+ if (const auto *derived{GetDerivedTypeSpec(*type)}) {
+ if (derived->IsEnumerationType()) {
+ if (const auto *scope{derived->GetScope()}) {
+ auto ordIter{
+ scope->find(semantics::SourceName{"__ordinal", 9})};
+ if (ordIter != scope->end()) {
+ const semantics::Symbol &ordSym{*ordIter->second};
+ int count{derived->typeSymbol()
+ .GetUltimate()
+ .get<semantics::DerivedTypeDetails>()
+ .enumeratorCount()};
+ // Extract ordinal from constant value
+ if (auto *constant{
+ UnwrapConstantValue<SomeDerived>(*expr)}) {
+ if (auto sc{constant->GetScalarValue()}) {
+ if (auto ordExpr{sc->Find(ordSym)}) {
+ if (auto ordVal{ToInt64(*ordExpr)}) {
+ bool isNext{name == "next"};
+ bool atBoundary{
+ isNext ? *ordVal >= count : *ordVal <= 1};
+ if (atBoundary) {
+ // At boundary without STAT — error
+ // termination at runtime. Don't fold;
+ // emit warning.
+ if (isNext) {
+ context.messages().Say(
+ "NEXT() of last enumerator without STAT= causes error termination"_warn_en_US);
+ } else {
+ context.messages().Say(
+ "PREVIOUS() of first enumerator without STAT= causes error termination"_warn_en_US);
+ }
+ return Expr<T>{std::move(funcRef)};
+ }
+ int newOrd{isNext
+ ? static_cast<int>(*ordVal + 1)
+ : static_cast<int>(*ordVal - 1)};
+ StructureConstructor ctor{*derived};
+ ctor.Add(ordSym,
+ Expr<SomeType>{Expr<SomeInteger>{
+ Expr<Type<TypeCategory::Integer, 4>>{
+ newOrd}}});
+ return Expr<SomeDerived>{
+ Constant<SomeDerived>{std::move(ctor)}};
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
return FoldIntrinsicFunction(context, std::move(funcRef));
}
}
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index bc0026746c05c..121ed9accd323 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2948,6 +2948,18 @@ class IntrinsicProcTable::Implementation {
ActualArguments &, FoldingContext &) const;
std::optional<SpecificCall> HandleC_Devloc(
ActualArguments &, FoldingContext &) const;
+ std::optional<SpecificCall> HandleEnumerationHuge(
+ const semantics::DerivedTypeSpec &, ActualArguments &,
+ FoldingContext &) const;
+ std::optional<SpecificCall> HandleEnumerationNext(
+ const semantics::DerivedTypeSpec &, ActualArguments &,
+ FoldingContext &) const;
+ std::optional<SpecificCall> HandleEnumerationPrevious(
+ const semantics::DerivedTypeSpec &, ActualArguments &,
+ FoldingContext &) const;
+ std::optional<SpecificCall> HandleEnumerationInt(
+ const semantics::DerivedTypeSpec &, ActualArguments &,
+ FoldingContext &) const;
const std::string &ResolveAlias(const std::string &name) const {
auto iter{aliases_.find(name)};
return iter == aliases_.end() ? name : iter->second;
@@ -2976,7 +2988,7 @@ bool IntrinsicProcTable::Implementation::IsIntrinsicFunction(
}
// special cases
return name == "__builtin_c_loc" || name == "__builtin_c_devloc" ||
- name == "null";
+ name == "null" || name == "next" || name == "previous";
}
bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine(
const std::string &name0) const {
@@ -3656,6 +3668,170 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Devloc(
return std::nullopt;
}
+// HUGE(x) for enumeration types — returns the last enumerator
+std::optional<SpecificCall>
+IntrinsicProcTable::Implementation::HandleEnumerationHuge(
+ const semantics::DerivedTypeSpec &derived, ActualArguments &arguments,
+ FoldingContext &context) const {
+ static const char *const keywords[]{"x", nullptr};
+ if (!CheckAndRearrangeArguments(arguments, context.messages(), keywords)) {
+ return std::nullopt;
+ }
+ int count{derived.typeSymbol()
+ .GetUltimate()
+ .get<semantics::DerivedTypeDetails>()
+ .enumeratorCount()};
+ // Build a StructureConstructor with __ordinal = enumeratorCount
+ const auto *scope{derived.GetScope()};
+ if (!scope) {
+ return std::nullopt;
+ }
+ auto ordIter{scope->find(semantics::SourceName{"__ordinal", 9})};
+ if (ordIter == scope->end()) {
+ return std::nullopt;
+ }
+ const semantics::Symbol &ordSym{*ordIter->second};
+ StructureConstructor ctor{derived};
+ ctor.Add(ordSym,
+ Expr<SomeType>{
+ Expr<SomeInteger>{Expr<Type<TypeCategory::Integer, 4>>{count}}});
+ // Build FunctionResult and DummyArguments
+ DynamicType enumType{derived};
+ characteristics::DummyDataObject ddo{characteristics::TypeAndShape{enumType}};
+ ddo.intent = common::Intent::In;
+ ddo.attrs.set(characteristics::DummyDataObject::Attr::OnlyIntrinsicInquiry);
+ characteristics::Procedure::Attrs attrs;
+ attrs.set(characteristics::Procedure::Attr::Pure);
+ // Replace arguments with the constant result
+ arguments.clear();
+ arguments.emplace_back(
+ AsGenericExpr(Expr<SomeDerived>{Constant<SomeDerived>{std::move(ctor)}}));
+ return SpecificCall{
+ SpecificIntrinsic{"huge"s,
+ characteristics::Procedure{characteristics::FunctionResult{enumType},
+ characteristics::DummyArguments{
+ characteristics::DummyArgument{"x"s, std::move(ddo)}},
+ attrs}},
+ std::move(arguments)};
+}
+
+// NEXT(a [, stat]) for enumeration types — returns the next enumerator
+std::optional<SpecificCall>
+IntrinsicProcTable::Implementation::HandleEnumerationNext(
+ const semantics::DerivedTypeSpec &derived, ActualArguments &arguments,
+ FoldingContext &context) const {
+ static const char *const keywords[]{"a", "stat", nullptr};
+ if (!CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
+ return std::nullopt;
+ }
+ if (!arguments[0]) {
+ context.messages().Say("NEXT() requires argument A"_err_en_US);
+ return std::nullopt;
+ }
+ DynamicType enumerationType{derived};
+ characteristics::DummyDataObject ddoA{
+ characteristics::TypeAndShape{enumerationType}};
+ ddoA.intent = common::Intent::In;
+ DynamicType statType{
+ TypeCategory::Integer, defaults_.GetDefaultKind(TypeCategory::Integer)};
+ characteristics::DummyDataObject ddoStat{
+ characteristics::TypeAndShape{statType}};
+ ddoStat.intent = common::Intent::Out;
+ ddoStat.attrs.set(characteristics::DummyDataObject::Attr::Optional);
+ characteristics::Procedure::Attrs attrs;
+ attrs.set(characteristics::Procedure::Attr::Pure);
+ attrs.set(characteristics::Procedure::Attr::Elemental);
+ return SpecificCall{
+ SpecificIntrinsic{"next"s,
+ characteristics::Procedure{
+ characteristics::FunctionResult{enumerationType},
+ characteristics::DummyArguments{
+ characteristics::DummyArgument{"a"s, std::move(ddoA)},
+ characteristics::DummyArgument{"stat"s, std::move(ddoStat)}},
+ attrs}},
+ std::move(arguments)};
+}
+
+// PREVIOUS(a [, stat]) for enumeration types — returns the previous enumerator
+std::optional<SpecificCall>
+IntrinsicProcTable::Implementation::HandleEnumerationPrevious(
+ const semantics::DerivedTypeSpec &derived, ActualArguments &arguments,
+ FoldingContext &context) const {
+ static const char *const keywords[]{"a", "stat", nullptr};
+ if (!CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
+ return std::nullopt;
+ }
+ if (!arguments[0]) {
+ context.messages().Say("PREVIOUS() requires argument A"_err_en_US);
+ return std::nullopt;
+ }
+ DynamicType enumerationType{derived};
+ characteristics::DummyDataObject ddoA{
+ characteristics::TypeAndShape{enumerationType}};
+ ddoA.intent = common::Intent::In;
+ DynamicType statType{
+ TypeCategory::Integer, defaults_.GetDefaultKind(TypeCategory::Integer)};
+ characteristics::DummyDataObject ddoStat{
+ characteristics::TypeAndShape{statType}};
+ ddoStat.intent = common::Intent::Out;
+ ddoStat.attrs.set(characteristics::DummyDataObject::Attr::Optional);
+ characteristics::Procedure::Attrs attrs;
+ attrs.set(characteristics::Procedure::Attr::Pure);
+ attrs.set(characteristics::Procedure::Attr::Elemental);
+ return SpecificCall{
+ SpecificIntrinsic{"previous"s,
+ characteristics::Procedure{
+ characteristics::FunctionResult{enumerationType},
+ characteristics::DummyArguments{
+ characteristics::DummyArgument{"a"s, std::move(ddoA)},
+ characteristics::DummyArgument{"stat"s, std::move(ddoStat)}},
+ attrs}},
+ std::move(arguments)};
+}
+
+// INT(x) for enumeration types — returns the ordinal as an integer
+std::optional<SpecificCall>
+IntrinsicProcTable::Implementation::HandleEnumerationInt(
+ const semantics::DerivedTypeSpec &derived, ActualArguments &arguments,
+ FoldingContext &context) const {
+ static const char *const keywords[]{"a", "kind", nullptr};
+ if (!CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
+ return std::nullopt;
+ }
+ // Determine result kind
+ int kind{defaults_.GetDefaultKind(TypeCategory::Integer)};
+ if (arguments.size() > 1 && arguments[1]) {
+ if (const auto *kindExpr{arguments[1]->UnwrapExpr()}) {
+ if (auto kindVal{ToInt64(*kindExpr)}) {
+ kind = static_cast<int>(*kindVal);
+ }
+ }
+ }
+ DynamicType enumerationType{derived};
+ DynamicType resultType{TypeCategory::Integer, kind};
+ characteristics::DummyDataObject ddo{
+ characteristics::TypeAndShape{enumerationType}};
+ ddo.intent = common::Intent::In;
+ characteristics::Procedure::Attrs attrs;
+ attrs.set(characteristics::Procedure::Attr::Pure);
+ attrs.set(characteristics::Procedure::Attr::Elemental);
+ characteristics::DummyArguments dummies;
+ dummies.emplace_back("a"s, std::move(ddo));
+ // Always include KIND dummy — CheckAndRearrangeArguments always populates
+ // the slot even when absent
+ characteristics::DummyDataObject kindDdo{
+ characteristics::TypeAndShape{DynamicType{TypeCategory::Integer,
+ defaults_.GetDefaultKind(TypeCategory::Integer)}}};
+ kindDdo.intent = common::Intent::In;
+ auto &kindDummy{dummies.emplace_back("kind"s, std::move(kindDdo))};
+ kindDummy.SetOptional();
+ return SpecificCall{SpecificIntrinsic{"int"s,
+ characteristics::Procedure{
+ characteristics::FunctionResult{resultType},
+ std::move(dummies), attrs}},
+ std::move(arguments)};
+}
+
static bool CheckForNonPositiveValues(FoldingContext &context,
const ActualArgument &arg, const std::string &procName,
const std::string &argName) {
@@ -3864,6 +4040,56 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
}
}
}
+ // Enumeration type intrinsics: HUGE, NEXT, INT
+ if (arguments.size() >= 1 && arguments[0]) {
+ if (auto type{arguments[0]->GetType()}) {
+ if (const auto *derived{GetDerivedTypeSpec(*type)}) {
+ if (derived->IsEnumerationType()) {
+ if (call.name == "huge") {
+ return HandleEnumerationHuge(*derived, arguments, context);
+ } else if (call.name == "next") {
+ return HandleEnumerationNext(*derived, arguments, context);
+ } else if (call.name == "int") {
+ return HandleEnumerationInt(*derived, arguments, context);
+ }
+ }
+ }
+ }
+ }
+ // Enumeration type intrinsics: HUGE, NEXT, INT
+ if (arguments.size() >= 1 && arguments[0]) {
+ if (auto type{arguments[0]->GetType()}) {
+ if (const auto *derived{GetDerivedTypeSpec(*type)}) {
+ if (derived->IsEnumerationType()) {
+ if (call.name == "huge") {
+ return HandleEnumerationHuge(*derived, arguments, context);
+ } else if (call.name == "next") {
+ return HandleEnumerationNext(*derived, arguments, context);
+ } else if (call.name == "int") {
+ return HandleEnumerationInt(*derived, arguments, context);
+ }
+ }
+ }
+ }
+ }
+ // Enumeration type intrinsics: HUGE, NEXT, PREVIOUS, INT
+ if (arguments.size() >= 1 && arguments[0]) {
+ if (auto type{arguments[0]->GetType()}) {
+ if (const auto *derived{GetDerivedTypeSpec(*type)}) {
+ if (derived->IsEnumerationType()) {
+ if (call.name == "huge") {
+ return HandleEnumerationHuge(*derived, arguments, context);
+ } else if (call.name == "next") {
+ return HandleEnumerationNext(*derived, arguments, context);
+ } else if (call.name == "previous") {
+ return HandleEnumerationPrevious(*derived, arguments, context);
+ } else if (call.name == "int") {
+ return HandleEnumerationInt(*derived, arguments, context);
+ }
+ }
+ }
+ }
+ }
}
// Find the specific subroutine and match the actual arguments against its
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index 5a5bee2b80e3c..f88897e362548 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -332,6 +332,21 @@ void IoChecker::Enter(const parser::InputItem &spec) {
CheckForDefinableVariable(*var, "Input");
if (auto expr{AnalyzeExpr(context_, *var)}) {
auto at{var->GetSource()};
+ if (flags_.test(Flag::StarFmt)) {
+ if (auto type{expr->GetType()}; type &&
+ type->category() == TypeCategory::Derived &&
+ !type->IsUnlimitedPolymorphic()) {
+ const auto &derived{type->GetDerivedTypeSpec()};
+ if (const auto *details{
+ derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) {
+ if (details->isEnumerationType()) {
+ context_.Say(at,
+ "Enumeration type may not appear in list-directed input"_err_en_US);
+ return;
+ }
+ }
+ }
+ }
CheckForAssumedRank(UnwrapWholeSymbolDataRef(*expr), at);
CheckForBadIoType(*expr,
flags_.test(Flag::FmtOrNml) ? common::DefinedIo::ReadFormatted
@@ -665,6 +680,21 @@ void IoChecker::Enter(const parser::OutputItem &item) {
"Output item must not be a procedure"_err_en_US); // C1233
} else {
auto at{parser::FindSourceLocation(item)};
+ if (flags_.test(Flag::StarFmt)) {
+ if (auto type{expr->GetType()}; type &&
+ type->category() == TypeCategory::Derived &&
+ !type->IsUnlimitedPolymorphic()) {
+ const auto &derived{type->GetDerivedTypeSpec()};
+ if (const auto *details{
+ derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) {
+ if (details->isEnumerationType()) {
+ context_.Say(at,
+ "Enumeration type may not appear in list-directed output"_err_en_US);
+ return;
+ }
+ }
+ }
+ }
CheckForAssumedRank(UnwrapWholeSymbolDataRef(*expr), at);
CheckForBadIoType(*expr,
flags_.test(Flag::FmtOrNml) ? common::DefinedIo::WriteFormatted
@@ -1224,6 +1254,17 @@ parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
where, "I/O list item may not be unlimited polymorphic"_err_en_US);
} else if (type.category() == TypeCategory::Derived) {
const auto &derived{type.GetDerivedTypeSpec()};
+ if (const auto *details{
+ derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) {
+ if (details->isEnumerationType()) {
+ if (which == common::DefinedIo::ReadUnformatted ||
+ which == common::DefinedIo::WriteUnformatted) {
+ return &context_.Say(where,
+ "Enumeration type may not be used in unformatted I/O"_err_en_US);
+ }
+ return nullptr; // formatted I/O is allowed
+ }
+ }
const Scope &scope{context_.FindScope(where)};
if (const Symbol *
bad{FindUnsafeIoDirectComponent(which, derived, scope)}) {
@@ -1289,6 +1330,38 @@ void IoChecker::CheckNamelist(const Symbol &namelist, common::DefinedIo which,
const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
for (const Symbol &object : details.objects()) {
context_.CheckIndexVarRedefine(namelistLocation, object);
+ if (auto type{evaluate::DynamicType::From(object)};
+ type && type->category() == TypeCategory::Derived) {
+ const auto &derived{type->GetDerivedTypeSpec()};
+ if (const auto *dtDetails{
+ derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) {
+ if (dtDetails->isEnumerationType()) {
+ context_.Say(namelistLocation,
+ "Enumeration type '%s' may not be a namelist group object"_err_en_US,
+ derived.name());
+ continue;
+ }
+ }
+ // Check direct components for enumeration types
+ if (derived.GetScope()) {
+ DirectComponentIterator directs{derived};
+ for (const Symbol &component : directs) {
+ if (auto compType{evaluate::DynamicType::From(component)};
+ compType && compType->category() == TypeCategory::Derived) {
+ const auto &compDerived{compType->GetDerivedTypeSpec()};
+ if (const auto *compDetails{compDerived.typeSymbol()
+ .detailsIf<DerivedTypeDetails>()}) {
+ if (compDetails->isEnumerationType()) {
+ context_.Say(namelistLocation,
+ "Namelist group object '%s' has a direct component '%s' of enumeration type"_err_en_US,
+ object.name(), component.name());
+ break;
+ }
+ }
+ }
+ }
+ }
+ }
if (auto *msg{CheckForBadIoType(object, which, namelistLocation)}) {
evaluate::AttachDeclaration(*msg, namelist);
} else if (which == common::DefinedIo::ReadFormatted) {
diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp
index fd1b1caa7fce1..1d2c12b3303aa 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -10,6 +10,7 @@
#include "resolve-names-utils.h"
#include "resolve-names.h"
#include "flang/Common/restorer.h"
+#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/tools.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parsing.h"
@@ -626,6 +627,10 @@ void ModFileWriter::PutDerivedType(
PutDECStructure(typeSymbol, scope);
return;
}
+ if (details.isEnumerationType()) {
+ PutEnumerationType(typeSymbol);
+ return;
+ }
PutAttrs(decls_ << "type", typeSymbol.attrs());
if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) {
decls_ << ",extends(" << extends->name() << ')';
@@ -698,6 +703,82 @@ void ModFileWriter::PutDECStructure(
decls_ << "end structure\n";
}
+void ModFileWriter::PutEnumerationType(const Symbol &typeSymbol) {
+ auto &details{typeSymbol.get<DerivedTypeDetails>()};
+ PutAttrs(decls_ << "enumeration type", typeSymbol.attrs());
+ decls_ << "::" << typeSymbol.name() << '\n';
+ // Collect enumerator PARAMETER symbols from the enclosing scope that have
+ // this enumeration type, sorted by ordinal value. Only the first
+ // enumeratorCount PARAMETERs (by ordinal) are true enumerators created by
+ // the ENUMERATOR statement; any additional PARAMETERs of this type are
+ // user-declared and should not be included here.
+ struct EnumeratorInfo {
+ SourceName name;
+ const Symbol *sym{nullptr};
+ int ordinal{0};
+ };
+ // GetSymbols() returns symbols in source-position order. The real
+ // enumerators are created inside the ENUMERATION TYPE block and appear
+ // before any user-declared PARAMETERs of the same type. For each ordinal
+ // 1..N, take only the first PARAMETER seen (by source order) — that is
+ // the real enumerator.
+ int count{details.enumeratorCount()};
+ std::vector<EnumeratorInfo> enumerators(count); // indexed by ordinal-1
+ std::vector<bool> filled(count, false);
+ for (const auto &ref : typeSymbol.owner().GetSymbols()) {
+ if (ref->attrs().test(Attr::PARAMETER)) {
+ if (const auto *obj{ref->detailsIf<ObjectEntityDetails>()}) {
+ if (obj->type() &&
+ obj->type()->category() == DeclTypeSpec::TypeDerived &&
+ &obj->type()->derivedTypeSpec().typeSymbol() == &typeSymbol) {
+ int ordinal{0};
+ if (const auto &init{obj->init()}) {
+ // The init may be a bare StructureConstructor or a
+ // Constant<SomeDerived> (after folding). Use
+ // GetScalarConstantValue which handles both.
+ if (auto ctor{
+ evaluate::GetScalarConstantValue<evaluate::SomeDerived>(
+ *init)}) {
+ for (const auto &[compRef, val] : *ctor) {
+ if (auto intVal{evaluate::ToInt64(val.value())}) {
+ ordinal = static_cast<int>(*intVal);
+ }
+ }
+ }
+ }
+ if (ordinal >= 1 && ordinal <= count && !filled[ordinal - 1]) {
+ enumerators[ordinal - 1] = {ref->name(), &*ref, ordinal};
+ filled[ordinal - 1] = true;
+ emittedEnumerators_.insert(*ref);
+ }
+ }
+ }
+ }
+ }
+ if (!enumerators.empty()) {
+ decls_ << "enumerator::";
+ bool first{true};
+ for (const auto &e : enumerators) {
+ if (!first) {
+ decls_ << ',';
+ }
+ decls_ << e.name;
+ first = false;
+ }
+ decls_ << '\n';
+ }
+ decls_ << "end enumeration type\n";
+ // Emit access overrides for individual enumerators, matching the
+ // pattern used elsewhere in mod file output (e.g., namelists, generics).
+ if (!isSubmodule_) {
+ for (const auto &e : enumerators) {
+ if (e.sym->attrs().test(Attr::PRIVATE)) {
+ decls_ << "private::" << e.name << '\n';
+ }
+ }
+ }
+}
+
// Attributes that may be in a subprogram prefix
static const Attrs subprogramPrefixAttrs{Attr::ELEMENTAL, Attr::IMPURE,
Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::SIMPLE,
@@ -1040,6 +1121,11 @@ void ModFileWriter::PutObjectEntity(
return; // symbol was emitted on STRUCTURE statement
}
}
+ // Enumerator PARAMETERs are emitted as part of the ENUMERATION TYPE
+ // block — suppress standalone emission to avoid duplicates on USE.
+ if (emittedEnumerators_.find(symbol) != emittedEnumerators_.end()) {
+ return;
+ }
}
PutEntity(
os, symbol, [&]() { PutType(os, DEREF(symbol.GetType())); },
diff --git a/flang/lib/Semantics/mod-file.h b/flang/lib/Semantics/mod-file.h
index 9e5724089b3c5..d4d3684f67539 100644
--- a/flang/lib/Semantics/mod-file.h
+++ b/flang/lib/Semantics/mod-file.h
@@ -52,6 +52,8 @@ class ModFileWriter {
std::string containsBuf_;
// Tracks nested DEC structures and fields of that type
UnorderedSymbolSet emittedDECStructures_, emittedDECFields_;
+ // Tracks enumerator PARAMETER symbols emitted within ENUMERATION TYPE blocks
+ UnorderedSymbolSet emittedEnumerators_;
UnorderedSymbolSet usedNonIntrinsicModules_;
llvm::raw_string_ostream needs_{needsBuf_};
@@ -79,6 +81,7 @@ class ModFileWriter {
void PutProcEntity(llvm::raw_ostream &, const Symbol &);
void PutDerivedType(const Symbol &, const Scope * = nullptr);
void PutDECStructure(const Symbol &, const Scope * = nullptr);
+ void PutEnumerationType(const Symbol &);
void PutTypeParam(llvm::raw_ostream &, const Symbol &);
void PutUserReduction(llvm::raw_ostream &, const Symbol &);
void PutSubprogram(const Symbol &);
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 678bae83ba68e..448a29b7c18bd 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -1007,6 +1007,11 @@ std::string DeclTypeSpec::AsFortran() const {
return "RECORD" + derivedTypeSpec().typeSymbol().name().ToString();
} else if (derivedTypeSpec().IsVectorType()) {
return derivedTypeSpec().VectorTypeAsFortran();
+ } else if (derivedTypeSpec()
+ .typeSymbol()
+ .get<DerivedTypeDetails>()
+ .isEnumerationType()) {
+ return "TYPE(" + derivedTypeSpec().typeSymbol().name().ToString() + ')';
} else {
return "TYPE(" + derivedTypeSpec().AsFortran() + ')';
}
>From de1e25f53bd28a65ab3d34137c000d002aef6b3a Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Tue, 21 Apr 2026 09:19:46 -0500
Subject: [PATCH 2/4] Adding test cases.
---
.../Semantics/enumeration-type-intrinsics.f90 | 153 ++++++++++++++++++
flang/test/Semantics/enumeration-type-io.f90 | 68 ++++++++
flang/test/Semantics/enumeration-type-mod.f90 | 84 ++++++++++
3 files changed, 305 insertions(+)
create mode 100644 flang/test/Semantics/enumeration-type-intrinsics.f90
create mode 100644 flang/test/Semantics/enumeration-type-io.f90
create mode 100644 flang/test/Semantics/enumeration-type-mod.f90
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
new file mode 100644
index 0000000000000..f4478903d8ddb
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -0,0 +1,153 @@
+! RUN: %flang_fc1 -fsyntax-only -pedantic %s 2>&1 | FileCheck %s
+! Test intrinsics HUGE, NEXT, PREVIOUS, INT for enumeration types (F2023 7.6.2)
+
+module enum_intrinsics_mod
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+
+ enumeration type :: v_value
+ enumerator :: v_one, v_two, v_three
+ enumerator v_four
+ end enumeration type
+end module
+
+subroutine test_huge()
+ use enum_intrinsics_mod
+ type(color) :: x
+ type(v_value) :: y
+
+ ! HUGE(x) returns the last enumerator
+ x = huge(x)
+ y = huge(y)
+
+ ! HUGE in comparison — should fold to .TRUE.
+ if (huge(x) == blue) continue
+ if (huge(y) == v_four) continue
+end subroutine
+
+subroutine test_next()
+ use enum_intrinsics_mod
+ type(color) :: c, nc
+ integer :: istat
+
+ ! NEXT(a) returns the next enumerator
+ c = red
+ nc = next(c)
+
+ ! NEXT with constants
+ nc = next(red)
+ nc = next(green)
+
+ ! NEXT with STAT= argument
+ nc = next(c, stat=istat)
+ nc = next(blue, stat=istat)
+end subroutine
+
+subroutine test_previous()
+ use enum_intrinsics_mod
+ type(color) :: c, pc
+ integer :: istat
+
+ ! PREVIOUS(a) returns the previous enumerator
+ c = blue
+ pc = previous(c)
+
+ ! PREVIOUS with constants
+ pc = previous(blue)
+ pc = previous(green)
+
+ ! PREVIOUS with STAT= argument
+ pc = previous(c, stat=istat)
+ pc = previous(red, stat=istat)
+end subroutine
+
+subroutine test_int()
+ use enum_intrinsics_mod
+ integer :: i
+ integer(8) :: j
+
+ ! INT(x) returns the ordinal position
+ i = int(red)
+ i = int(green)
+ i = int(blue)
+
+ ! INT with KIND= argument
+ j = int(red, kind=8)
+ j = int(green, 8)
+end subroutine
+
+subroutine test_int_parameter()
+ use enum_intrinsics_mod
+ ! INT(x) in parameter (constant) context
+ integer, parameter :: r = int(red)
+ integer, parameter :: g = int(green)
+ integer, parameter :: b = int(blue)
+
+ ! Verify ordinals are 1-based
+ integer, parameter :: test1 = r ! should be 1
+ integer, parameter :: test2 = g ! should be 2
+ integer, parameter :: test3 = b ! should be 3
+end subroutine
+
+subroutine test_huge_constant()
+ use enum_intrinsics_mod
+ ! HUGE in constant context
+ logical, parameter :: h1 = huge(red) == blue
+ logical, parameter :: h2 = huge(v_one) == v_four
+end subroutine
+
+subroutine test_next_constant()
+ use enum_intrinsics_mod
+ ! NEXT with constant folding — non-boundary cases
+ logical, parameter :: n1 = next(red) == green
+ logical, parameter :: n2 = next(green) == blue
+end subroutine
+
+subroutine test_next_boundary_with_stat()
+ use enum_intrinsics_mod
+ type(color) :: nc
+ integer :: istat
+ ! NEXT at boundary with STAT — no error, STAT gets nonzero
+ nc = next(blue, stat=istat)
+ nc = next(huge(red), stat=istat)
+end subroutine
+
+subroutine test_previous_constant()
+ use enum_intrinsics_mod
+ ! PREVIOUS with constant folding — non-boundary cases
+ logical, parameter :: p1 = previous(blue) == green
+ logical, parameter :: p2 = previous(green) == red
+end subroutine
+
+subroutine test_previous_boundary_with_stat()
+ use enum_intrinsics_mod
+ type(color) :: pc
+ integer :: istat
+ ! PREVIOUS at boundary with STAT — no error, STAT gets nonzero
+ pc = previous(red, stat=istat)
+end subroutine
+
+subroutine test_next_boundary_warning()
+ use enum_intrinsics_mod
+ type(color) :: nc
+ ! NEXT at boundary without STAT — warning
+ !CHECK: warning: NEXT() of last enumerator without STAT= causes error termination
+ nc = next(blue)
+end subroutine
+
+subroutine test_previous_boundary_warning()
+ use enum_intrinsics_mod
+ type(color) :: pc
+ ! PREVIOUS at boundary without STAT — warning
+ !CHECK: warning: PREVIOUS() of first enumerator without STAT= causes error termination
+ pc = previous(red)
+end subroutine
+
+subroutine test_huge_real_still_works()
+ ! Non-enumeration HUGE still works normally
+ real :: r
+ integer :: i
+ r = huge(r)
+ i = huge(i)
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-io.f90 b/flang/test/Semantics/enumeration-type-io.f90
new file mode 100644
index 0000000000000..2862d8d0bb9f4
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-io.f90
@@ -0,0 +1,68 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test I/O constraints for enumeration types (F2023 7.6.2)
+
+module enum_io_mod
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end module
+
+subroutine test_valid_io()
+ use enum_io_mod
+ type(color) :: c
+ character(10) :: fmt
+ c = red
+ fmt = '(I4)'
+ ! Valid: explicit format with I edit descriptor
+ write(*, '(I4)') c
+ ! Valid: explicit format via character variable
+ write(10, fmt) c
+ ! Valid: explicit format read
+ read(*, '(I4)') c
+end subroutine
+
+subroutine test_list_directed()
+ use enum_io_mod
+ type(color) :: c
+ c = red
+ !ERROR: Enumeration type may not appear in list-directed output
+ print *, c
+ !ERROR: Enumeration type may not appear in list-directed input
+ read *, c
+end subroutine
+
+subroutine test_unformatted()
+ use enum_io_mod
+ type(color) :: c
+ c = red
+ !ERROR: Enumeration type may not be used in unformatted I/O
+ write(10) c
+ !ERROR: Enumeration type may not be used in unformatted I/O
+ read(10) c
+end subroutine
+
+subroutine test_namelist_enum_object()
+ use enum_io_mod
+ type(color) :: c
+ namelist /nml/ c
+ !ERROR: Enumeration type 'color' may not be a namelist group object
+ write(*, nml=nml)
+end subroutine
+
+subroutine test_namelist_enum_component()
+ use enum_io_mod
+ type :: has_color
+ type(color) :: clr
+ integer :: n
+ end type
+ type(has_color) :: d
+ namelist /nml2/ d
+ !ERROR: Namelist group object 'd' has a direct component 'clr' of enumeration type
+ write(*, nml=nml2)
+end subroutine
+
+subroutine test_namelist_valid()
+ integer :: n
+ namelist /nml3/ n
+ write(*, nml=nml3)
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-mod.f90 b/flang/test/Semantics/enumeration-type-mod.f90
new file mode 100644
index 0000000000000..3c2f7c8f96289
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-mod.f90
@@ -0,0 +1,84 @@
+! RUN: %python %S/test_modfile.py %s %flang_fc1
+! Check correct modfile generation for enumeration types.
+
+! Basic enumeration type
+module m1
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+ type(color) :: c = green
+end
+
+!Expect: m1.mod
+!module m1
+!enumeration type::color
+!enumerator::red,green,blue
+!end enumeration type
+!type(color)::c
+!end
+
+! Private enumeration type
+module m2
+ enumeration type, private :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end
+
+!Expect: m2.mod
+!module m2
+!enumeration type,private::color
+!enumerator::red,green,blue
+!end enumeration type
+!end
+
+! Multiple enumeration types
+module m3
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+ enumeration type :: direction
+ enumerator :: north, south, east, west
+ end enumeration type
+end
+
+!Expect: m3.mod
+!module m3
+!enumeration type::color
+!enumerator::red,green,blue
+!end enumeration type
+!enumeration type::direction
+!enumerator::north,south,east,west
+!end enumeration type
+!end
+
+! Enumeration type with variable declaration
+module m4
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+ type(color) :: default_color = green
+ type(color), parameter :: favorite = blue
+end
+
+!Expect: m4.mod
+!module m4
+!enumeration type::color
+!enumerator::red,green,blue
+!end enumeration type
+!type(color)::default_color
+!type(color),parameter::favorite=color(3_4)
+!end
+
+! USE and re-export
+module m5
+ use m1, only: color, red, green, blue, c
+end
+
+!Expect: m5.mod
+!module m5
+!use m1,only:color
+!use m1,only:red
+!use m1,only:green
+!use m1,only:blue
+!use m1,only:c
+!end
>From c67715f9025e2abc41aff264d73f180b712dcf73 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Tue, 30 Jun 2026 16:09:01 -0500
Subject: [PATCH 3/4] Gated NEXT/PREVIOUS lowering with a temporary error.
Fixed INT to utilize the same KIND conversion logic as the normal INT.
---
flang/lib/Evaluate/fold-implementation.h | 14 ++--
flang/lib/Evaluate/intrinsics.cpp | 79 +++++++++++--------
.../Semantics/enumeration-type-intrinsics.f90 | 29 ++++---
flang/test/Semantics/enumeration-type-io.f90 | 3 +-
flang/test/Semantics/enumeration-type-mod.f90 | 2 +-
5 files changed, 75 insertions(+), 52 deletions(-)
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index c59b0ed68289b..821f76c950840 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1311,8 +1311,11 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
if (const auto *derived{GetDerivedTypeSpec(*type)}) {
if (derived->IsEnumerationType()) {
if (const auto *scope{derived->GetScope()}) {
- auto ordIter{
- scope->find(semantics::SourceName{"__ordinal", 9})};
+ auto ordIter{scope->find(semantics::SourceName{
+ semantics::DerivedTypeDetails::ordinalComponentName,
+ sizeof(semantics::DerivedTypeDetails::
+ ordinalComponentName) -
+ 1})};
if (ordIter != scope->end()) {
const semantics::Symbol &ordSym{*ordIter->second};
int count{derived->typeSymbol()
@@ -1334,10 +1337,10 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
// emit warning.
if (isNext) {
context.messages().Say(
- "NEXT() of last enumerator without STAT= causes error termination"_warn_en_US);
+ "NEXT() of last enumerator without STAT= causes error termination"_err_en_US);
} else {
context.messages().Say(
- "PREVIOUS() of first enumerator without STAT= causes error termination"_warn_en_US);
+ "PREVIOUS() of first enumerator without STAT= causes error termination"_err_en_US);
}
return Expr<T>{std::move(funcRef)};
}
@@ -1347,8 +1350,7 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
StructureConstructor ctor{*derived};
ctor.Add(ordSym,
Expr<SomeType>{Expr<SomeInteger>{
- Expr<Type<TypeCategory::Integer, 4>>{
- newOrd}}});
+ Expr<CInteger>{newOrd}}});
return Expr<SomeDerived>{
Constant<SomeDerived>{std::move(ctor)}};
}
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 121ed9accd323..0b1e3e0a19140 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -3728,6 +3728,20 @@ 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}};
@@ -3765,6 +3779,20 @@ 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}};
@@ -3798,12 +3826,24 @@ IntrinsicProcTable::Implementation::HandleEnumerationInt(
if (!CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
return std::nullopt;
}
- // Determine result kind
+ // Determine result kind using the same validation as the ordinary INT
+ // intrinsic (fold, check IsTypeEnabled, emit the same diagnostic on failure).
int kind{defaults_.GetDefaultKind(TypeCategory::Integer)};
if (arguments.size() > 1 && arguments[1]) {
if (const auto *kindExpr{arguments[1]->UnwrapExpr()}) {
- if (auto kindVal{ToInt64(*kindExpr)}) {
- kind = static_cast<int>(*kindVal);
+ bool kindOk{false};
+ if (auto kindVal{ToInt64(Fold(context, common::Clone(*kindExpr)))}) {
+ if (context.targetCharacteristics().IsTypeEnabled(
+ TypeCategory::Integer, *kindVal)) {
+ kind = static_cast<int>(*kindVal);
+ kindOk = true;
+ }
+ }
+ if (!kindOk) {
+ context.messages().Say(arguments[1]->sourceLocation(),
+ "'kind=' argument must be a constant scalar integer whose value is "
+ "a supported kind for the intrinsic result type"_err_en_US);
+ // fall through with default kind for error recovery
}
}
}
@@ -4040,38 +4080,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
}
}
}
- // Enumeration type intrinsics: HUGE, NEXT, INT
- if (arguments.size() >= 1 && arguments[0]) {
- if (auto type{arguments[0]->GetType()}) {
- if (const auto *derived{GetDerivedTypeSpec(*type)}) {
- if (derived->IsEnumerationType()) {
- if (call.name == "huge") {
- return HandleEnumerationHuge(*derived, arguments, context);
- } else if (call.name == "next") {
- return HandleEnumerationNext(*derived, arguments, context);
- } else if (call.name == "int") {
- return HandleEnumerationInt(*derived, arguments, context);
- }
- }
- }
- }
- }
- // Enumeration type intrinsics: HUGE, NEXT, INT
- if (arguments.size() >= 1 && arguments[0]) {
- if (auto type{arguments[0]->GetType()}) {
- if (const auto *derived{GetDerivedTypeSpec(*type)}) {
- if (derived->IsEnumerationType()) {
- if (call.name == "huge") {
- return HandleEnumerationHuge(*derived, arguments, context);
- } else if (call.name == "next") {
- return HandleEnumerationNext(*derived, arguments, context);
- } else if (call.name == "int") {
- return HandleEnumerationInt(*derived, arguments, context);
- }
- }
- }
- }
- }
+
// Enumeration type intrinsics: HUGE, NEXT, PREVIOUS, INT
if (arguments.size() >= 1 && arguments[0]) {
if (auto type{arguments[0]->GetType()}) {
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
index f4478903d8ddb..fa9b1aae79c13 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -1,5 +1,7 @@
-! RUN: %flang_fc1 -fsyntax-only -pedantic %s 2>&1 | FileCheck %s
+! 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.
module enum_intrinsics_mod
enumeration type :: color
@@ -33,14 +35,17 @@ subroutine test_next()
! NEXT(a) returns the next enumerator
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
+ ! NEXT with STAT= argument (temporarily unsupported)
+ !CHECK: error: NEXT() with STAT= is not yet supported
nc = next(c, stat=istat)
+ !CHECK: error: NEXT() with STAT= is not yet supported
nc = next(blue, stat=istat)
end subroutine
@@ -51,14 +56,17 @@ subroutine test_previous()
! PREVIOUS(a) returns the previous enumerator
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
+ ! PREVIOUS with STAT= argument (temporarily unsupported)
+ !CHECK: error: PREVIOUS() with STAT= is not yet supported
pc = previous(c, stat=istat)
+ !CHECK: error: PREVIOUS() with STAT= is not yet supported
pc = previous(red, stat=istat)
end subroutine
@@ -108,8 +116,10 @@ subroutine test_next_boundary_with_stat()
use enum_intrinsics_mod
type(color) :: nc
integer :: istat
- ! NEXT at boundary with STAT — no error, STAT gets nonzero
+ ! NEXT at boundary with STAT — TEMPORARILY rejected until lowering lands in PR 4/5
+ !CHECK: error: NEXT() with STAT= is not yet supported
nc = next(blue, stat=istat)
+ !CHECK: error: NEXT() with STAT= is not yet supported
nc = next(huge(red), stat=istat)
end subroutine
@@ -124,23 +134,24 @@ subroutine test_previous_boundary_with_stat()
use enum_intrinsics_mod
type(color) :: pc
integer :: istat
- ! PREVIOUS at boundary with STAT — no error, STAT gets nonzero
+ ! PREVIOUS at boundary with STAT — TEMPORARILY rejected until lowering lands in PR 4/5
+ !CHECK: error: PREVIOUS() with STAT= is not yet supported
pc = previous(red, stat=istat)
end subroutine
subroutine test_next_boundary_warning()
use enum_intrinsics_mod
type(color) :: nc
- ! NEXT at boundary without STAT — warning
- !CHECK: warning: NEXT() of last enumerator without STAT= causes error termination
+ ! NEXT at boundary without STAT — error
+ !CHECK: error: NEXT() of last enumerator without STAT= causes error termination
nc = next(blue)
end subroutine
subroutine test_previous_boundary_warning()
use enum_intrinsics_mod
type(color) :: pc
- ! PREVIOUS at boundary without STAT — warning
- !CHECK: warning: PREVIOUS() of first enumerator without STAT= causes error termination
+ ! PREVIOUS at boundary without STAT — error
+ !CHECK: error: PREVIOUS() of first enumerator without STAT= causes error termination
pc = previous(red)
end subroutine
diff --git a/flang/test/Semantics/enumeration-type-io.f90 b/flang/test/Semantics/enumeration-type-io.f90
index 2862d8d0bb9f4..93d651cb1bb88 100644
--- a/flang/test/Semantics/enumeration-type-io.f90
+++ b/flang/test/Semantics/enumeration-type-io.f90
@@ -1,7 +1,8 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -fenumeration-type
! Test I/O constraints for enumeration types (F2023 7.6.2)
module enum_io_mod
+ !WARNING: ENUMERATION TYPE support is incomplete and should be enabled only for testing
enumeration type :: color
enumerator :: red, green, blue
end enumeration type
diff --git a/flang/test/Semantics/enumeration-type-mod.f90 b/flang/test/Semantics/enumeration-type-mod.f90
index 3c2f7c8f96289..17abf8a60c43c 100644
--- a/flang/test/Semantics/enumeration-type-mod.f90
+++ b/flang/test/Semantics/enumeration-type-mod.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_modfile.py %s %flang_fc1
+! RUN: %python %S/test_modfile.py %s %flang_fc1 -fenumeration-type
! Check correct modfile generation for enumeration types.
! Basic enumeration type
>From eefbbc918316d6d565b82100062abbd7efe0e0a4 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 2 Jul 2026 12:22:12 -0500
Subject: [PATCH 4/4] Incorporated the following fixes:
- Fold enum INT/NEXT/PREVIOUS over constant array arguments elementwise
- Enumeration Type inlines HUGE/INT/NEXT/PREVIOUS now look at argument by keyword.
- Gated and report an error on NEXT/PREVIOUS intrinsic use.
---
flang/lib/Evaluate/fold-implementation.h | 73 +++++++++++++++----
flang/lib/Evaluate/fold-integer.cpp | 26 +++++++
flang/lib/Evaluate/intrinsics.cpp | 68 +++++++++++++----
flang/lib/Semantics/resolve-names.cpp | 12 +++
...enumeration-type-intrinsics-array-fold.f90 | 29 ++++++++
.../enumeration-type-intrinsics-gating.f90 | 14 ++++
.../enumeration-type-intrinsics-keyword.f90 | 45 ++++++++++++
.../enumeration-type-intrinsics-nonenum.f90 | 16 ++++
.../Semantics/enumeration-type-intrinsics.f90 | 27 +++++++
9 files changed, 281 insertions(+), 29 deletions(-)
create mode 100644 flang/test/Semantics/enumeration-type-intrinsics-array-fold.f90
create mode 100644 flang/test/Semantics/enumeration-type-intrinsics-gating.f90
create mode 100644 flang/test/Semantics/enumeration-type-intrinsics-keyword.f90
create mode 100644 flang/test/Semantics/enumeration-type-intrinsics-nonenum.f90
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 821f76c950840..74848c94c7d62 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1314,7 +1314,7 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
auto ordIter{scope->find(semantics::SourceName{
semantics::DerivedTypeDetails::ordinalComponentName,
sizeof(semantics::DerivedTypeDetails::
- ordinalComponentName) -
+ ordinalComponentName) -
1})};
if (ordIter != scope->end()) {
const semantics::Symbol &ordSym{*ordIter->second};
@@ -1325,24 +1325,21 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
// Extract ordinal from constant value
if (auto *constant{
UnwrapConstantValue<SomeDerived>(*expr)}) {
+ const bool isNext{name == "next"};
+ // Boundary without STAT= is runtime error
+ // termination; diagnose and leave the reference
+ // unfolded (matches the scalar behavior).
+ auto boundaryBail{[&]() -> Expr<T> {
+ context.messages().Say(isNext
+ ? "NEXT() of last enumerator without STAT= causes error termination"_err_en_US
+ : "PREVIOUS() of first enumerator without STAT= causes error termination"_err_en_US);
+ return Expr<T>{std::move(funcRef)};
+ }};
if (auto sc{constant->GetScalarValue()}) {
if (auto ordExpr{sc->Find(ordSym)}) {
if (auto ordVal{ToInt64(*ordExpr)}) {
- bool isNext{name == "next"};
- bool atBoundary{
- isNext ? *ordVal >= count : *ordVal <= 1};
- if (atBoundary) {
- // At boundary without STAT — error
- // termination at runtime. Don't fold;
- // emit warning.
- if (isNext) {
- context.messages().Say(
- "NEXT() of last enumerator without STAT= causes error termination"_err_en_US);
- } else {
- context.messages().Say(
- "PREVIOUS() of first enumerator without STAT= causes error termination"_err_en_US);
- }
- return Expr<T>{std::move(funcRef)};
+ if (isNext ? *ordVal >= count : *ordVal <= 1) {
+ return boundaryBail();
}
int newOrd{isNext
? static_cast<int>(*ordVal + 1)
@@ -1355,6 +1352,50 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
Constant<SomeDerived>{std::move(ctor)}};
}
}
+ } else if (constant->Rank() > 0) {
+ // 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.
+ std::vector<StructureConstructor> elements;
+ elements.reserve(constant->values().size());
+ for (const StructureConstructorValues &scv :
+ constant->values()) {
+ auto ordVal{
+ ToInt64(scv.find(ordSym)->second.value())};
+ if (isNext ? *ordVal >= count : *ordVal <= 1) {
+ return boundaryBail();
+ }
+ int newOrd{isNext ? static_cast<int>(*ordVal + 1)
+ : static_cast<int>(*ordVal - 1)};
+ StructureConstructor ctor{*derived};
+ ctor.Add(ordSym,
+ Expr<SomeType>{
+ Expr<SomeInteger>{Expr<CInteger>{newOrd}}});
+ elements.emplace_back(std::move(ctor));
+ }
+ return Expr<SomeDerived>{Constant<SomeDerived>{
+ *derived, std::move(elements),
+ ConstantSubscripts{constant->shape()}}};
}
}
}
diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp
index 6619453148dba..2b607c67ec699 100644
--- a/flang/lib/Evaluate/fold-integer.cpp
+++ b/flang/lib/Evaluate/fold-integer.cpp
@@ -766,10 +766,36 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
if (auto type{derivedExpr->GetType()}) {
if (const auto *derived{GetDerivedTypeSpec(*type)}) {
if (derived->IsEnumerationType()) {
+ // Scalar: fold to the single ordinal.
if (auto ordExpr{GetEnumerationOrdinal(*derivedExpr)}) {
if (auto ordVal{ToInt64(*ordExpr)}) {
return Expr<T>{Constant<T>{Scalar<T>{*ordVal}}};
}
+ } else if (const auto *constant{
+ UnwrapConstantValue<SomeDerived>(*derivedExpr)};
+ constant && constant->Rank() > 0) {
+ // Array constant: fold elementwise into a constant array of
+ // ordinals. Reaching here means the whole constructor already
+ // folded to a constant, so every element's __ordinal is a
+ // constant integer.
+ if (const auto *scope{derived->GetScope()}) {
+ auto ordIter{scope->find(semantics::SourceName{
+ semantics::DerivedTypeDetails::ordinalComponentName,
+ sizeof(
+ semantics::DerivedTypeDetails::ordinalComponentName) -
+ 1})};
+ if (ordIter != scope->end()) {
+ const semantics::Symbol &ordSym{*ordIter->second};
+ std::vector<Scalar<T>> elements;
+ for (const StructureConstructorValues &scv :
+ constant->values()) {
+ elements.emplace_back(
+ *ToInt64(scv.find(ordSym)->second.value()));
+ }
+ return Expr<T>{Constant<T>{std::move(elements),
+ ConstantSubscripts{constant->shape()}}};
+ }
+ }
}
// Non-constant enumeration argument — leave unfolded
return Expr<T>{std::move(funcRef)};
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 0b1e3e0a19140..c0090076de9a0 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -3100,6 +3100,31 @@ bool CheckAndRearrangeArguments(ActualArguments &arguments,
return !anyMissing;
}
+// Locates the actual argument that binds to the first dummy argument of an
+// intrinsic, honoring keyword syntax. The enumeration-type inline handlers
+// (HUGE/INT/NEXT/PREVIOUS) must decide whether the enum path applies before
+// the actual arguments have been rearranged into dummy order, so they cannot
+// simply inspect arguments[0]. The first dummy is bound either by an explicit
+// keyword (e.g. INT(KIND=8, A=RED)) or, absent that keyword, by the first
+// positional argument. Returns nullptr if no such argument is present.
+static const ActualArgument *FindFirstDummyArgument(
+ const ActualArguments &arguments, const char *firstDummyKeyword) {
+ const ActualArgument *firstPositional{nullptr};
+ for (const std::optional<ActualArgument> &arg : arguments) {
+ if (!arg) {
+ continue;
+ }
+ if (arg->keyword()) {
+ if (*arg->keyword() == firstDummyKeyword) {
+ return &*arg;
+ }
+ } else if (!firstPositional) {
+ firstPositional = &*arg;
+ }
+ }
+ return firstPositional;
+}
+
// The NULL() intrinsic is a special case.
SpecificCall IntrinsicProcTable::Implementation::HandleNull(
ActualArguments &arguments, FoldingContext &context) const {
@@ -4081,19 +4106,36 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
}
}
- // Enumeration type intrinsics: HUGE, NEXT, PREVIOUS, INT
- if (arguments.size() >= 1 && arguments[0]) {
- if (auto type{arguments[0]->GetType()}) {
- if (const auto *derived{GetDerivedTypeSpec(*type)}) {
- if (derived->IsEnumerationType()) {
- if (call.name == "huge") {
- return HandleEnumerationHuge(*derived, arguments, context);
- } else if (call.name == "next") {
- return HandleEnumerationNext(*derived, arguments, context);
- } else if (call.name == "previous") {
- return HandleEnumerationPrevious(*derived, arguments, context);
- } else if (call.name == "int") {
- return HandleEnumerationInt(*derived, arguments, context);
+ // NEXT/PREVIOUS are enumeration-type-only intrinsics.
+ if (call.name == "next" || call.name == "previous") {
+ const semantics::DerivedTypeSpec *derived{nullptr};
+ if (const ActualArgument *arg{FindFirstDummyArgument(arguments, "a")}) {
+ if (auto type{arg->GetType()}) {
+ derived = GetDerivedTypeSpec(*type);
+ }
+ }
+ if (derived && derived->IsEnumerationType()) {
+ return call.name == "next"
+ ? HandleEnumerationNext(*derived, arguments, context)
+ : HandleEnumerationPrevious(*derived, arguments, context);
+ }
+ context.messages().Say(
+ "Argument of %s() must be of enumeration type"_err_en_US,
+ parser::ToUpperCaseLetters(call.name));
+ return std::nullopt;
+ }
+
+ // HUGE/INT are ordinary intrinsics that also accept enumeration types.
+ if (call.name == "huge" || call.name == "int") {
+ const char *firstDummyKeyword{call.name == "huge" ? "x" : "a"};
+ if (const ActualArgument *arg{
+ FindFirstDummyArgument(arguments, firstDummyKeyword)}) {
+ if (auto type{arg->GetType()}) {
+ if (const auto *derived{GetDerivedTypeSpec(*type)}) {
+ if (derived->IsEnumerationType()) {
+ return call.name == "huge"
+ ? HandleEnumerationHuge(*derived, arguments, context)
+ : HandleEnumerationInt(*derived, arguments, context);
}
}
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index fdfbf3cafd895..510b8b575a119 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -172,6 +172,18 @@ class BaseVisitor {
}
bool IsIntrinsic(
const SourceName &name, std::optional<Symbol::Flag> flag) const {
+ // TEMPORARY (enumeration-type feature gating): NEXT and PREVIOUS are only
+ // recognized as intrinsic names when the enumeration-type feature is
+ // enabled, so that pre-F2023 programs may still use those names for
+ // implicit external procedures. This gating is removed once the
+ // enumeration-type feature is fully implemented.
+ if (!context_->languageFeatures().IsEnabled(
+ common::LanguageFeature::EnumerationType)) {
+ const std::string nameStr{name.ToString()};
+ if (nameStr == "next" || nameStr == "previous") {
+ return false;
+ }
+ }
if (!flag) {
return context_->intrinsics().IsIntrinsic(name.ToString());
} else if (flag == Symbol::Flag::Function) {
diff --git a/flang/test/Semantics/enumeration-type-intrinsics-array-fold.f90 b/flang/test/Semantics/enumeration-type-intrinsics-array-fold.f90
new file mode 100644
index 0000000000000..d7af7199aa4ba
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-intrinsics-array-fold.f90
@@ -0,0 +1,29 @@
+! RUN: %flang_fc1 -fdebug-dump-symbols -fenumeration-type %s 2>&1 | FileCheck %s
+! Regression test: the enumeration-type intrinsics INT/NEXT/PREVIOUS are
+! elemental, so a constant array argument must fold elementwise in a constant
+! context. Previously the enum fold path extracted only a scalar ordinal, so an
+! array-valued call was left unfolded and a named constant reported "cannot be
+! computed as a constant value". Ordinals are 1-based, so
+! [red, green, blue] -> [1, 2, 3].
+
+module enum_array_fold_mod
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+
+ ! Default-kind INT() over an array constructor folds to INTEGER(4) [1,2,3].
+ integer, parameter :: a(3) = int([red, green, blue])
+ !CHECK: a, PARAMETER, PUBLIC size={{[0-9]+}} offset={{[0-9]+}}: ObjectEntity type: INTEGER(4) shape: 1_8:3_8 init:[INTEGER(4)::1_4,2_4,3_4]
+
+ ! KIND= is honored: folds to INTEGER(8) with the reversed order [3,2,1].
+ integer(8), parameter :: b(3) = int([blue, green, red], kind=8)
+ !CHECK: b, PARAMETER, PUBLIC size={{[0-9]+}} offset={{[0-9]+}}: ObjectEntity type: INTEGER(8) shape: 1_8:3_8 init:[INTEGER(8)::3_8,2_8,1_8]
+
+ ! NEXT() over a (non-boundary) constant array folds to [green, blue].
+ type(color), parameter :: cn(2) = next([red, green])
+ !CHECK: cn, PARAMETER, PUBLIC size={{[0-9]+}} offset={{[0-9]+}}: ObjectEntity type: TYPE(color) shape: 1_8:2_8 init:[color::color(2_4),color(3_4)]
+
+ ! PREVIOUS() over a (non-boundary) constant array folds to [red, green].
+ type(color), parameter :: cp(2) = previous([green, blue])
+ !CHECK: cp, PARAMETER, PUBLIC size={{[0-9]+}} offset={{[0-9]+}}: ObjectEntity type: TYPE(color) shape: 1_8:2_8 init:[color::color(1_4),color(2_4)]
+end module
diff --git a/flang/test/Semantics/enumeration-type-intrinsics-gating.f90 b/flang/test/Semantics/enumeration-type-intrinsics-gating.f90
new file mode 100644
index 0000000000000..11fda942208c5
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-intrinsics-gating.f90
@@ -0,0 +1,14 @@
+! RUN: %flang_fc1 -fsyntax-only %s
+! Without -fenumeration-type, NEXT and PREVIOUS are not reserved intrinsic
+! names, so a pre-F2023 program may use them as implicit external procedures.
+! This exercises the enumeration-type feature gating in resolve-names.cpp and
+! verifies the reference no longer triggers an internal compiler error.
+! NOTE: This gating is TEMPORARY and is removed once the enumeration-type
+! feature is fully implemented.
+
+program p
+ integer :: i
+ real :: r
+ i = next(5)
+ r = previous(3)
+end program
diff --git a/flang/test/Semantics/enumeration-type-intrinsics-keyword.f90 b/flang/test/Semantics/enumeration-type-intrinsics-keyword.f90
new file mode 100644
index 0000000000000..85e70baf9ca0e
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-intrinsics-keyword.f90
@@ -0,0 +1,45 @@
+! RUN: %flang_fc1 -fsyntax-only -fenumeration-type %s
+! Verify keyword-order argument binding for enumeration-type intrinsics.
+! INT(KIND=..., A=...) must recognize the enumeration argument even when it is
+! not the first positional actual. This is a regression test: previously the
+! enum dispatch inspected only the first positional argument, so a keyword call
+! that placed KIND= before A= reported "Actual argument for 'a=' has bad type".
+! A clean compile (exit 0) confirms the enum path is taken for the keyword form.
+
+module enum_keyword_mod
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end module
+
+subroutine test_int_keyword_order()
+ use enum_keyword_mod
+ integer :: i
+ integer(8) :: j
+
+ ! Enum argument bound by keyword A=, KIND= appears first.
+ j = int(kind=8, a=red)
+ i = int(a=green, kind=4)
+ j = int(a=blue, kind=8)
+
+ ! Positional forms continue to work.
+ i = int(red)
+ j = int(green, 8)
+end subroutine
+
+subroutine test_huge_keyword()
+ use enum_keyword_mod
+ type(color) :: x
+
+ ! HUGE bound by keyword X=.
+ x = huge(x=x)
+end subroutine
+
+subroutine test_next_previous_keyword()
+ use enum_keyword_mod
+ type(color) :: c
+
+ ! Enum argument bound by keyword A= (first and only dummy).
+ c = next(a=red)
+ c = previous(a=blue)
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-intrinsics-nonenum.f90 b/flang/test/Semantics/enumeration-type-intrinsics-nonenum.f90
new file mode 100644
index 0000000000000..37a04c6f0fffb
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-intrinsics-nonenum.f90
@@ -0,0 +1,16 @@
+! RUN: not %flang_fc1 -fsyntax-only -fenumeration-type %s 2>&1 | FileCheck %s
+! With the enumeration-type feature enabled, NEXT and PREVIOUS require an
+! argument of enumeration type. A non-enumeration argument must produce a
+! proper diagnostic rather than an internal compiler error.
+
+subroutine test_next_nonenum()
+ integer :: i, j
+ !CHECK: error: Argument of NEXT() must be of enumeration type
+ i = next(j)
+end subroutine
+
+subroutine test_previous_nonenum()
+ integer :: i, j
+ !CHECK: error: Argument of PREVIOUS() must be of enumeration type
+ i = previous(j)
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
index fa9b1aae79c13..0609b16f35bfe 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -155,6 +155,18 @@ subroutine test_previous_boundary_warning()
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 error termination without STAT=, so the whole reference is
+ ! diagnosed and left unfolded (same as the scalar boundary case).
+ !CHECK: error: NEXT() of last enumerator without STAT= causes error termination
+ nc = next([green, blue])
+ !CHECK: error: PREVIOUS() of first enumerator without STAT= causes error termination
+ pc = previous([red, green])
+end subroutine
+
subroutine test_huge_real_still_works()
! Non-enumeration HUGE still works normally
real :: r
@@ -162,3 +174,18 @@ subroutine test_huge_real_still_works()
r = huge(r)
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
+ nc = next(stat=istat, a=red)
+ !CHECK: error: PREVIOUS() with STAT= is not yet supported
+ nc = previous(stat=istat, a=blue)
+end subroutine
More information about the flang-commits
mailing list