[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 Sep 11 06:02:46 PDT 2026
https://github.com/kwyatt-ext updated https://github.com/llvm/llvm-project/pull/193235
>From c08274f029cd90e76e0c63c2b7f1af7d8567ab61 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 01/14] 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 467bc6f0f7005..ebbaeb54b711e 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1332,7 +1332,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 abfb48e5ad82b..2e8356d3badfa 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2951,6 +2951,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;
@@ -2979,7 +2991,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 {
@@ -3659,6 +3671,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) {
@@ -3867,6 +4043,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 87f7973f7e183..4c9aeebbbd0fe 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"
@@ -628,6 +629,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() << ')';
@@ -700,6 +705,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,
@@ -1140,6 +1221,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 83834671adac5..4e77e958dcf8e 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_;
// Modules already re-exported by a plain USE for an operator-less declare
// reduction, so the USE is written once even when several such reductions
@@ -83,6 +85,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 759b40ad9c207007e314134a8a86109855b5ed90 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 02/14] 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 b1e352c6ed0b0ac9b3166737b20d231acb8da7f7 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 03/14] 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 ebbaeb54b711e..6c916fdddd00a 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1353,8 +1353,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()
@@ -1376,10 +1379,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)};
}
@@ -1389,8 +1392,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 2e8356d3badfa..fc28d420d922a 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -3731,6 +3731,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}};
@@ -3768,6 +3782,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}};
@@ -3801,12 +3829,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
}
}
}
@@ -4043,38 +4083,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 aba12578e4eeab9027479084b6e5e4ce67f5ce30 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 04/14] 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 6c916fdddd00a..f50ac5bb25e56 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1356,7 +1356,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};
@@ -1367,24 +1367,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)
@@ -1397,6 +1394,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 c7db4069e3e28..c759191c0be1e 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 fc28d420d922a..7c6649935a902 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -3103,6 +3103,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 {
@@ -4084,19 +4109,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 af91064aa340d..43d210f251ef9 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 763122a95edb502c69487f85aa36d8d417520bc9 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 05/14] 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 e62b52f1f0bd4..d78ffbe5f8003 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -927,6 +927,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 4c9aeebbbd0fe..a39b8f7f95d10 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -709,26 +709,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 &&
@@ -751,7 +747,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);
}
}
}
@@ -1223,7 +1218,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 4e77e958dcf8e..a73d73be7b1a3 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_;
// Modules already re-exported by a plain USE for an operator-less declare
// reduction, so the USE is written once even when several such reductions
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 43d210f251ef9..9ee09379f21bc 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6520,6 +6520,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 05a9d0c86a0a98cbc0036947e4897295d60d41b2 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 06/14] 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 a39b8f7f95d10..331fdbe13a8a9 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -711,10 +711,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 f3252fb0c9a6cf4a478238185fda430ad947447b 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 07/14] 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 7c6649935a902..29af79c00d902 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -4109,8 +4109,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 9ee09379f21bc..8cd882f51f574 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6604,7 +6604,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))};
@@ -6629,7 +6630,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 2e0fd016f9f00fae76259e12decbd21ac1ed585d 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 08/14] 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 1d01fad50160c33b77bb42298b97c3f4c836b23a 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 09/14] 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
>From 81ffd9cde8a01eee92c0f460875b578bce2766c1 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Tue, 4 Aug 2026 15:29:36 -0500
Subject: [PATCH 10/14] Did the following: - Updated intrinsic.md document
- Simplified the code per recommendations - Fixed constant folding to be
context aware and only report errors in constant expressions. Otherwise
they are left for runtime. - Corrected namelist declaration error. -
Corrected enumeration type attributes. - Added/modified test cases are
appropriate.
---
flang/docs/Intrinsics.md | 18 +-
flang/include/flang/Evaluate/common.h | 11 +
flang/include/flang/Evaluate/type.h | 5 +
flang/include/flang/Semantics/symbol.h | 5 +
flang/lib/Evaluate/check-expression.cpp | 1 +
flang/lib/Evaluate/fold-implementation.h | 210 +++++++++---------
flang/lib/Evaluate/fold-integer.cpp | 64 +++---
flang/lib/Evaluate/intrinsics.cpp | 6 +-
flang/lib/Evaluate/tools.cpp | 29 +--
flang/lib/Evaluate/type.cpp | 11 +
flang/lib/Semantics/check-io.cpp | 11 +-
flang/lib/Semantics/check-namelist.cpp | 9 +
flang/lib/Semantics/mod-file.cpp | 23 +-
flang/lib/Semantics/resolve-names.cpp | 31 ++-
.../Semantics/enumeration-type-intrinsics.f90 | 32 ++-
flang/test/Semantics/enumeration-type-io.f90 | 2 +-
flang/test/Semantics/enumeration-type-mod.f90 | 21 ++
17 files changed, 297 insertions(+), 192 deletions(-)
diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index 1d4d85db7ad70..d4a9f1ccdecac 100644
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -224,7 +224,7 @@ EXPONENT(REAL(any) X) -> default INTEGER
FLOOR(REAL(any) A, KIND=KIND(0)) -> INTEGER(KIND)
IACHAR(CHARACTER(KIND=k,LEN=1) C, KIND=KIND(0)) -> INTEGER(KIND)
ICHAR(CHARACTER(KIND=k,LEN=1) C, KIND=KIND(0)) -> INTEGER(KIND)
-INT(INTEGER or REAL or COMPLEX or BOZ A, KIND=KIND(0)) -> INTEGER(KIND)
+INT(INTEGER or REAL or COMPLEX or BOZ or enumeration type A, KIND=KIND(0)) -> INTEGER(KIND)
LOGICAL(LOGICAL(any) L, KIND=KIND(.TRUE.)) -> LOGICAL(KIND)
REAL(INTEGER or REAL or COMPLEX or BOZ A, KIND=KIND(0.0)) -> REAL(KIND)
```
@@ -379,6 +379,20 @@ When `BACK` is `.TRUE.`, it returns the position of the rightmost character in
In Form 1, it returns the tokens as an array of characters and optionally the separator characters.
In Form 2, it returns the starting and ending positions of each token.
+### Enumeration type intrinsic functions (Fortran 2023)
+```
+NEXT(enumeration type A [, STAT]) -> same enumeration type as A
+PREVIOUS(enumeration type A [, STAT]) -> same enumeration type as A
+```
+
+`NEXT` returns the enumerator that follows `A` in declaration order; if `A` is
+already the last (`HUGE`) enumerator of its type, the result is `A` itself.
+`PREVIOUS` is the opposite: if `A` is the first enumerator, the result is `A`
+itself. `STAT` (optional, scalar `INTEGER` of any kind, `INTENT(OUT)`) is set
+to a positive, processor-dependent value in that boundary case, and to zero
+otherwise; if `STAT` would be assigned a nonzero value but is not present,
+error termination is initiated.
+
## Transformational intrinsic functions
This category comprises a large collection of intrinsic functions that
@@ -574,6 +588,7 @@ DIGITS(INTEGER or REAL X(..)) -> scalar default INTEGER
EPSILON(REAL(k) X(..)) -> scalar REAL(k)
HUGE(INTEGER(k) X(..)) -> scalar INTEGER(k)
HUGE(REAL(k) X(..)) -> scalar of REAL(k)
+HUGE(enumeration type X(..)) -> scalar of same enumeration type
KIND(intrinsic X(..)) -> scalar default INTEGER
MAXEXPONENT(REAL(k) X(..)) -> scalar default INTEGER
MINEXPONENT(REAL(k) X(..)) -> scalar default INTEGER
@@ -825,6 +840,7 @@ functions listed below are folded using host independent implementations.
| REAL | ABS(REAL(k)), ABS(COMPLEX(k)), AIMAG, AINT, DPROD, REAL |
| COMPLEX | CMPLX, CONJG |
| LOGICAL | BGE, BGT, BLE, BLT |
+| ENUMERATION | HUGE(enumeration type), NEXT/PREVIOUS(enumeration type) |
#### Intrinsic Functions with Host Dependent Folding Support
Implementations using the host runtime may not be available for all supported
diff --git a/flang/include/flang/Evaluate/common.h b/flang/include/flang/Evaluate/common.h
index 6adf395442edf..81f02181f0993 100644
--- a/flang/include/flang/Evaluate/common.h
+++ b/flang/include/flang/Evaluate/common.h
@@ -241,6 +241,7 @@ class FoldingContext {
pdtInstance_{that.pdtInstance_},
analyzingPDTComponentKindSelector_{
that.analyzingPDTComponentKindSelector_},
+ inConstantContext_{that.inConstantContext_},
impliedDos_{that.impliedDos_},
languageFeatures_{that.languageFeatures_}, tempNames_{that.tempNames_},
fpMaxminBehavior_{that.fpMaxminBehavior_} {}
@@ -251,6 +252,7 @@ class FoldingContext {
pdtInstance_{that.pdtInstance_},
analyzingPDTComponentKindSelector_{
that.analyzingPDTComponentKindSelector_},
+ inConstantContext_{that.inConstantContext_},
impliedDos_{that.impliedDos_},
languageFeatures_{that.languageFeatures_}, tempNames_{that.tempNames_},
fpMaxminBehavior_{that.fpMaxminBehavior_} {}
@@ -313,6 +315,11 @@ class FoldingContext {
return common::ScopedSet(analyzingPDTComponentKindSelector_, true);
}
+ bool inConstantContext() const { return inConstantContext_; }
+ common::Restorer<bool> WithConstantContext() {
+ return common::ScopedSet(inConstantContext_, true);
+ }
+
common::Restorer<std::string> SetRealFlagWarningContext(std::string str) {
return common::ScopedSet(realFlagWarningContext_, str);
}
@@ -330,6 +337,10 @@ class FoldingContext {
const TargetCharacteristics &targetCharacteristics_;
const semantics::DerivedTypeSpec *pdtInstance_{nullptr};
bool analyzingPDTComponentKindSelector_{false};
+ // True while folding an expression that is required to be constant (e.g. a
+ // named-constant or type-parameter initializer). Used to promote certain
+ // deferred-to-runtime conditions into compile-time diagnostics.
+ bool inConstantContext_{false};
std::optional<parser::CharBlock> moduleFileName_;
std::map<parser::CharBlock, ConstantSubscript> impliedDos_;
const common::LanguageFeatureControl &languageFeatures_;
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 165784159b9ca..ad78a8e37747b 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -249,6 +249,11 @@ class DynamicType {
const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &);
const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
const std::optional<DynamicType> &);
+// Return the DerivedTypeSpec of a DynamicType if it is an enumeration type,
+// otherwise null.
+const semantics::DerivedTypeSpec *GetEnumerationTypeSpec(const DynamicType &);
+const semantics::DerivedTypeSpec *GetEnumerationTypeSpec(
+ const std::optional<DynamicType> &);
const semantics::DerivedTypeSpec *GetParentTypeSpec(
const semantics::DerivedTypeSpec &);
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index d78ffbe5f8003..7853ef79ba179 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -570,6 +570,10 @@ class DerivedTypeDetails {
bool isDECStructure() const { return isDECStructure_; }
bool isEnumerationType() const { return isEnumerationType_; }
void set_isEnumerationType(bool x = true) { isEnumerationType_ = x; }
+ std::optional<Attr> enumeratorDefaultAccess() const {
+ return enumeratorDefaultAccess_;
+ }
+ void set_enumeratorDefaultAccess(Attr a) { enumeratorDefaultAccess_ = a; }
// Name of the hidden component created for an enumeration type to hold
// the 1-based enumerator ordinal.
static constexpr char ordinalComponentName[]{"__ordinal"};
@@ -629,6 +633,7 @@ class DerivedTypeDetails {
// These fields are only used if the derived type is an enumeration type.
bool isEnumerationType_{false};
int enumeratorCount_{0};
+ std::optional<Attr> enumeratorDefaultAccess_;
friend llvm::raw_ostream &operator<<(
llvm::raw_ostream &, const DerivedTypeDetails &);
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 737502a504d61..6e4ea495c6ab8 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -580,6 +580,7 @@ std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
}
}
if (converted) {
+ auto restorer{context.WithConstantContext()};
auto folded{Fold(context, std::move(*converted))};
if (IsActuallyConstant(folded)) {
InexactLiteralConversionFlagClearer{}(folded);
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index f50ac5bb25e56..2b948d4cd761a 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1255,6 +1255,110 @@ template <int KIND>
Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
FoldingContext &context, FunctionRef<Type<TypeCategory::Logical, KIND>> &&);
+// Fold NEXT(enum) / PREVIOUS(enum) to a constant enumerator (scalar or array)
+// when the argument is a constant enumeration value. Returns the folded
+// constant, or the original reference left unfolded (e.g. at a boundary,
+// where error termination is deferred to run time).
+static inline Expr<SomeDerived> FoldEnumerationNextOrPrevious(
+ FoldingContext &context, FunctionRef<SomeDerived> &&funcRef, bool isNext) {
+ ActualArguments &args{funcRef.arguments()};
+ // Don't fold if STAT is present — STAT assignment is a side effect
+ if (args.size() >= 2 && args[1]) {
+ return Expr<SomeDerived>{std::move(funcRef)};
+ }
+ auto *expr{args.size() >= 1 && args[0]
+ ? UnwrapExpr<Expr<SomeDerived>>(args[0])
+ : nullptr};
+ if (!expr) {
+ return Expr<SomeDerived>{std::move(funcRef)};
+ }
+ const auto *derived{GetEnumerationTypeSpec(expr->GetType())};
+ const semantics::Scope *scope{derived ? derived->GetScope() : nullptr};
+ if (!scope) {
+ return Expr<SomeDerived>{std::move(funcRef)};
+ }
+ auto ordIter{scope->find(
+ semantics::SourceName{semantics::DerivedTypeDetails::ordinalComponentName,
+ sizeof(semantics::DerivedTypeDetails::ordinalComponentName) - 1})};
+ if (ordIter == scope->end()) {
+ return Expr<SomeDerived>{std::move(funcRef)};
+ }
+ const semantics::Symbol &ordSym{*ordIter->second};
+ int count{derived->typeSymbol()
+ .GetUltimate()
+ .get<semantics::DerivedTypeDetails>()
+ .enumeratorCount()};
+ auto *constant{UnwrapConstantValue<SomeDerived>(*expr)};
+ if (!constant) {
+ return Expr<SomeDerived>{std::move(funcRef)};
+ }
+ // A boundary hit (NEXT() of the last enumerator or PREVIOUS() of the first)
+ // without STAT= is a runtime error termination, so in an ordinary expression
+ // it is left unfolded and deferred to run time. In a required-constant
+ // context the value cannot be deferred: diagnose it and mark the reference
+ // invalid so this specific message replaces the generic
+ // "cannot be computed as a constant value".
+ auto handleBoundary{[&]() -> Expr<SomeDerived> {
+ if (context.inConstantContext()) {
+ context.messages().Say(isNext
+ ? "NEXT() of the last enumerator is out of range"_err_en_US
+ : "PREVIOUS() of the first enumerator is out of range"_err_en_US);
+ return MakeInvalidIntrinsic<SomeDerived>(std::move(funcRef));
+ }
+ return Expr<SomeDerived>{std::move(funcRef)};
+ }};
+ if (auto sc{constant->GetScalarValue()}) {
+ if (auto ordExpr{sc->Find(ordSym)}) {
+ if (auto ordVal{ToInt64(*ordExpr)}) {
+ if (isNext ? *ordVal >= count : *ordVal <= 1) {
+ return handleBoundary();
+ }
+ 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}}});
+ return Expr<SomeDerived>{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 handleBoundary();
+ }
+ 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()}}};
+ }
+ return Expr<SomeDerived>{std::move(funcRef)};
+}
+
template <typename T>
Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
ActualArguments &args{funcRef.arguments()};
@@ -1343,110 +1447,8 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
}
}
} 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{
- semantics::DerivedTypeDetails::ordinalComponentName,
- sizeof(semantics::DerivedTypeDetails::
- ordinalComponentName) -
- 1})};
- 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)}) {
- 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)}) {
- 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}}});
- return Expr<SomeDerived>{
- 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()}}};
- }
- }
- }
- }
- }
- }
- }
- }
- }
+ return FoldEnumerationNextOrPrevious(
+ context, std::move(funcRef), name == "next");
}
} else {
return FoldIntrinsicFunction(context, std::move(funcRef));
diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp
index c759191c0be1e..4b596532ef4aa 100644
--- a/flang/lib/Evaluate/fold-integer.cpp
+++ b/flang/lib/Evaluate/fold-integer.cpp
@@ -763,44 +763,40 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
if (auto *expr{UnwrapExpr<Expr<SomeType>>(args[0])}) {
// Check for enumeration type argument first — extract __ordinal
if (auto *derivedExpr{std::get_if<Expr<SomeDerived>>(&expr->u)}) {
- 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()}}};
- }
+ if (const auto *derived{
+ GetEnumerationTypeSpec(derivedExpr->GetType())}) {
+ // 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)};
}
}
+ // Non-constant enumeration argument — leave unfolded
+ return Expr<T>{std::move(funcRef)};
}
}
return common::visit(
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 29af79c00d902..88874f7ef08e8 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -4120,11 +4120,9 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
common::LanguageFeature::EnumerationType)) {
const semantics::DerivedTypeSpec *derived{nullptr};
if (const ActualArgument *arg{FindFirstDummyArgument(arguments, "a")}) {
- if (auto type{arg->GetType()}) {
- derived = GetDerivedTypeSpec(*type);
- }
+ derived = GetEnumerationTypeSpec(arg->GetType());
}
- if (derived && derived->IsEnumerationType()) {
+ if (derived) {
return call.name == "next"
? HandleEnumerationNext(*derived, arguments, context)
: HandleEnumerationPrevious(*derived, arguments, context);
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index def85232cc572..cd7e28b5724ac 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -693,24 +693,19 @@ Expr<LogicalResult> PromoteAndRelate(
}
std::optional<Expr<SomeType>> GetEnumerationOrdinal(Expr<SomeDerived> &expr) {
- if (auto type{expr.GetType()}) {
- if (const auto *derived{GetDerivedTypeSpec(*type)}) {
- if (derived->IsEnumerationType()) {
- if (const auto *scope{derived->GetScope()}) {
- auto iter{scope->find(semantics::SourceName{
- semantics::DerivedTypeDetails::ordinalComponentName,
- sizeof(semantics::DerivedTypeDetails::ordinalComponentName) -
- 1})};
- if (iter != scope->end()) {
- const semantics::Symbol &ordSym{*iter->second};
- if (auto *constant{UnwrapConstantValue<SomeDerived>(expr)}) {
- if (auto sc{constant->GetScalarValue()}) {
- return sc->Find(ordSym);
- }
- } else if (auto *sc{UnwrapExpr<StructureConstructor>(expr)}) {
- return sc->Find(ordSym);
- }
+ if (const auto *derived{GetEnumerationTypeSpec(expr.GetType())}) {
+ if (const auto *scope{derived->GetScope()}) {
+ auto iter{scope->find(semantics::SourceName{
+ semantics::DerivedTypeDetails::ordinalComponentName,
+ sizeof(semantics::DerivedTypeDetails::ordinalComponentName) - 1})};
+ if (iter != scope->end()) {
+ const semantics::Symbol &ordSym{*iter->second};
+ if (auto *constant{UnwrapConstantValue<SomeDerived>(expr)}) {
+ if (auto sc{constant->GetScalarValue()}) {
+ return sc->Find(ordSym);
}
+ } else if (auto *sc{UnwrapExpr<StructureConstructor>(expr)}) {
+ return sc->Find(ordSym);
}
}
}
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 3913bd394fde0..05575b5f3a7af 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -276,6 +276,17 @@ const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
}
}
+const semantics::DerivedTypeSpec *GetEnumerationTypeSpec(
+ const DynamicType &type) {
+ const semantics::DerivedTypeSpec *derived{GetDerivedTypeSpec(type)};
+ return derived && derived->IsEnumerationType() ? derived : nullptr;
+}
+
+const semantics::DerivedTypeSpec *GetEnumerationTypeSpec(
+ const std::optional<DynamicType> &type) {
+ return type ? GetEnumerationTypeSpec(*type) : nullptr;
+}
+
static const semantics::Symbol *FindParentComponent(
const semantics::DerivedTypeSpec &derived) {
const semantics::Symbol &typeSymbol{derived.typeSymbol()};
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index 4092ab87e1bc2..619754db98ed2 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -1443,15 +1443,8 @@ void IoChecker::CheckNamelist(const Symbol &namelist, common::DefinedIo which,
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;
- }
- }
+ // A bare enumeration-type namelist group object is rejected earlier at
+ // declaration time (F2023 C8109) in NamelistChecker.
// 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.
diff --git a/flang/lib/Semantics/check-namelist.cpp b/flang/lib/Semantics/check-namelist.cpp
index eedc1a66b563e..1b1148189d38d 100644
--- a/flang/lib/Semantics/check-namelist.cpp
+++ b/flang/lib/Semantics/check-namelist.cpp
@@ -36,6 +36,15 @@ void NamelistChecker::Leave(const parser::NamelistStmt &nmlStmt) {
"A namelist group object '%s' should not be a PARAMETER"_port_en_US,
nmlObjSymbol->name());
}
+ if (const DeclTypeSpec *type{nmlObjSymbol->GetType()}) {
+ if (const DerivedTypeSpec *derived{type->AsDerived()}) {
+ if (IsEnumerationType(*derived)) { // F2023 C8109
+ context_.Say(nmlObjName.source,
+ "Enumeration type '%s' may not be a namelist group object"_err_en_US,
+ derived->name());
+ }
+ }
+ }
}
}
}
diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp
index 331fdbe13a8a9..ddf269883fb19 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -765,12 +765,27 @@ void ModFileWriter::PutEnumerationType(const Symbol &typeSymbol) {
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).
+ // Emit accessibility only for enumerators that differ from the default the
+ // reader will apply the ENUMERATION TYPE access-spec if present, otherwise
+ // the module default.
if (!isSubmodule_) {
+ Attr enumDefault{Attr::PUBLIC};
+ if (const Symbol *modSym{typeSymbol.owner().symbol()}) {
+ if (const auto *modDetails{modSym->detailsIf<ModuleDetails>()}) {
+ if (modDetails->isDefaultPrivate()) {
+ enumDefault = Attr::PRIVATE;
+ }
+ }
+ }
+ if (auto a{details.enumeratorDefaultAccess()}) {
+ enumDefault = *a;
+ }
for (const auto &e : enumerators) {
- if (e.sym->attrs().test(Attr::PRIVATE)) {
- decls_ << "private::" << e.name << '\n';
+ Attr actual{
+ e.sym->attrs().test(Attr::PRIVATE) ? Attr::PRIVATE : Attr::PUBLIC};
+ if (actual != enumDefault) {
+ decls_ << (actual == Attr::PRIVATE ? "private::" : "public::") << e.name
+ << '\n';
}
}
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 8cd882f51f574..21f83e9d87cc1 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -4893,7 +4893,19 @@ void ModuleVisitor::ApplyDefaultAccess() {
Symbol &symbol{*pair.second};
if (!symbol.attrs().HasAny({Attr::PUBLIC, Attr::PRIVATE})) {
Attr attr{defaultAttr};
- if (auto *generic{symbol.detailsIf<GenericDetails>()}) {
+ if (symbol.test(Symbol::Flag::EnumeratorParameter)) {
+ // F2023 7.6.2p2: the access-spec on the ENUMERATION TYPE statement
+ // supplies the default accessibility of its enumerators. A
+ // use-associated enumerator also carries the flag but holds UseDetails,
+ // not ObjectEntityDetails; it follows the module default here.
+ if (const auto *obj{symbol.detailsIf<ObjectEntityDetails>()}) {
+ const Symbol &typeSym{obj->type()->derivedTypeSpec().typeSymbol()};
+ if (auto a{typeSym.get<DerivedTypeDetails>()
+ .enumeratorDefaultAccess()}) {
+ attr = *a;
+ }
+ }
+ } else if (auto *generic{symbol.detailsIf<GenericDetails>()}) {
if (generic->derivedType()) {
// If a generic interface has a derived type of the same
// name that has an explicit accessibility attribute, then
@@ -6461,13 +6473,10 @@ bool DeclarationVisitor::Pre(const parser::EnumerationTypeDef &x) {
void DeclarationVisitor::Post(const parser::EnumerationTypeStmt &x) {
const auto &name{std::get<parser::Name>(x.t)};
Attrs attrs{EndAttrs()};
- if (const auto &optAccessSpec{
- std::get<std::optional<parser::AccessSpec>>(x.t)};
- optAccessSpec) {
- if (!NonDerivedTypeScope().IsModule()) { // F2023 C7114
- Say(currStmtSource().value(),
- "Access specifier on ENUMERATION TYPE may only appear in the specification part of a module"_err_en_US);
- }
+ const auto &optAccessSpec{std::get<std::optional<parser::AccessSpec>>(x.t)};
+ if (optAccessSpec && !NonDerivedTypeScope().IsModule()) { // F2023 C7114
+ Say(currStmtSource().value(),
+ "Access specifier on ENUMERATION TYPE may only appear in the specification part of a module"_err_en_US);
}
// F2023 C7116: the enumeration-type-name in an enumeration-type-spec shall be
// the name of a previously defined enumeration type. Enumeration Types are
@@ -6483,6 +6492,12 @@ void DeclarationVisitor::Post(const parser::EnumerationTypeStmt &x) {
}
DerivedTypeDetails details;
details.set_isEnumerationType(true);
+ // An access-spec on the ENUMERATION TYPE statement sets the default
+ // accessibility of its enumerators.
+ if (optAccessSpec) {
+ details.set_enumeratorDefaultAccess(
+ attrs.test(Attr::PRIVATE) ? Attr::PRIVATE : Attr::PUBLIC);
+ }
auto &symbol{MakeSymbol(name, attrs, std::move(details))};
symbol.ReplaceName(name.source);
PushScope(Scope::Kind::DerivedType, &symbol);
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
index 0609b16f35bfe..788636eafc331 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -139,19 +139,21 @@ subroutine test_previous_boundary_with_stat()
pc = previous(red, stat=istat)
end subroutine
-subroutine test_next_boundary_warning()
+subroutine test_next_boundary_no_diagnostic()
use enum_intrinsics_mod
type(color) :: nc
- ! NEXT at boundary without STAT — error
- !CHECK: error: NEXT() of last enumerator without STAT= causes error termination
+ ! NEXT at boundary without STAT is a runtime error termination, not a
+ ! compile-time error: folding leaves the call unfolded and emits no
+ ! diagnostic (the statement may never execute).
nc = next(blue)
end subroutine
-subroutine test_previous_boundary_warning()
+subroutine test_previous_boundary_no_diagnostic()
use enum_intrinsics_mod
type(color) :: pc
- ! PREVIOUS at boundary without STAT — error
- !CHECK: error: PREVIOUS() of first enumerator without STAT= causes error termination
+ ! PREVIOUS at boundary without STAT is a runtime error termination, not a
+ ! compile-time error: folding leaves the call unfolded and emits no
+ ! diagnostic (the statement may never execute).
pc = previous(red)
end subroutine
@@ -159,14 +161,24 @@ 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
+ ! boundary is a runtime error termination without STAT=, so folding leaves
+ ! the whole reference unfolded and emits no diagnostic (same as the scalar
+ ! boundary case).
nc = next([green, blue])
- !CHECK: error: PREVIOUS() of first enumerator without STAT= causes error termination
pc = previous([red, green])
end subroutine
+subroutine test_next_previous_boundary_constant()
+ use enum_intrinsics_mod
+ ! In a required-constant context the boundary case cannot be deferred to
+ ! run time: the initializer must fold to a constant, so the boundary is
+ ! diagnosed at compile time.
+ !CHECK: error: NEXT() of the last enumerator is out of range
+ logical, parameter :: nb = next(blue) == green
+ !CHECK: error: PREVIOUS() of the first enumerator is out of range
+ logical, parameter :: pb = previous(red) == green
+end subroutine
+
subroutine test_huge_real_still_works()
! Non-enumeration HUGE still works normally
real :: r
diff --git a/flang/test/Semantics/enumeration-type-io.f90 b/flang/test/Semantics/enumeration-type-io.f90
index 215810d26ffdf..070243c88743a 100644
--- a/flang/test/Semantics/enumeration-type-io.f90
+++ b/flang/test/Semantics/enumeration-type-io.f90
@@ -114,8 +114,8 @@ subroutine test_nested_rejection()
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
+ namelist /nml/ c
write(*, nml=nml)
end subroutine
diff --git a/flang/test/Semantics/enumeration-type-mod.f90 b/flang/test/Semantics/enumeration-type-mod.f90
index 9188f105d5892..a5f3572a3a4dc 100644
--- a/flang/test/Semantics/enumeration-type-mod.f90
+++ b/flang/test/Semantics/enumeration-type-mod.f90
@@ -120,3 +120,24 @@ module m7
!end enumeration type
!end
+! Explicit PUBLIC accessibility statement overriding one enumerator of a
+! PRIVATE enumeration type. Per F2023 7.6.2p2, the access-spec on the
+! ENUMERATION TYPE statement sets the default accessibility of the enumerators
+! (private here), so red and blue are private; 'public :: green' overrides
+! green back to public. Only the override differing from the type default is
+! emitted.
+module m8
+ enumeration type, private :: color
+ enumerator :: red, green, blue
+ end enumeration type
+ public :: green
+end module
+
+!Expect: m8.mod
+!module m8
+!enumeration type,private::color
+!enumerator::red,green,blue
+!end enumeration type
+!public::green
+!end
+
>From fb5351bbf80733410dcbd2f99d42d2f02adf8db0 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Wed, 5 Aug 2026 12:13:39 -0500
Subject: [PATCH 11/14] Corrected the recursion block to have memory,
preventing exponential blowup. I also tested this with an ad-hoc test and
verified the problem and fix. Added a couple of test cases to demonstrate
that order does not prevent error detection.
---
flang/lib/Semantics/check-io.cpp | 104 ++++++++++--------
.../enumeration-type-io-pdt-order.f90 | 44 ++++++++
2 files changed, 104 insertions(+), 44 deletions(-)
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index 619754db98ed2..a4326972c3535 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -1282,64 +1282,80 @@ static const Symbol *FindInaccessibleComponent(common::DefinedIo which,
// 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).
+// The walk is memoized on the *instantiated scope* (derived.scope()), which is
+// the key that distinguishes two parameterized-derived-type instantiations
+// sharing one type symbol -- their defined-I/O shielding is decided per
+// instantiation (HasDefinedIo). This is a two-color DFS:
+// - 'onPath' holds the scopes currently on the recursion stack; a repeat
+// entry is an F2023 C749 recursive-type cycle and is pruned without being
+// cached, since that partial result is only valid under the ancestor.
+// - 'cache' holds the result of each fully-walked subtree, giving linear
+// cost instead of the fanout^depth of an unmemoized path-scoped walk.
+// The cache is sound because a subtree's result depends only on 'which', the
+// (fixed) outer 'scope', and the instantiated scope's contents; for the
+// acyclic type graphs that legal unformatted I/O permits, no cycle prune
+// contaminates a cached result.
+using EnumComponentPathSet = std::unordered_set<const Scope *>;
+using EnumComponentCache = std::unordered_map<const Scope *, const Symbol *>;
+
static const Symbol *FindEnumerationTypeComponent(common::DefinedIo which,
const DerivedTypeSpec &derived, const Scope &scope,
- VisitedSymbolSet &visited) {
- if (!visited.insert(&derived.typeSymbol()).second) {
+ EnumComponentPathSet &onPath, EnumComponentCache &cache) {
+ const Scope *dtScope{derived.scope()};
+ if (!dtScope) {
return nullptr;
}
+ if (auto it{cache.find(dtScope)}; it != cache.end()) {
+ return it->second;
+ }
+ if (!onPath.insert(dtScope).second) {
+ return nullptr; // cycle: prune without caching
+ }
const Symbol *result{nullptr};
- 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()) {
- 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.
- 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)}) {
- result = bad;
- break;
+ 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()) {
+ 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.
+ 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, onPath, cache)}) {
+ result = bad;
+ break;
+ }
}
}
- // Erase on unwind so 'visited' tracks only the current recursion path.
- visited.erase(&derived.typeSymbol());
+ onPath.erase(dtScope);
+ cache.emplace(dtScope, result);
return result;
}
static const Symbol *FindEnumerationTypeComponent(common::DefinedIo which,
const DerivedTypeSpec &derived, const Scope &scope) {
- VisitedSymbolSet visited;
- return FindEnumerationTypeComponent(which, derived, scope, visited);
+ EnumComponentPathSet onPath;
+ EnumComponentCache cache;
+ return FindEnumerationTypeComponent(which, derived, scope, onPath, cache);
}
// Fortran 2018, 12.6.3 paragraphs 5 & 7
diff --git a/flang/test/Semantics/enumeration-type-io-pdt-order.f90 b/flang/test/Semantics/enumeration-type-io-pdt-order.f90
index 8e56d2f89f49d..6eb87e83eca38 100644
--- a/flang/test/Semantics/enumeration-type-io-pdt-order.f90
+++ b/flang/test/Semantics/enumeration-type-io-pdt-order.f90
@@ -25,11 +25,36 @@ module enum_pdt_order_mod
module procedure wleaf1
end interface
+ ! NOTE: Scope iterates components in SourceName (alphabetical) order, not
+ ! declaration order. The three containers below deliberately pin down both
+ ! traversal orders so the test does not silently depend on the component
+ ! names chosen:
+ ! - In `container`, the shielded branch(1) sorts first (a_safe < b_bad).
+ ! - In `container_rev`, the unshielded branch(2) sorts first (a_bad <
+ ! b_safe).
+ ! - In `container_rev_decl`, the failing branch(2) is declared first but
+ ! sorts last (a_safe < b_bad), so declaration order and traversal order
+ ! disagree and the error must still surface.
+ ! Renaming a component in only one container would change which subtree is
+ ! visited first; keeping both spellings covers the error path regardless of
+ ! iteration order. In `container_rev` the components are also declared in
+ ! non-alphabetical order (b_safe before a_bad) so the source itself shows
+ ! that SourceName order, not declaration order, drives the traversal.
type :: container
type(branch(1)) :: a_safe
type(branch(2)) :: b_bad
end type
+ type :: container_rev
+ type(branch(1)) :: b_safe
+ type(branch(2)) :: a_bad
+ end type
+
+ type :: container_rev_decl
+ type(branch(2)) :: b_bad
+ type(branch(1)) :: a_safe
+ end type
+
contains
subroutine wleaf1(dtv, unit, iostat, iomsg)
class(leaf(1)), intent(in) :: dtv
@@ -70,4 +95,23 @@ subroutine test_order_bug(u)
!ERROR: Enumeration type may not be used in unformatted I/O
write(u) z
end subroutine
+
+ ! Same as above, but the unshielded branch(2) is visited first in SourceName
+ ! order. The error must still be emitted regardless of traversal order.
+ subroutine test_order_bug_rev(u)
+ integer, intent(in) :: u
+ type(container_rev) :: z
+ !ERROR: Enumeration type may not be used in unformatted I/O
+ write(u) z
+ end subroutine
+
+ ! Failing branch(2) is declared first but sorts last (a_safe < b_bad), so it
+ ! is visited last; the error must still be emitted regardless of the mismatch
+ ! between declaration order and traversal order.
+ subroutine test_order_bug_rev_decl(u)
+ integer, intent(in) :: u
+ type(container_rev_decl) :: z
+ !ERROR: Enumeration type may not be used in unformatted I/O
+ write(u) z
+ end subroutine
end module
>From e13288560067f58e35c67bf707c027d4d886d241 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 6 Aug 2026 15:48:06 -0500
Subject: [PATCH 12/14] Updated with the following changes: - Modified to
report an error on boundary condition. - Modified tests for the boundary
error message. - Corrected accessibility attributes by giving explicit
attributes as needed. - Added regression test for attributes. - Reworded
incorrect comment. - Switched to originalTypeSymbol to use in-scope name.
- Added test case to verify pre-built mod name usage.
---
flang/lib/Evaluate/fold-implementation.h | 21 +++--
flang/lib/Semantics/check-io.cpp | 17 ++--
flang/lib/Semantics/mod-file.cpp | 24 +++---
flang/lib/Semantics/type.cpp | 5 +-
.../Semantics/enumeration-type-intrinsics.f90 | 36 ++++----
.../enumeration-type-mod-readback.F90 | 82 +++++++++++++++++++
flang/test/Semantics/enumeration-type-mod.f90 | 10 +++
7 files changed, 151 insertions(+), 44 deletions(-)
create mode 100644 flang/test/Semantics/enumeration-type-mod-readback.F90
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 2b948d4cd761a..f89fb1601176e 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1293,19 +1293,26 @@ static inline Expr<SomeDerived> FoldEnumerationNextOrPrevious(
return Expr<SomeDerived>{std::move(funcRef)};
}
// A boundary hit (NEXT() of the last enumerator or PREVIOUS() of the first)
- // without STAT= is a runtime error termination, so in an ordinary expression
- // it is left unfolded and deferred to run time. In a required-constant
- // context the value cannot be deferred: diagnose it and mark the reference
- // invalid so this specific message replaces the generic
- // "cannot be computed as a constant value".
+ // without STAT= is, in the final design, a runtime error termination. In a
+ // required-constant context that value cannot be deferred, so it is
+ // diagnosed as out of range. Outside a constant context the reference would
+ // otherwise be left unfolded and deferred to run time — but lowering has no
+ // NEXT/PREVIOUS support yet (IntrinsicCall.cpp aborts), so a constant
+ // boundary argument is temporarily gated here, mirroring the STAT= and
+ // non-constant guards in intrinsics.cpp, until the lowering handler lands.
auto handleBoundary{[&]() -> Expr<SomeDerived> {
if (context.inConstantContext()) {
context.messages().Say(isNext
? "NEXT() of the last enumerator is out of range"_err_en_US
: "PREVIOUS() of the first enumerator is out of range"_err_en_US);
- return MakeInvalidIntrinsic<SomeDerived>(std::move(funcRef));
+ } else {
+ // TEMPORARY: gate the boundary case until lowering handler lands in PR
+ // 4/5
+ context.messages().Say(isNext
+ ? "NEXT() at the last enumerator is not yet supported"_err_en_US
+ : "PREVIOUS() at the first enumerator is not yet supported"_err_en_US);
}
- return Expr<SomeDerived>{std::move(funcRef)};
+ return MakeInvalidIntrinsic<SomeDerived>(std::move(funcRef));
}};
if (auto sc{constant->GetScalarValue()}) {
if (auto ordExpr{sc->Find(ordSym)}) {
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index a4326972c3535..12ff05de5def6 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -1287,14 +1287,19 @@ static const Symbol *FindInaccessibleComponent(common::DefinedIo which,
// sharing one type symbol -- their defined-I/O shielding is decided per
// instantiation (HasDefinedIo). This is a two-color DFS:
// - 'onPath' holds the scopes currently on the recursion stack; a repeat
-// entry is an F2023 C749 recursive-type cycle and is pruned without being
-// cached, since that partial result is only valid under the ancestor.
+// entry is a back edge from a recursive type (e.g. a component that is a
+// pointer/allocatable to the enclosing type -- unlike
+// FindInaccessibleComponent, such components are not skipped here) and is
+// pruned without being cached, since that partial result is only valid
+// under the ancestor.
// - 'cache' holds the result of each fully-walked subtree, giving linear
// cost instead of the fanout^depth of an unmemoized path-scoped walk.
-// The cache is sound because a subtree's result depends only on 'which', the
-// (fixed) outer 'scope', and the instantiated scope's contents; for the
-// acyclic type graphs that legal unformatted I/O permits, no cycle prune
-// contaminates a cached result.
+// The type graph may therefore contain cycles. Pruning a back edge is sound
+// because every reachable scope is entered once and checks its own components
+// on entry, so the target of a back edge has already been inspected: pruning
+// it cannot hide an enumeration component from the result. This relies on
+// stopping at the first match; revisit it if the walk is ever changed to
+// collect every offending component.
using EnumComponentPathSet = std::unordered_set<const Scope *>;
using EnumComponentCache = std::unordered_map<const Scope *, const Symbol *>;
diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp
index ddf269883fb19..cfc2706811c65 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -765,21 +765,17 @@ void ModFileWriter::PutEnumerationType(const Symbol &typeSymbol) {
decls_ << '\n';
}
decls_ << "end enumeration type\n";
- // Emit accessibility only for enumerators that differ from the default the
- // reader will apply the ENUMERATION TYPE access-spec if present, otherwise
- // the module default.
+ // Emit an explicit access statement for every enumerator that differs from
+ // the default the reader will reconstruct. The reader derives that default
+ // solely from the ENUMERATION TYPE statement it reads back: PutAttrs writes
+ // the type's own PRIVATE attribute as an access-spec there, and an access-
+ // spec sets the enumerator default (F2023 7.6.2p2). A module file never
+ // emits a bare module-default `private`, and enumeratorDefaultAccess() is
+ // not separately serialized, so the round-trip default is exactly "PRIVATE
+ // if the type itself is PRIVATE, else PUBLIC".
if (!isSubmodule_) {
- Attr enumDefault{Attr::PUBLIC};
- if (const Symbol *modSym{typeSymbol.owner().symbol()}) {
- if (const auto *modDetails{modSym->detailsIf<ModuleDetails>()}) {
- if (modDetails->isDefaultPrivate()) {
- enumDefault = Attr::PRIVATE;
- }
- }
- }
- if (auto a{details.enumeratorDefaultAccess()}) {
- enumDefault = *a;
- }
+ Attr enumDefault{
+ typeSymbol.attrs().test(Attr::PRIVATE) ? Attr::PRIVATE : Attr::PUBLIC};
for (const auto &e : enumerators) {
Attr actual{
e.sym->attrs().test(Attr::PRIVATE) ? Attr::PRIVATE : Attr::PUBLIC};
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 448a29b7c18bd..2d27879afdaac 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -1011,7 +1011,10 @@ std::string DeclTypeSpec::AsFortran() const {
.typeSymbol()
.get<DerivedTypeDetails>()
.isEnumerationType()) {
- return "TYPE(" + derivedTypeSpec().typeSymbol().name().ToString() + ')';
+ // Preserve the in-scope (possibly USE-renamed) spelling so the name
+ // written to a module file resolves on readback.
+ return "TYPE(" +
+ derivedTypeSpec().originalTypeSymbol().name().ToString() + ')';
} else {
return "TYPE(" + derivedTypeSpec().AsFortran() + ')';
}
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
index 788636eafc331..163a24a1bff13 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -139,21 +139,23 @@ subroutine test_previous_boundary_with_stat()
pc = previous(red, stat=istat)
end subroutine
-subroutine test_next_boundary_no_diagnostic()
+subroutine test_next_boundary()
use enum_intrinsics_mod
type(color) :: nc
- ! NEXT at boundary without STAT is a runtime error termination, not a
- ! compile-time error: folding leaves the call unfolded and emits no
- ! diagnostic (the statement may never execute).
+ ! NEXT at the last enumerator without STAT is, in the final design, a runtime
+ ! error termination. Until the lowering handler lands (PR 4/5) the constant
+ ! boundary case is temporarily rejected at compile time rather than reaching
+ ! the unimplemented lowering path.
+ !CHECK: error: NEXT() at the last enumerator is not yet supported
nc = next(blue)
end subroutine
-subroutine test_previous_boundary_no_diagnostic()
+subroutine test_previous_boundary()
use enum_intrinsics_mod
type(color) :: pc
- ! PREVIOUS at boundary without STAT is a runtime error termination, not a
- ! compile-time error: folding leaves the call unfolded and emits no
- ! diagnostic (the statement may never execute).
+ ! PREVIOUS at the first enumerator without STAT is, in the final design, a
+ ! runtime error termination. Temporarily rejected until lowering lands.
+ !CHECK: error: PREVIOUS() at the first enumerator is not yet supported
pc = previous(red)
end subroutine
@@ -161,21 +163,23 @@ subroutine test_next_previous_array_boundary()
use enum_intrinsics_mod
type(color) :: nc(2), pc(2)
! NEXT/PREVIOUS are elemental: a constant array with any element at the
- ! boundary is a runtime error termination without STAT=, so folding leaves
- ! the whole reference unfolded and emits no diagnostic (same as the scalar
- ! boundary case).
+ ! boundary is a runtime error termination without STAT=. Temporarily
+ ! rejected until lowering lands (same as the scalar boundary case).
+ !CHECK: error: NEXT() at the last enumerator is not yet supported
nc = next([green, blue])
+ !CHECK: error: PREVIOUS() at the first enumerator is not yet supported
pc = previous([red, green])
end subroutine
subroutine test_next_previous_boundary_constant()
use enum_intrinsics_mod
- ! In a required-constant context the boundary case cannot be deferred to
- ! run time: the initializer must fold to a constant, so the boundary is
- ! diagnosed at compile time.
- !CHECK: error: NEXT() of the last enumerator is out of range
+ ! A required-constant boundary case would normally be diagnosed as out of
+ ! range at compile time. While NEXT/PREVIOUS are temporarily gated (PR 4/5),
+ ! the runtime-context gate fires first and reports "not yet supported"
+ ! instead; this reverts to "out of range" once the lowering handler lands.
+ !CHECK: error: NEXT() at the last enumerator is not yet supported
logical, parameter :: nb = next(blue) == green
- !CHECK: error: PREVIOUS() of the first enumerator is out of range
+ !CHECK: error: PREVIOUS() at the first enumerator is not yet supported
logical, parameter :: pb = previous(red) == green
end subroutine
diff --git a/flang/test/Semantics/enumeration-type-mod-readback.F90 b/flang/test/Semantics/enumeration-type-mod-readback.F90
new file mode 100644
index 0000000000000..92cd1cf6935ec
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-mod-readback.F90
@@ -0,0 +1,82 @@
+!RUN: rm -rf %t && mkdir -p %t
+!RUN: %flang_fc1 -fenumeration-type -fsyntax-only -DSTEP=1 -J%t %s
+!RUN: %flang_fc1 -fenumeration-type -fsyntax-only -DSTEP=2 -J%t %s
+!RUN: not %flang_fc1 -fenumeration-type -fsyntax-only -DSTEP=3 -J%t %s 2>&1 | FileCheck --check-prefix=CHECK-PRIVTYPE %s
+!RUN: not %flang_fc1 -fenumeration-type -fsyntax-only -DSTEP=4 -J%t %s 2>&1 | FileCheck --check-prefix=CHECK-LEAK %s
+!RUN: %flang_fc1 -fenumeration-type -fsyntax-only -DSTEP=5 -J%t %s
+
+! Enumerator accessibility must survive being written to a module file and read
+! back: each using unit below is compiled in a SEPARATE invocation that reloads
+! m*.mod through the module-file reader, which test_modfile.py (text-only
+! comparison) cannot exercise. See enumeration-type-mod.f90 (m7) for the
+! generated-text expectations.
+
+#if STEP == 1
+! Producers, written to %t.
+
+! 'private :: color' is an access-STATEMENT on the type name; it does NOT set
+! the enumerator default (F2023 7.6.2p2), so red/green/blue are PUBLIC while the
+! type color is PRIVATE.
+module m7a
+ private :: color
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end module
+
+! Module default private with the type made public: the enumerators take the
+! module default (PRIVATE) while color is PUBLIC.
+module m7b
+ private
+ public :: color
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end module
+
+! A USE-renamed enumeration type must be written to the module file under its
+! in-scope (renamed) spelling so it resolves on readback.
+module m7c
+ enumeration type :: color
+ enumerator :: red, green, blue
+ end enumeration type
+end module
+
+module m7d
+ use m7c, only: hue => color
+ type(hue) :: v
+end module
+#endif
+
+#if STEP == 2
+! A PUBLIC enumerator of a PRIVATE type stays usable through the module file,
+! and a PUBLIC type with PRIVATE enumerators still exposes the type.
+subroutine use_public
+ use m7a, only: green
+ use m7b, only: color
+end subroutine
+#endif
+
+#if STEP == 3
+! color is PRIVATE in m7a; reading m7a.mod must still reject it.
+subroutine use_private_type
+ !CHECK-PRIVTYPE: 'color' is PRIVATE in 'm7a'
+ use m7a, only: color
+end subroutine
+#endif
+
+#if STEP == 4
+! red is PRIVATE in m7b; a private enumerator must not leak through m7b.mod.
+subroutine use_private_enumerator
+ !CHECK-LEAK: 'red' is PRIVATE in 'm7b'
+ use m7b, only: red
+end subroutine
+#endif
+
+#if STEP == 5
+! Reading m7d.mod back must resolve the renamed type spelling 'hue' that was
+! written to the module file, not the module-original name 'color'.
+subroutine use_renamed
+ use m7d, only: v
+end subroutine
+#endif
diff --git a/flang/test/Semantics/enumeration-type-mod.f90 b/flang/test/Semantics/enumeration-type-mod.f90
index a5f3572a3a4dc..7773a185e888d 100644
--- a/flang/test/Semantics/enumeration-type-mod.f90
+++ b/flang/test/Semantics/enumeration-type-mod.f90
@@ -106,6 +106,13 @@ module m6
! 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.
+! 'private :: color' is an access-STATEMENT on the type name; it does NOT set
+! the enumerator default (only an access-SPEC on the ENUMERATION TYPE statement
+! does, per F2023 7.6.2p2), so red/green/blue stay PUBLIC. The module file
+! writes the type's PRIVATE attribute inline as 'enumeration type,private', an
+! access-spec that the reader would treat as a PRIVATE enumerator default;
+! explicit 'public::' lines for each enumerator are therefore required so the
+! module reads back with the enumerators still PUBLIC.
module m7
private :: color
enumeration type :: color
@@ -118,6 +125,9 @@ module m7
!enumeration type,private::color
!enumerator::red,green,blue
!end enumeration type
+!public::red
+!public::green
+!public::blue
!end
! Explicit PUBLIC accessibility statement overriding one enumerator of a
>From 7f4567735f85acc2ed804cc97a53f619209e2267 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Thu, 6 Aug 2026 16:58:34 -0500
Subject: [PATCH 13/14] Added an AI identified missing test case, int() with a
bad kind.
---
flang/test/Semantics/enumeration-type-intrinsics.f90 | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/flang/test/Semantics/enumeration-type-intrinsics.f90 b/flang/test/Semantics/enumeration-type-intrinsics.f90
index 163a24a1bff13..1335090b6c75d 100644
--- a/flang/test/Semantics/enumeration-type-intrinsics.f90
+++ b/flang/test/Semantics/enumeration-type-intrinsics.f90
@@ -85,6 +85,14 @@ subroutine test_int()
j = int(green, 8)
end subroutine
+subroutine test_int_bad_kind()
+ use enum_intrinsics_mod
+ integer :: i
+ ! INT of an enumeration argument with an unsupported KIND value is rejected.
+ !CHECK: error: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
+ i = int(red, kind=3)
+end subroutine
+
subroutine test_int_parameter()
use enum_intrinsics_mod
! INT(x) in parameter (constant) context
>From 9f7bc85f0a21eda246817b1a108f4503b46b2804 Mon Sep 17 00:00:00 2001
From: Kevin Wyatt <kwyatt at hpe.com>
Date: Tue, 1 Sep 2026 13:50:50 -0500
Subject: [PATCH 14/14] Enhanced the check for enumerations in namelist objects
at declaration time and remove the I/O time check. This captures the C8109
restrictions completely. Added test cases from reviewer to demonstrate the
fix.
---
flang/docs/Extensions.md | 9 +++
flang/lib/Semantics/check-io.cpp | 34 +++-------
flang/lib/Semantics/check-namelist.cpp | 21 +++++-
.../enumeration-type-io-pdt-order.f90 | 8 +--
flang/test/Semantics/enumeration-type-io.f90 | 65 +++++++++++++++++--
5 files changed, 101 insertions(+), 36 deletions(-)
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 0b16348074cfc..3973841d061b9 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -695,6 +695,15 @@ end program
assignment statements as no-ops, and the rest crash during compilation.)
The compiler flags this case as an error.
+* F2023 12.6.3 restricts enumeration types in I/O only for list-directed
+ transfers (prohibited) and formatted transfers (which must use an `I`, `B`,
+ `O`, or `Z` edit descriptor); it places no restriction on unformatted I/O.
+ Flang is currently stricter than the standard here and rejects an
+ enumeration type -- whether a bare item or reached as a component of a
+ derived type not processed by defined I/O -- in unformatted I/O with an
+ error. This can be a temporary flang limitation while enumeration-type
+ support is incomplete, not a standard requirement.
+
## Standard features that might as well not be
* Flang supports designators with constant expressions, properly
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index 12ff05de5def6..bc9181592aeb5 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -1377,24 +1377,24 @@ parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
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);
+ "Enumeration type is not supported in unformatted I/O"_err_en_US);
}
return nullptr; // formatted I/O is allowed
}
}
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.
+ // Enumeration type is not supported in unformatted I/O. This is a flang
+ // limitation, not a standard requirement: F2023 12.6.3 restricts
+ // enumeration types only in list-directed and formatted I/O, and treats an
+ // unformatted derived-type item as a single value. 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.
if ((which == common::DefinedIo::ReadUnformatted ||
which == common::DefinedIo::WriteUnformatted) &&
!HasDefinedIo(which, derived, &scope)) {
if (FindEnumerationTypeComponent(which, derived, scope)) {
return &context_.Say(where,
- "Enumeration type may not be used in unformatted I/O"_err_en_US);
+ "Enumeration type is not supported in unformatted I/O"_err_en_US);
}
}
if (const Symbol *
@@ -1461,24 +1461,6 @@ 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()};
- // A bare enumeration-type namelist group object is rejected earlier at
- // declaration time (F2023 C8109) in NamelistChecker.
- // 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 component '%s' of enumeration type"_err_en_US,
- object.name(), bad->name());
- }
- }
- }
if (auto *msg{CheckForBadIoType(object, which, namelistLocation)}) {
evaluate::AttachDeclaration(*msg, namelist);
} else if (which == common::DefinedIo::ReadFormatted) {
diff --git a/flang/lib/Semantics/check-namelist.cpp b/flang/lib/Semantics/check-namelist.cpp
index 1b1148189d38d..6060ac31d8615 100644
--- a/flang/lib/Semantics/check-namelist.cpp
+++ b/flang/lib/Semantics/check-namelist.cpp
@@ -8,6 +8,7 @@
#include "check-namelist.h"
#include "flang/Semantics/tools.h"
+#include <algorithm>
namespace Fortran::semantics {
@@ -38,10 +39,28 @@ void NamelistChecker::Leave(const parser::NamelistStmt &nmlStmt) {
}
if (const DeclTypeSpec *type{nmlObjSymbol->GetType()}) {
if (const DerivedTypeSpec *derived{type->AsDerived()}) {
- if (IsEnumerationType(*derived)) { // F2023 C8109
+ // F2023 C8109: a namelist-group-object shall not be of
+ // enumeration type, nor have a direct component of enumeration
+ // type. This is a declaration-time constraint, enforced
+ // regardless of whether the namelist is used in I/O.
+ if (IsEnumerationType(*derived)) {
context_.Say(nmlObjName.source,
"Enumeration type '%s' may not be a namelist group object"_err_en_US,
derived->name());
+ } else {
+ DirectComponentIterator directs{*derived};
+ auto bad{std::find_if(
+ directs.begin(), directs.end(), [](const Symbol &comp) {
+ const DeclTypeSpec *compType{comp.GetType()};
+ const DerivedTypeSpec *compDerived{
+ compType ? compType->AsDerived() : nullptr};
+ return compDerived && IsEnumerationType(*compDerived);
+ })};
+ if (bad != directs.end()) {
+ context_.Say(nmlObjName.source,
+ "Namelist group object '%s' may not have a direct component '%s' of enumeration type"_err_en_US,
+ nmlObjSymbol->name(), bad.BuildResultDesignatorName());
+ }
}
}
}
diff --git a/flang/test/Semantics/enumeration-type-io-pdt-order.f90 b/flang/test/Semantics/enumeration-type-io-pdt-order.f90
index 6eb87e83eca38..36bbf6802d335 100644
--- a/flang/test/Semantics/enumeration-type-io-pdt-order.f90
+++ b/flang/test/Semantics/enumeration-type-io-pdt-order.f90
@@ -84,7 +84,7 @@ subroutine test_shielded(u)
subroutine test_unshielded(u)
integer, intent(in) :: u
type(branch(2)) :: y
- !ERROR: Enumeration type may not be used in unformatted I/O
+ !ERROR: Enumeration type is not supported in unformatted I/O
write(u) y
end subroutine
@@ -92,7 +92,7 @@ subroutine test_unshielded(u)
subroutine test_order_bug(u)
integer, intent(in) :: u
type(container) :: z
- !ERROR: Enumeration type may not be used in unformatted I/O
+ !ERROR: Enumeration type is not supported in unformatted I/O
write(u) z
end subroutine
@@ -101,7 +101,7 @@ subroutine test_order_bug(u)
subroutine test_order_bug_rev(u)
integer, intent(in) :: u
type(container_rev) :: z
- !ERROR: Enumeration type may not be used in unformatted I/O
+ !ERROR: Enumeration type is not supported in unformatted I/O
write(u) z
end subroutine
@@ -111,7 +111,7 @@ subroutine test_order_bug_rev(u)
subroutine test_order_bug_rev_decl(u)
integer, intent(in) :: u
type(container_rev_decl) :: z
- !ERROR: Enumeration type may not be used in unformatted I/O
+ !ERROR: Enumeration type is not supported in unformatted I/O
write(u) z
end subroutine
end module
diff --git a/flang/test/Semantics/enumeration-type-io.f90 b/flang/test/Semantics/enumeration-type-io.f90
index 070243c88743a..6196e5e8e814e 100644
--- a/flang/test/Semantics/enumeration-type-io.f90
+++ b/flang/test/Semantics/enumeration-type-io.f90
@@ -56,9 +56,9 @@ subroutine test_unformatted()
use enum_io_mod
type(color) :: c
c = red
- !ERROR: Enumeration type may not be used in unformatted I/O
+ !ERROR: Enumeration type is not supported in unformatted I/O
write(10) c
- !ERROR: Enumeration type may not be used in unformatted I/O
+ !ERROR: Enumeration type is not supported in unformatted I/O
read(10) c
end subroutine
@@ -72,9 +72,9 @@ subroutine test_component_io()
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
+ !ERROR: Enumeration type is not supported in unformatted I/O
write(10) d
- !ERROR: Enumeration type may not be used in unformatted I/O
+ !ERROR: Enumeration type is not supported in unformatted I/O
read(10) d
end subroutine
@@ -126,11 +126,66 @@ subroutine test_namelist_enum_component()
integer :: n
end type
type(has_color) :: d
+ ! F2023 C8109: caught at the namelist declaration, regardless of I/O.
+ !ERROR: Namelist group object 'd' may not have a direct component '%clr' of enumeration type
namelist /nml2/ d
- !ERROR: Namelist group object 'd' has a component 'clr' of enumeration type
write(*, nml=nml2)
end subroutine
+subroutine test_namelist_enum_component_no_io()
+ ! F2023 C8109 is a declaration-time constraint: it must be diagnosed even
+ ! when the namelist is never used in an I/O statement.
+ use enum_io_mod
+ type :: has_color
+ type(color) :: clr
+ end type
+ type(has_color) :: d
+ !ERROR: Namelist group object 'd' may not have a direct component '%clr' of enumeration type
+ namelist /nml2b/ d
+end subroutine
+
+subroutine test_namelist_enum_buried()
+ ! A direct component reached through non-pointer/non-allocatable derived
+ ! components is still a direct component (F2023 C8109).
+ use enum_io_mod
+ type :: inner
+ type(color) :: clr
+ end type
+ type :: outer
+ type(inner) :: i
+ end type
+ type(outer) :: o
+ !ERROR: Namelist group object 'o' may not have a direct component '%i%clr' of enumeration type
+ namelist /nml2c/ o
+end subroutine
+
+subroutine test_namelist_enum_behind_pointer()
+ ! An enumeration type reached only through a POINTER (or allocatable)
+ ! component is NOT a direct component, so C8109 does not apply and this is
+ ! accepted (the pointer breaks the direct-component chain).
+ use enum_io_mod
+ type :: inner
+ type(color) :: clr
+ end type
+ type :: outer
+ type(inner), pointer :: i
+ end type
+ type(outer) :: o
+ namelist /nml2d/ o
+end subroutine
+
+subroutine test_namelist_enum_defined_io_not_shielded()
+ ! Defined I/O on an intermediate NON-pointer component does not shield its
+ ! enumeration subcomponent from C8109: the enum is still a direct component.
+ ! (Contrast with list-directed I/O, where 12.6.3 treats a defined-I/O
+ ! component as a single value -- see test_shielded_component.)
+ use enum_io_mod
+ type(has_color_io) :: d
+ !ERROR: Namelist group object 'd' may not have a direct component '%c' of enumeration type
+ namelist /nml2e/ d
+ write(*, nml=nml2e)
+end subroutine
+
subroutine test_namelist_valid()
integer :: n
namelist /nml3/ n
More information about the flang-commits
mailing list