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

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-04-13T18:35:00-07:00
New Revision: a73f7ababb4b2de65c6e2cdd832fc1f8c21207cf

URL: https://github.com/llvm/llvm-project/commit/a73f7ababb4b2de65c6e2cdd832fc1f8c21207cf
DIFF: https://github.com/llvm/llvm-project/commit/a73f7ababb4b2de65c6e2cdd832fc1f8c21207cf.diff

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

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

Differential Revision: https://reviews.llvm.org/D123708

Added: 
    

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

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-case.cpp b/flang/lib/Semantics/check-case.cpp
index 3c52de8306b69..262a68596ae7d 100644
--- a/flang/lib/Semantics/check-case.cpp
+++ b/flang/lib/Semantics/check-case.cpp
@@ -79,15 +79,31 @@ template <typename T> class CaseValues {
       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,

diff  --git a/flang/test/Semantics/case01.f90 b/flang/test/Semantics/case01.f90
index 42eb07d20982f..020f25119b708 100644
--- a/flang/test/Semantics/case01.f90
+++ b/flang/test/Semantics/case01.f90
@@ -177,3 +177,24 @@ program test_overlap
     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