[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
Fri Jul 31 07:24:43 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/9] 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/9] 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/9] 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/9] 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
>From 35e0a609ab89a13001a652b39f6cf08aa8839b03 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Mon, 6 Jul 2026 13:36:59 -0500
Subject: [PATCH 5/9] Added new flag to emit enumerators based on flag status,
not order. This fixes the problem with an accessor being forward declared.
---
flang/include/flang/Semantics/symbol.h | 5 +++
flang/lib/Semantics/mod-file.cpp | 25 ++++++------
flang/lib/Semantics/mod-file.h | 2 -
flang/lib/Semantics/resolve-names.cpp | 1 +
flang/test/Semantics/enumeration-type-mod.f90 | 38 +++++++++++++++++++
5 files changed, 56 insertions(+), 15 deletions(-)
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index b307f08dfd50a..4240ee0e1bd0f 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -904,6 +904,11 @@ class Symbol {
// For compiler created symbols that are constant but cannot legally have
// the PARAMETER attribute.
ReadOnly,
+ // A named constant created by an ENUMERATOR statement within an
+ // ENUMERATION TYPE definition (F2023 R768). Distinguishes the intrinsic
+ // enumerators of an enumeration type from user-declared PARAMETERs of
+ // that type.
+ EnumeratorParameter,
// OpenACC data-sharing attribute
AccPrivate, AccFirstPrivate, AccShared,
// OpenACC data-mapping attribute
diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp
index 1d2c12b3303aa..76ba2849bba61 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -707,26 +707,22 @@ 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.
+ // Collect the enumerator PARAMETER symbols of this enumeration type from the
+ // enclosing scope, sorted by ordinal value. The intrinsic enumerators
+ // created by the ENUMERATOR statement carry Symbol::Flag::EnumeratorParameter,
+ // which distinguishes them from user-declared PARAMETERs of the same
+ // enumeration type; only the flagged symbols are listed here and suppressed
+ // from standalone emission.
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 (ref->test(Symbol::Flag::EnumeratorParameter)) {
if (const auto *obj{ref->detailsIf<ObjectEntityDetails>()}) {
if (obj->type() &&
obj->type()->category() == DeclTypeSpec::TypeDerived &&
@@ -749,7 +745,6 @@ void ModFileWriter::PutEnumerationType(const Symbol &typeSymbol) {
if (ordinal >= 1 && ordinal <= count && !filled[ordinal - 1]) {
enumerators[ordinal - 1] = {ref->name(), &*ref, ordinal};
filled[ordinal - 1] = true;
- emittedEnumerators_.insert(*ref);
}
}
}
@@ -1123,7 +1118,11 @@ void ModFileWriter::PutObjectEntity(
}
// 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()) {
+ // Keyed on Symbol::Flag::EnumeratorParameter so this is independent of
+ // whether the enumeration type block has already been emitted (the
+ // enumerator may sort before its type, e.g. when an accessibility
+ // statement precedes the ENUMERATION TYPE definition).
+ if (symbol.test(Symbol::Flag::EnumeratorParameter)) {
return;
}
}
diff --git a/flang/lib/Semantics/mod-file.h b/flang/lib/Semantics/mod-file.h
index d4d3684f67539..b0ebb582d99da 100644
--- a/flang/lib/Semantics/mod-file.h
+++ b/flang/lib/Semantics/mod-file.h
@@ -52,8 +52,6 @@ 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_};
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 510b8b575a119..21900d4d9643a 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6176,6 +6176,7 @@ bool DeclarationVisitor::Pre(const parser::EnumerationEnumeratorStmt &x) {
MakeSymbol(enclosingScope, name.source, Attrs{Attr::PARAMETER})};
Resolve(name, enumerator);
enumerator.set_details(ObjectEntityDetails{});
+ enumerator.set(Symbol::Flag::EnumeratorParameter);
enumerator.SetType(declType);
// Store the init as a StructureConstructor of the enumeration type with
// the ordinal in the hidden __ordinal component. This gives each
diff --git a/flang/test/Semantics/enumeration-type-mod.f90 b/flang/test/Semantics/enumeration-type-mod.f90
index 17abf8a60c43c..9188f105d5892 100644
--- a/flang/test/Semantics/enumeration-type-mod.f90
+++ b/flang/test/Semantics/enumeration-type-mod.f90
@@ -82,3 +82,41 @@ module m5
!use m1,only:blue
!use m1,only:c
!end
+
+! Accessibility statement for an enumerator appearing BEFORE the enumeration
+! type definition. The enumerator must still be emitted only inside the
+! ENUMERATION TYPE block (never as a standalone forward-referencing PARAMETER),
+! regardless of the earlier source position of the accessibility statement.
+module m6
+ private :: green
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end
+
+!Expect: m6.mod
+!module m6
+!enumeration type::color
+!enumerator::red,green,blue
+!end enumeration type
+!private::green
+!end
+
+! Accessibility statement for the enumeration type NAME appearing BEFORE its
+! definition (valid Fortran; distinct from the C7116 forward-reference
+! prohibition, which only concerns enumeration-type-specs). The type block
+! must be emitted correctly and no enumerator may leak out ahead of it.
+module m7
+ private :: color
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end
+
+!Expect: m7.mod
+!module m7
+!enumeration type,private::color
+!enumerator::red,green,blue
+!end enumeration type
+!end
+
>From c81b3db0eef998ecf4acdc498235cd2932f0b914 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Mon, 6 Jul 2026 15:53:30 -0500
Subject: [PATCH 6/9] Corrected IO restrictions to handle components and make
restrictions consistent.
---
flang/lib/Semantics/check-io.cpp | 65 ++++++++++++++++++++
flang/lib/Semantics/mod-file.cpp | 8 +--
flang/test/Semantics/enumeration-type-io.f90 | 16 +++++
3 files changed, 85 insertions(+), 4 deletions(-)
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index f88897e362548..a71087d9970f9 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -22,6 +22,8 @@ namespace Fortran::semantics {
// TODO: C1234, C1235 -- defined I/O constraints
+static const Symbol *FindEnumerationTypeComponent(const DerivedTypeSpec &);
+
class FormatErrorReporter {
public:
FormatErrorReporter(SemanticsContext &context,
@@ -345,6 +347,18 @@ void IoChecker::Enter(const parser::InputItem &spec) {
return;
}
}
+ // A derived type without defined input I/O expands into its
+ // components (12.6.3), so reject one reaching an enumeration
+ // effective item, which may not appear in list-directed input.
+ const Scope &scope{context_.FindScope(at)};
+ if (!HasDefinedIo(common::DefinedIo::ReadFormatted, derived, &scope)) {
+ if (const Symbol *bad{FindEnumerationTypeComponent(derived)}) {
+ context_.Say(at,
+ "List-directed input item has a component '%s' of enumeration type"_err_en_US,
+ bad->name());
+ return;
+ }
+ }
}
}
CheckForAssumedRank(UnwrapWholeSymbolDataRef(*expr), at);
@@ -693,6 +707,19 @@ void IoChecker::Enter(const parser::OutputItem &item) {
return;
}
}
+ // A derived type without defined output I/O expands into its
+ // components (12.6.3), so reject one reaching an enumeration
+ // effective item, which may not appear in list-directed output.
+ const Scope &scope{context_.FindScope(at)};
+ if (!HasDefinedIo(
+ common::DefinedIo::WriteFormatted, derived, &scope)) {
+ if (const Symbol *bad{FindEnumerationTypeComponent(derived)}) {
+ context_.Say(at,
+ "List-directed output item has a component '%s' of enumeration type"_err_en_US,
+ bad->name());
+ return;
+ }
+ }
}
}
CheckForAssumedRank(UnwrapWholeSymbolDataRef(*expr), at);
@@ -1246,6 +1273,30 @@ static const Symbol *FindInaccessibleComponent(common::DefinedIo which,
return FindInaccessibleComponent(which, derived, scope, visited);
}
+// Returns the first direct (effective) component of `derived` whose type is an
+// enumeration type, else nullptr. Mirrors the F2023 12.6.3 effective-item
+// expansion used to detect an enumeration effective item reached through a
+// derived-type list item.
+static const Symbol *FindEnumerationTypeComponent(
+ const DerivedTypeSpec &derived) {
+ if (!derived.GetScope()) {
+ return nullptr;
+ }
+ DirectComponentIterator directs{derived};
+ for (const Symbol &component : directs) {
+ if (auto compType{evaluate::DynamicType::From(component)};
+ compType && compType->category() == TypeCategory::Derived) {
+ if (const auto *compDetails{compType->GetDerivedTypeSpec()
+ .typeSymbol()
+ .detailsIf<DerivedTypeDetails>()};
+ compDetails && compDetails->isEnumerationType()) {
+ return &component;
+ }
+ }
+ }
+ return nullptr;
+}
+
// Fortran 2018, 12.6.3 paragraphs 5 & 7
parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
common::DefinedIo which, parser::CharBlock where) const {
@@ -1266,6 +1317,20 @@ parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
}
}
const Scope &scope{context_.FindScope(where)};
+ // An enumeration type may not be used in unformatted I/O. A derived type
+ // that is not processed by defined I/O expands into its components
+ // (12.6.3), so reject one that reaches an enumeration effective item.
+ // This is intentional flang policy: the standard treats an unformatted
+ // derived-type item as a single value, but flang keeps enumeration values
+ // out of unformatted I/O for consistency with the bare-enum rejection.
+ if ((which == common::DefinedIo::ReadUnformatted ||
+ which == common::DefinedIo::WriteUnformatted) &&
+ !HasDefinedIo(which, derived, &scope)) {
+ if (FindEnumerationTypeComponent(derived)) {
+ return &context_.Say(where,
+ "Enumeration type may not be used in unformatted I/O"_err_en_US);
+ }
+ }
if (const Symbol *
bad{FindUnsafeIoDirectComponent(which, derived, scope)}) {
return &context_.SayWithDecl(*bad, where,
diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp
index 76ba2849bba61..64afc75fd9628 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -709,10 +709,10 @@ void ModFileWriter::PutEnumerationType(const Symbol &typeSymbol) {
decls_ << "::" << typeSymbol.name() << '\n';
// Collect the enumerator PARAMETER symbols of this enumeration type from the
// enclosing scope, sorted by ordinal value. The intrinsic enumerators
- // created by the ENUMERATOR statement carry Symbol::Flag::EnumeratorParameter,
- // which distinguishes them from user-declared PARAMETERs of the same
- // enumeration type; only the flagged symbols are listed here and suppressed
- // from standalone emission.
+ // created by the ENUMERATOR statement carry
+ // Symbol::Flag::EnumeratorParameter, which distinguishes them from
+ // user-declared PARAMETERs of the same enumeration type; only the flagged
+ // symbols are listed here and suppressed from standalone emission.
struct EnumeratorInfo {
SourceName name;
const Symbol *sym{nullptr};
diff --git a/flang/test/Semantics/enumeration-type-io.f90 b/flang/test/Semantics/enumeration-type-io.f90
index 93d651cb1bb88..d6841464342ec 100644
--- a/flang/test/Semantics/enumeration-type-io.f90
+++ b/flang/test/Semantics/enumeration-type-io.f90
@@ -42,6 +42,22 @@ subroutine test_unformatted()
read(10) c
end subroutine
+subroutine test_component_io()
+ use enum_io_mod
+ type :: has_color
+ type(color) :: c
+ end type
+ type(has_color) :: d
+ !ERROR: List-directed output item has a component 'c' of enumeration type
+ print *, d
+ !ERROR: List-directed input item has a component 'c' of enumeration type
+ read *, d
+ !ERROR: Enumeration type may not be used in unformatted I/O
+ write(10) d
+ !ERROR: Enumeration type may not be used in unformatted I/O
+ read(10) d
+end subroutine
+
subroutine test_namelist_enum_object()
use enum_io_mod
type(color) :: c
>From d1bbe5dc0bfbb1a70854b2777c8c865e653f1093 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Tue, 21 Jul 2026 11:31:16 -0500
Subject: [PATCH 7/9] Added detection to prevent extraneous errors. Corrected
component iteration to correctly handle defined I/O of enumeration type
components.
---
flang/lib/Evaluate/intrinsics.cpp | 11 ++-
flang/lib/Semantics/check-io.cpp | 100 ++++++++++++++++----------
flang/lib/Semantics/resolve-names.cpp | 5 +-
3 files changed, 75 insertions(+), 41 deletions(-)
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index c0090076de9a0..917823e297f04 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -4106,8 +4106,15 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
}
}
- // NEXT/PREVIOUS are enumeration-type-only intrinsics.
- if (call.name == "next" || call.name == "previous") {
+ // NEXT/PREVIOUS are enumeration-type-only intrinsics. They are only
+ // recognized as intrinsic names when the enumeration-type feature is
+ // enabled, so that pre-F2023 programs may still use those names for
+ // external procedures. This gating is symmetric with the one in
+ // resolve-names.cpp and should be removed once the feature is fully
+ // implemented.
+ if ((call.name == "next" || call.name == "previous") &&
+ context.languageFeatures().IsEnabled(
+ common::LanguageFeature::EnumerationType)) {
const semantics::DerivedTypeSpec *derived{nullptr};
if (const ActualArgument *arg{FindFirstDummyArgument(arguments, "a")}) {
if (auto type{arg->GetType()}) {
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index a71087d9970f9..bf2599f440ac8 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -22,7 +22,8 @@ namespace Fortran::semantics {
// TODO: C1234, C1235 -- defined I/O constraints
-static const Symbol *FindEnumerationTypeComponent(const DerivedTypeSpec &);
+static const Symbol *FindEnumerationTypeComponent(
+ common::DefinedIo, const DerivedTypeSpec &, const Scope &);
class FormatErrorReporter {
public:
@@ -352,7 +353,8 @@ void IoChecker::Enter(const parser::InputItem &spec) {
// effective item, which may not appear in list-directed input.
const Scope &scope{context_.FindScope(at)};
if (!HasDefinedIo(common::DefinedIo::ReadFormatted, derived, &scope)) {
- if (const Symbol *bad{FindEnumerationTypeComponent(derived)}) {
+ if (const Symbol *bad{FindEnumerationTypeComponent(
+ common::DefinedIo::ReadFormatted, derived, scope)}) {
context_.Say(at,
"List-directed input item has a component '%s' of enumeration type"_err_en_US,
bad->name());
@@ -713,7 +715,8 @@ void IoChecker::Enter(const parser::OutputItem &item) {
const Scope &scope{context_.FindScope(at)};
if (!HasDefinedIo(
common::DefinedIo::WriteFormatted, derived, &scope)) {
- if (const Symbol *bad{FindEnumerationTypeComponent(derived)}) {
+ if (const Symbol *bad{FindEnumerationTypeComponent(
+ common::DefinedIo::WriteFormatted, derived, scope)}) {
context_.Say(at,
"List-directed output item has a component '%s' of enumeration type"_err_en_US,
bad->name());
@@ -1273,30 +1276,60 @@ static const Symbol *FindInaccessibleComponent(common::DefinedIo which,
return FindInaccessibleComponent(which, derived, scope, visited);
}
-// Returns the first direct (effective) component of `derived` whose type is an
-// enumeration type, else nullptr. Mirrors the F2023 12.6.3 effective-item
-// expansion used to detect an enumeration effective item reached through a
-// derived-type list item.
-static const Symbol *FindEnumerationTypeComponent(
- const DerivedTypeSpec &derived) {
- if (!derived.GetScope()) {
+// Finds a direct (effective) component whose type is an enumeration type,
+// expanding a derived-type list item into its components per F2023 12.6.3. A
+// component that is itself processed by defined I/O is treated as a single
+// value and is not expanded, so its subtree is skipped (based off of
+// FindInaccessibleComponent).
+static const Symbol *FindEnumerationTypeComponent(common::DefinedIo which,
+ const DerivedTypeSpec &derived, const Scope &scope,
+ VisitedSymbolSet &visited) {
+ if (!visited.insert(&derived.typeSymbol()).second) {
return nullptr;
}
- DirectComponentIterator directs{derived};
- for (const Symbol &component : directs) {
- if (auto compType{evaluate::DynamicType::From(component)};
- compType && compType->category() == TypeCategory::Derived) {
- if (const auto *compDetails{compType->GetDerivedTypeSpec()
- .typeSymbol()
- .detailsIf<DerivedTypeDetails>()};
- compDetails && compDetails->isEnumerationType()) {
- return &component;
+ if (const Scope *dtScope{derived.scope()}) {
+ for (const auto &pair : *dtScope) {
+ const Symbol &symbol{*pair.second};
+ if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+ const DerivedTypeSpec *componentDerived{nullptr};
+ if (const DeclTypeSpec *type{details->type()}) {
+ if (type->category() == DeclTypeSpec::Category::TypeDerived) {
+ componentDerived = &type->derivedTypeSpec();
+ }
+ }
+ if (!componentDerived) {
+ continue;
+ }
+ // The component's type is itself an enumeration type: this is the
+ // enumeration effective item we are looking for.
+ if (const auto *compDetails{
+ componentDerived->typeSymbol().detailsIf<DerivedTypeDetails>()};
+ compDetails && compDetails->isEnumerationType()) {
+ return &symbol;
+ }
+ // The component is processed by defined I/O. It is treated as a single
+ // value and does not expand into its components.
+ if (HasDefinedIo(which, *componentDerived, &scope)) {
+ continue;
+ }
+ // Otherwise the component expands into its own components; recurse to
+ // look for an enumeration effective item nested within it.
+ if (const Symbol *bad{FindEnumerationTypeComponent(
+ which, *componentDerived, scope, visited)}) {
+ return bad;
+ }
}
}
}
return nullptr;
}
+static const Symbol *FindEnumerationTypeComponent(common::DefinedIo which,
+ const DerivedTypeSpec &derived, const Scope &scope) {
+ VisitedSymbolSet visited;
+ return FindEnumerationTypeComponent(which, derived, scope, visited);
+}
+
// Fortran 2018, 12.6.3 paragraphs 5 & 7
parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
common::DefinedIo which, parser::CharBlock where) const {
@@ -1326,7 +1359,7 @@ parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
if ((which == common::DefinedIo::ReadUnformatted ||
which == common::DefinedIo::WriteUnformatted) &&
!HasDefinedIo(which, derived, &scope)) {
- if (FindEnumerationTypeComponent(derived)) {
+ if (FindEnumerationTypeComponent(which, derived, scope)) {
return &context_.Say(where,
"Enumeration type may not be used in unformatted I/O"_err_en_US);
}
@@ -1407,23 +1440,16 @@ void IoChecker::CheckNamelist(const Symbol &namelist, common::DefinedIo which,
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;
- }
- }
- }
+ // A namelist group object of derived type that is not processed by
+ // defined I/O expands into its components (F2023 12.6.3), so reject one
+ // that reaches an enumeration effective item.
+ const Scope &scope{context_.FindScope(namelistLocation)};
+ if (!HasDefinedIo(which, derived, &scope)) {
+ if (const Symbol *bad{
+ FindEnumerationTypeComponent(which, derived, scope)}) {
+ context_.Say(namelistLocation,
+ "Namelist group object '%s' has a direct component '%s' of enumeration type"_err_en_US,
+ object.name(), bad->name());
}
}
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 21900d4d9643a..ef9c893bda4e9 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6260,7 +6260,8 @@ bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) {
}
void DeclarationVisitor::DeclareIntrinsic(const parser::Name &name) {
HandleAttributeStmt(Attr::INTRINSIC, name);
- if (!IsIntrinsic(name.source, std::nullopt)) {
+ const bool isKnownIntrinsic{IsIntrinsic(name.source, std::nullopt)};
+ if (!isKnownIntrinsic) {
Say(name.source, "'%s' is not a known intrinsic procedure"_err_en_US);
}
auto &symbol{DEREF(FindSymbol(name))};
@@ -6285,7 +6286,7 @@ void DeclarationVisitor::DeclareIntrinsic(const parser::Name &name) {
"INTRINSIC statement for explicitly-typed '%s'"_en_US, name.source);
}
}
- if (!symbol.test(Symbol::Flag::Function) &&
+ if (isKnownIntrinsic && !symbol.test(Symbol::Flag::Function) &&
!symbol.test(Symbol::Flag::Subroutine) &&
!context().intrinsics().IsDualIntrinsic(name.source.ToString())) {
if (context().intrinsics().IsIntrinsicFunction(name.source.ToString())) {
>From f7c913e4236cfb4d378015486c7e9c5cc65339d0 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 30 Jul 2026 14:02:06 -0500
Subject: [PATCH 8/9] Added test cases and corrected error text.
---
flang/lib/Semantics/check-io.cpp | 2 +-
.../enumeration-type-intrinsics-gating.f90 | 14 ++++-
flang/test/Semantics/enumeration-type-io.f90 | 55 ++++++++++++++++++-
3 files changed, 68 insertions(+), 3 deletions(-)
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index bf2599f440ac8..c6bff64466cc3 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -1448,7 +1448,7 @@ void IoChecker::CheckNamelist(const Symbol &namelist, common::DefinedIo which,
if (const Symbol *bad{
FindEnumerationTypeComponent(which, derived, scope)}) {
context_.Say(namelistLocation,
- "Namelist group object '%s' has a direct component '%s' of enumeration type"_err_en_US,
+ "Namelist group object '%s' has a component '%s' of enumeration type"_err_en_US,
object.name(), bad->name());
}
}
diff --git a/flang/test/Semantics/enumeration-type-intrinsics-gating.f90 b/flang/test/Semantics/enumeration-type-intrinsics-gating.f90
index 11fda942208c5..3ccab11d02ef4 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics-gating.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics-gating.f90
@@ -1,4 +1,4 @@
-! RUN: %flang_fc1 -fsyntax-only %s
+! RUN: %python %S/test_errors.py %s %flang_fc1
! 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
@@ -12,3 +12,15 @@ program p
i = next(5)
r = previous(3)
end program
+
+subroutine test_intrinsic_next_declaration()
+ ! Explicitly declaring NEXT intrinsic here (with the enumeration-type
+ ! feature disabled) must produce only the single expected diagnostic below.
+ ! Before the DeclareIntrinsic fix, the name was still incorrectly flagged
+ ! as an intrinsic function under the hood, risking a second, bogus
+ ! diagnostic when it was later referenced as a call below.
+ !ERROR: 'next' is not a known intrinsic procedure
+ intrinsic :: next
+ integer :: i
+ i = next(5)
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-io.f90 b/flang/test/Semantics/enumeration-type-io.f90
index d6841464342ec..215810d26ffdf 100644
--- a/flang/test/Semantics/enumeration-type-io.f90
+++ b/flang/test/Semantics/enumeration-type-io.f90
@@ -6,6 +6,26 @@ module enum_io_mod
enumeration type :: color
enumerator :: red, green, blue
end enumeration type
+
+ ! Wraps an enumeration component behind defined output I/O so it can be
+ ! used to test that a component with defined I/O shields whatever is
+ ! nested inside it from the enumeration-type component check.
+ type :: has_color_io
+ type(color) :: c
+ contains
+ procedure :: wfc
+ generic :: write(formatted) => wfc
+ end type
+contains
+ subroutine wfc(x, unit, iotype, vlist, iostat, iomsg)
+ class(has_color_io), intent(in) :: x
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: vlist(:)
+ integer, intent(out) :: iostat
+ character(*), intent(in out) :: iomsg
+ write(unit, '(I4)', iostat=iostat, iomsg=iomsg) x%c
+ end subroutine
end module
subroutine test_valid_io()
@@ -58,6 +78,39 @@ subroutine test_component_io()
read(10) d
end subroutine
+subroutine test_shielded_component()
+ ! A component whose type has defined output I/O is treated as a single
+ ! effective item (F2023 12.6.3) and is not expanded, so the enumeration
+ ! type nested inside has_color_io is shielded from the list-directed
+ ! output check. This is expected to compile without error.
+ use enum_io_mod
+ type :: wrapper
+ type(has_color_io) :: hc
+ end type
+ type(wrapper) :: w
+ w%hc%c = red
+ print *, w
+end subroutine
+
+subroutine test_nested_rejection()
+ ! The enumeration type is nested two levels deep through a plain
+ ! intermediate type with no defined I/O, so the recursive component
+ ! search must still find and reject it.
+ use enum_io_mod
+ type :: inner
+ type(color) :: c
+ end type
+ type :: outer
+ type(inner) :: i
+ end type
+ type(outer) :: o
+ o%i%c = red
+ !ERROR: List-directed output item has a component 'c' of enumeration type
+ print *, o
+ !ERROR: List-directed input item has a component 'c' of enumeration type
+ read *, o
+end subroutine
+
subroutine test_namelist_enum_object()
use enum_io_mod
type(color) :: c
@@ -74,7 +127,7 @@ subroutine test_namelist_enum_component()
end type
type(has_color) :: d
namelist /nml2/ d
- !ERROR: Namelist group object 'd' has a direct component 'clr' of enumeration type
+ !ERROR: Namelist group object 'd' has a component 'clr' of enumeration type
write(*, nml=nml2)
end subroutine
>From db6e2e9f09a635fa2a24d7a55709a71671101bdf Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Fri, 31 Jul 2026 09:23:43 -0500
Subject: [PATCH 9/9] Modified to erase visited on recursion return. Added a
test that demonstrates the issue and fix.
---
flang/lib/Semantics/check-io.cpp | 18 ++++-
.../enumeration-type-io-pdt-order.f90 | 73 +++++++++++++++++++
2 files changed, 88 insertions(+), 3 deletions(-)
create mode 100644 flang/test/Semantics/enumeration-type-io-pdt-order.f90
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index c6bff64466cc3..4092ab87e1bc2 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -1281,12 +1281,20 @@ static const Symbol *FindInaccessibleComponent(common::DefinedIo which,
// component that is itself processed by defined I/O is treated as a single
// value and is not expanded, so its subtree is skipped (based off of
// FindInaccessibleComponent).
+//
+// The 'visited' set must be *path-scoped*: a type symbol is inserted on entry
+// and erased on unwind, so it only prunes recursion when it names a true
+// ancestor on the current path (a real F2023 C749 recursive-type cycle). This
+// matters for parameterized derived types, where two instantiations share one
+// type symbol but their defined-I/O shielding is decided per-instantiation
+// (HasDefinedIo).
static const Symbol *FindEnumerationTypeComponent(common::DefinedIo which,
const DerivedTypeSpec &derived, const Scope &scope,
VisitedSymbolSet &visited) {
if (!visited.insert(&derived.typeSymbol()).second) {
return nullptr;
}
+ const Symbol *result{nullptr};
if (const Scope *dtScope{derived.scope()}) {
for (const auto &pair : *dtScope) {
const Symbol &symbol{*pair.second};
@@ -1305,7 +1313,8 @@ static const Symbol *FindEnumerationTypeComponent(common::DefinedIo which,
if (const auto *compDetails{
componentDerived->typeSymbol().detailsIf<DerivedTypeDetails>()};
compDetails && compDetails->isEnumerationType()) {
- return &symbol;
+ result = &symbol;
+ break;
}
// The component is processed by defined I/O. It is treated as a single
// value and does not expand into its components.
@@ -1316,12 +1325,15 @@ static const Symbol *FindEnumerationTypeComponent(common::DefinedIo which,
// look for an enumeration effective item nested within it.
if (const Symbol *bad{FindEnumerationTypeComponent(
which, *componentDerived, scope, visited)}) {
- return bad;
+ result = bad;
+ break;
}
}
}
}
- return nullptr;
+ // Erase on unwind so 'visited' tracks only the current recursion path.
+ visited.erase(&derived.typeSymbol());
+ return result;
}
static const Symbol *FindEnumerationTypeComponent(common::DefinedIo which,
diff --git a/flang/test/Semantics/enumeration-type-io-pdt-order.f90 b/flang/test/Semantics/enumeration-type-io-pdt-order.f90
new file mode 100644
index 0000000000000..8e56d2f89f49d
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-io-pdt-order.f90
@@ -0,0 +1,73 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -fenumeration-type
+!
+! This test verifies that the transversal order for enumeration type components
+! does not impact the correct recognition/reporting of unformatted output
+! errors.
+
+module enum_pdt_order_mod
+ !WARNING: ENUMERATION TYPE support is incomplete and should be enabled only for testing
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+
+ type :: leaf(k)
+ integer, kind :: k = 2
+ type(color) :: c
+ end type
+
+ type :: branch(k)
+ integer, kind :: k = 2
+ type(leaf(k)) :: item
+ end type
+
+ ! Defined unformatted output for leaf(1) ONLY.
+ interface write(unformatted)
+ module procedure wleaf1
+ end interface
+
+ type :: container
+ type(branch(1)) :: a_safe
+ type(branch(2)) :: b_bad
+ 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
+ integer :: tmp
+ ! Do not write dtv%c directly; an enumeration value may not appear in
+ ! unformatted I/O. Write a surrogate integer instead.
+ tmp = int(dtv%c)
+ write(unit, iostat=iostat, iomsg=iomsg) tmp
+ end subroutine
+
+ ! Positive control A: a lone shielded instantiation. leaf(1) has matching
+ ! defined unformatted output, so branch(1) expands to a single shielded item
+ ! 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 enumeration 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: Enumeration type may not be used in unformatted I/O
+ write(u) y
+ end subroutine
+
+ ! Expected (correct, post-fix) behavior: the error below is emitted.
+ subroutine test_order_bug(u)
+ integer, intent(in) :: u
+ type(container) :: z
+ !ERROR: Enumeration type may not be used in unformatted I/O
+ write(u) z
+ end subroutine
+end module
More information about the flang-commits
mailing list