mirrors/llvm-project
0
0
Fork 0
mirror of https://github.com/llvm/llvm-project.git synced 2025-04-26 01:56:06 +00:00
Code Issues Projects Releases Wiki Activity

[flang] Check that a SELECT TYPE selector is not a procedure

Browse Source 
A SELECT TYPE statement's selector must be a variable or expression,
not a procedure; specifically, a function with a polymorphic result
is unacceptable.

Differential Revision: https://reviews.llvm.org/D145742
This commit is contained in:
Peter Klausler 2023-03-03 10:37:13 -08:00
parent 326c13531a
commit 3c10eb4942
2 changed files with 21 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
flang/lib/Semantics/check-select-type.cpp
View File

@ -254,16 +254,16 @@ void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) {
std::get<parser::Statement<parser::SelectTypeStmt>>(construct.t)};
const auto &selectType{selectTypeStmt.statement};
const auto &unResolvedSel{std::get<parser::Selector>(selectType.t)};
const auto *selector{GetExprFromSelector(unResolvedSel)};
if (!selector) {
return; // expression semantics failed on Selector
}
if (auto exprType{selector->GetType()}) {
const auto &typeCaseList{
std::get<std::list<parser::SelectTypeConstruct::TypeCase>>(
construct.t)};
TypeCaseValues{context_, *exprType}.Check(typeCaseList);
if (const auto *selector{GetExprFromSelector(unResolvedSel)}) {
if (IsProcedure(*selector)) {
context_.Say(
selectTypeStmt.source, "Selector may not be a procedure"_err_en_US);
} else if (auto exprType{selector->GetType()}) {
const auto &typeCaseList{
std::get<std::list<parser::SelectTypeConstruct::TypeCase>>(
construct.t)};
TypeCaseValues{context_, *exprType}.Check(typeCaseList);
}
}
}

11
flang/test/Semantics/selecttype01.f90
View File

@ -277,3 +277,14 @@ subroutine WorkingPolymorphism
print *, "default"
end select
end
subroutine CheckNotProcedure
use m1
!ERROR: Selector may not be a procedure
select type (x=>f)
end select
contains
function f() result(res)
class(shape), allocatable :: res
end
end