Adding tests and intrinsic piece required for relationals.users/kwyatt-ext/enum-sem-2

4 files changed, 230 insertions, 4 deletions

diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp
index 9f2bb94a9213..d5dcf272d53d 100644
--- a/flang/lib/Evaluate/fold-integer.cpp
+++ b/flang/lib/Evaluate/fold-integer.cpp
@@ -761,6 +761,34 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
   } else if (name == "int" || name == "int2" || name == "int8" ||
       name == "uint") {
     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()) {
+              if (const auto *scope{derived->GetScope()}) {
+                auto ordIter{
+                    scope->find(semantics::SourceName{"__ordinal", 9})};
+                if (ordIter != scope->end()) {
+                  const semantics::Symbol &ordSym{*ordIter->second};
+                  if (auto *constant{
+                          UnwrapConstantValue<SomeDerived>(*derivedExpr)}) {
+                    if (auto sc{constant->GetScalarValue()}) {
+                      if (auto ordExpr{sc->Find(ordSym)}) {
+                        if (auto ordVal{ToInt64(*ordExpr)}) {
+                          return Expr<T>{Constant<T>{Scalar<T>{*ordVal}}};
+                        }
+                      }
+                    }
+                  }
+                }
+              }
+              // Non-constant enumeration argument — leave unfolded
+              return Expr<T>{std::move(funcRef)};
+            }
+          }
+        }
+      }
       return common::visit(
           [&](auto &&x) -> Expr<T> {
             using From = std::decay_t<decltype(x)>;
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 7e4a5d34b418..176e9d78714f 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -5904,10 +5904,7 @@ void DeclarationVisitor::Post(const parser::EnumDef &) {
 // and popped in Post(EndEnumerationTypeStmt).
 bool DeclarationVisitor::Pre(const parser::EnumerationTypeDef &x) {
   BeginAttrs();
-  // TODO: Remove this and set true when ENUMERATION TYPEs are implemented.
-  Say(std::get<parser::Statement<parser::EnumerationTypeStmt>>(x.t).source,
-      "F2023 ENUMERATION TYPEs are not yet implemented"_err_en_US);
-  return false;
+  return true;
 }
 
 // F2023 R767 EnumerationTypeStmt — create the enumeration type symbol
diff --git a/flang/test/Semantics/enumeration-type-declarations.f90 b/flang/test/Semantics/enumeration-type-declarations.f90
new file mode 100644
index 000000000000..de66ae888268
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-declarations.f90
@@ -0,0 +1,84 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test declaration, constructor, and expression semantics for enumeration types
+
+! C7114: access specifier only allowed in module
+subroutine test_access_specifier_outside_module()
+  !ERROR: PRIVATE attribute may only appear in the specification part of a module
+  !ERROR: Access specifier on ENUMERATION TYPE may only appear in the specification part of a module
+  enumeration type, private :: color
+    enumerator :: red, green, blue
+  end enumeration type
+end subroutine
+
+! Valid: basic declarations and usage
+subroutine test_basic_declarations()
+  enumeration type :: color
+    enumerator :: red, green, blue
+  end enumeration type
+
+  type(color) :: c1, c2
+  logical :: l
+
+  ! Valid: assign an enumerator
+  c1 = red
+  c2 = blue
+
+  ! Valid: comparison produces logical
+  l = (c1 == c2)
+  l = (c1 /= red)
+end subroutine
+
+! Valid: constructor syntax — color(n) where n is a positive integer <= count
+subroutine test_constructor_valid()
+  enumeration type :: color
+    enumerator :: red, green, blue
+  end enumeration type
+
+  type(color) :: c
+
+  ! Valid: integer constructor in range
+  c = color(1)
+  c = color(2)
+  c = color(3)
+end subroutine
+
+! Constructor errors
+subroutine test_constructor_errors()
+  enumeration type :: color
+    enumerator :: red, green, blue
+  end enumeration type
+
+  type(color) :: c
+
+  ! ERROR: Enumeration constructor for 'color' requires exactly one argument
+  c = color()
+
+  ! ERROR: Enumeration constructor for 'color' requires exactly one argument
+  c = color(1, 2)
+
+  ! ERROR: Enumeration constructor for 'color' may not have a keyword argument
+  c = color(val=1)
+
+  ! ERROR: Enumeration constructor argument must be INTEGER, but is REAL(4)
+  c = color(1.0)
+
+  ! ERROR: Enumeration constructor value (0) for 'color' must be positive and less than or equal to the number of enumerators (3)
+  c = color(0)
+
+  ! ERROR: Enumeration constructor value (4) for 'color' must be positive and less than or equal to the number of enumerators (3)
+  c = color(4)
+end subroutine
+
+! Component reference on enumeration type is not allowed
+subroutine test_component_reference()
+  enumeration type :: color
+    enumerator :: red, green, blue
+  end enumeration type
+
+  type(color) :: c
+  integer :: i
+
+  c = red
+  ! ERROR: Component reference is not allowed for enumeration type 'color'
+  i = c%__ordinal
+end subroutine
diff --git a/flang/test/Semantics/enumeration-type-relational.f90 b/flang/test/Semantics/enumeration-type-relational.f90
new file mode 100644
index 000000000000..507635c6bbdd
--- /dev/null
+++ b/flang/test/Semantics/enumeration-type-relational.f90
@@ -0,0 +1,117 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test relational operators and SELECT CASE for enumeration types (F2023 7.6.2)
+
+module enum_mod
+  enumeration type :: color
+    enumerator :: red, green, blue
+  end enumeration type
+
+  enumeration type :: direction
+    enumerator :: north, south, east, west
+  end enumeration type
+
+  enumeration type :: w_value
+    enumerator :: w1, w2, w3, w4, w5
+  end enumeration type
+end module
+
+subroutine test_relational_same_type()
+  use enum_mod
+  logical :: result
+
+  ! Valid: all six relational operators between same-type enumerators
+  result = red == red
+  result = red /= green
+  result = red < green
+  result = green > red
+  result = red <= red
+  result = blue >= green
+end subroutine
+
+subroutine test_relational_cross_type()
+  use enum_mod
+
+  ! ERROR: Operands of .EQ. must have comparable types; have TYPE(color) and TYPE(direction)
+  if (red == north) stop 1
+
+  ! ERROR: Operands of .LT. must have comparable types; have TYPE(color) and TYPE(direction)
+  if (red < north) stop 2
+end subroutine
+
+subroutine test_relational_enum_vs_integer()
+  use enum_mod
+
+  ! ERROR: Operands of .EQ. must have comparable types; have TYPE(color) and INTEGER(4)
+  if (red == 1) stop 1
+
+  ! ERROR: Operands of .EQ. must have comparable types; have INTEGER(4) and TYPE(color)
+  if (1 == red) stop 2
+end subroutine
+
+subroutine test_select_case_basic(w)
+  use enum_mod
+  type(w_value), intent(in) :: w
+
+  ! Valid: SELECT CASE with enumerator names as case values
+  select case (w)
+    case (w1)
+      print *, 'w1'
+    case (w2)
+      print *, 'w2'
+    case default
+      print *, 'other'
+  end select
+end subroutine
+
+subroutine test_select_case_range(w)
+  use enum_mod
+  type(w_value), intent(in) :: w
+
+  ! Valid: SELECT CASE with ranges
+  select case (w)
+    case (w1)
+      print *, 'w1'
+    case (w2:w4)
+      print *, 'w2 to w4'
+    case (w5)
+      print *, 'w5'
+  end select
+end subroutine
+
+subroutine test_select_case_wrong_enum(w)
+  use enum_mod
+  type(w_value), intent(in) :: w
+
+  select case (w)
+    !ERROR: CASE value has type 'color' which is not compatible with the SELECT CASE expression's type 'ENUMERATION TYPE :: w_value'
+    case (red)
+      print *, 'wrong'
+    case default
+      print *, 'ok'
+  end select
+end subroutine
+
+subroutine test_select_case_integer_case(w)
+  use enum_mod
+  type(w_value), intent(in) :: w
+
+  select case (w)
+    !ERROR: CASE value has type 'INTEGER(4)' which is not compatible with the SELECT CASE expression's type 'ENUMERATION TYPE :: w_value'
+    case (1)
+      print *, 'wrong'
+    case default
+      print *, 'ok'
+  end select
+end subroutine
+
+subroutine test_select_case_non_enum_derived()
+  type :: my_type
+    integer :: val
+  end type
+  type(my_type) :: x = my_type(1)
+
+  !ERROR: SELECT CASE expression must be integer, logical, character, or enumeration type
+  select case (x)
+    case default
+  end select
+end subroutine