[flang-commits] [PATCH] D123708: [flang] Error handling for out-of-range CASE values

[Peter Klausler via Phabricator via flang-commits]

This revision was automatically updated to reflect the committed changes.
Closed by commit rGa73f7ababb4b: [flang] Error handling for out-of-range CASE values (authored by klausler).

Repository:
  rG LLVM Github Monorepo

CHANGES SINCE LAST ACTION
  https://reviews.llvm.org/D123708/new/

https://reviews.llvm.org/D123708

Files:
  flang/lib/Semantics/check-case.cpp
  flang/test/Semantics/case01.f90


Index: flang/test/Semantics/case01.f90
===================================================================
--- flang/test/Semantics/case01.f90
+++ flang/test/Semantics/case01.f90
@@ -177,3 +177,24 @@
     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
Index: flang/lib/Semantics/check-case.cpp
===================================================================
--- flang/lib/Semantics/check-case.cpp
+++ flang/lib/Semantics/check-case.cpp
@@ -79,15 +79,31 @@
       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,


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D123708.422708.patch
Type: text/x-patch
Size: 3042 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20220414/2b90e644/attachment.bin>