diff --git a/flang/lib/Semantics/check-case.cpp b/flang/lib/Semantics/check-case.cpp --- a/flang/lib/Semantics/check-case.cpp +++ b/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(*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(*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 --- a/flang/test/Semantics/case01.f90 +++ b/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