[flang] Error handling for out-of-range CASE values

[klausler]

Summary

Catch and nicely describe errors in CASE range values
that are out of range for the type of the SELECT CASE.

flang/lib/Semantics/check-case.cpp

private:
   std::optional<Value> GetValue(const parser::CaseValue &caseValue) {
     const parser::Expr &expr{caseValue.thing.thing.value()};
     auto *x{expr.typedExpr.get()};
     if (x && x->v) { // C1147
       auto type{x->v->GetType()};
       if (type && type->category() == caseExprType_.category() &&
           (type->category() != TypeCategory::Character ||
               type->kind() == caseExprType_.kind())) {
-        x->v = evaluate::Fold(context_.foldingContext(),
-            evaluate::ConvertToType(T::GetType(), std::move(*x->v)));
-        if (x->v) {
-          if (auto value{evaluate::GetScalarConstantValue<T>(*x->v)}) {
-            return *value;
+        parser::Messages buffer; // discarded folding messages
+        parser::ContextualMessages foldingMessages{expr.source, &buffer};
+        evaluate::FoldingContext foldingContext{
+            context_.foldingContext(), foldingMessages};
+        auto folded{evaluate::Fold(foldingContext, SomeExpr{*x->v})};
+        if (auto converted{evaluate::Fold(foldingContext,
+                evaluate::ConvertToType(T::GetType(), SomeExpr{folded}))}) {
+          if (auto value{evaluate::GetScalarConstantValue<T>(*converted)}) {
+            auto back{evaluate::Fold(foldingContext,
+                evaluate::ConvertToType(*type, SomeExpr{*converted}))};
+            if (back == folded) {
+              x->v = converted;
+              return value;
+            } else {
+              context_.Say(expr.source,
+                  "CASE value (%s) overflows type (%s) of SELECT CASE expression"_err_en_US,
+                  folded.AsFortran(), caseExprType_.AsFortran());
+              hasErrors_ = true;
+              return std::nullopt;
+            }
           }
         }
-        context_.Say(
-            expr.source, "CASE value must be a constant scalar"_err_en_US);
+        context_.Say(expr.source,
+            "CASE value (%s) must be a constant scalar"_err_en_US,
+            x->v->AsFortran());
       } else {
         std::string typeStr{type ? type->AsFortran() : "typeless"s};
         context_.Say(expr.source,
             "CASE value has type '%s' which is not compatible with the SELECT CASE expression's type '%s'"_err_en_US,
             typeStr, caseExprType_.AsFortran());
       }
       hasErrors_ = true;
     }

flang/test/Semantics/case01.f90

select case(i)
     case(:-1)
   end select
   select case(i)
     case(-1:)
     !ERROR: CASE (:0_4) conflicts with previous cases
     case(:0)
   end select
 end
+
+program test_overflow
+  integer :: j
+  select case(1_1)
+  case (127)
+  !ERROR: CASE value (128_4) overflows type (INTEGER(1)) of SELECT CASE expression
+  case (128)
+  !ERROR: CASE value (129_4) overflows type (INTEGER(1)) of SELECT CASE expression
+  !ERROR: CASE value (130_4) overflows type (INTEGER(1)) of SELECT CASE expression
+  case (129:130)
+  !ERROR: CASE value (-130_4) overflows type (INTEGER(1)) of SELECT CASE expression
+  !ERROR: CASE value (-129_4) overflows type (INTEGER(1)) of SELECT CASE expression
+  case (-130:-129)
+  case (-128)
+  !ERROR: Must be a scalar value, but is a rank-1 array
+  case ([1, 2])
+  !ERROR: Must be a constant value
+  case (j)
+  case default
+  end select
+end