OSchip
/
llvm-project
mirror of https://github.com/THU-DSP-LAB/llvm-project.git
13
0
Fork 6
Code Issues Packages Projects Releases Wiki Activity

[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
This commit is contained in:
Peter Klausler 2022-03-31 15:59:27 -07:00
parent 3a54bbb0f2
commit a73f7ababb
2 changed files with 44 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
flang/lib/Semantics/check-case.cpp
View File

@ -79,15 +79,31 @@ private:
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,

21
flang/test/Semantics/case01.f90
View File

@ -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