[flang-commits] [flang] 594dec2 - [FLANG] Fix issues in SELECT TYPE construct when intrinsic type specification is specified in TYPE GUARD statement.
via flang-commits
flang-commits at lists.llvm.org
Sun Aug 2 20:57:32 PDT 2020
Author: compinder
Date: 2020-08-03T09:24:42+05:30
New Revision: 594dec2884a4814dc97ebdfa7c83ef15bdfb379e
URL: https://github.com/llvm/llvm-project/commit/594dec2884a4814dc97ebdfa7c83ef15bdfb379e
DIFF: https://github.com/llvm/llvm-project/commit/594dec2884a4814dc97ebdfa7c83ef15bdfb379e.diff
LOG: [FLANG] Fix issues in SELECT TYPE construct when intrinsic type specification is specified in TYPE GUARD statement.
Fix of PR46789 and PR46830.
Differential Revision: https://reviews.llvm.org/D84290
Added:
Modified:
flang/lib/Semantics/check-select-type.cpp
flang/test/Semantics/selecttype01.f90
flang/test/Semantics/symbol11.f90
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-select-type.cpp b/flang/lib/Semantics/check-select-type.cpp
index 5b430440dffb..ce675fa2f1db 100644
--- a/flang/lib/Semantics/check-select-type.cpp
+++ b/flang/lib/Semantics/check-select-type.cpp
@@ -39,7 +39,7 @@ class TypeCaseValues {
if (std::holds_alternative<parser::Default>(guard.u)) {
typeCases_.emplace_back(stmt, std::nullopt);
} else if (std::optional<evaluate::DynamicType> type{GetGuardType(guard)}) {
- if (PassesChecksOnGuard(guard, *type)) {
+ if (PassesChecksOnGuard(stmt, *type)) {
typeCases_.emplace_back(stmt, *type);
} else {
hasErrors_ = true;
@@ -71,35 +71,46 @@ class TypeCaseValues {
guard.u);
}
- bool PassesChecksOnGuard(const parser::TypeGuardStmt::Guard &guard,
+ bool PassesChecksOnGuard(const parser::Statement<parser::TypeGuardStmt> &stmt,
const evaluate::DynamicType &guardDynamicType) {
+ const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
+ const auto &guard{std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t)};
return std::visit(
common::visitors{
[](const parser::Default &) { return true; },
[&](const parser::TypeSpec &typeSpec) {
- if (const DeclTypeSpec * spec{typeSpec.declTypeSpec}) {
+ const DeclTypeSpec *spec{typeSpec.declTypeSpec};
+ CHECK(spec);
+ CHECK(spec->AsIntrinsic() || spec->AsDerived());
+ bool typeSpecRetVal{false};
+ if (spec->AsIntrinsic()) {
+ typeSpecRetVal = true;
+ if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162
+ context_.Say(stmt.source,
+ "If selector is not unlimited polymorphic, "
+ "an intrinsic type specification must not be specified "
+ "in the type guard statement"_err_en_US);
+ typeSpecRetVal = false;
+ }
if (spec->category() == DeclTypeSpec::Character &&
!guardDynamicType.IsAssumedLengthCharacter()) { // C1160
context_.Say(parser::FindSourceLocation(typeSpec),
"The type specification statement must have "
"LEN type parameter as assumed"_err_en_US);
- return false;
+ typeSpecRetVal = false;
}
- if (const DerivedTypeSpec * derived{spec->AsDerived()}) {
- return PassesDerivedTypeChecks(
- *derived, parser::FindSourceLocation(typeSpec));
- }
- return false;
+ } else {
+ const DerivedTypeSpec *derived{spec->AsDerived()};
+ typeSpecRetVal = PassesDerivedTypeChecks(
+ *derived, parser::FindSourceLocation(typeSpec));
}
- return false;
+ return typeSpecRetVal;
},
[&](const parser::DerivedTypeSpec &x) {
- if (const semantics::DerivedTypeSpec *
- derived{x.derivedTypeSpec}) {
- return PassesDerivedTypeChecks(
- *derived, parser::FindSourceLocation(x));
- }
- return false;
+ CHECK(x.derivedTypeSpec);
+ const semantics::DerivedTypeSpec *derived{x.derivedTypeSpec};
+ return PassesDerivedTypeChecks(
+ *derived, parser::FindSourceLocation(x));
},
},
guard.u);
diff --git a/flang/test/Semantics/selecttype01.f90 b/flang/test/Semantics/selecttype01.f90
index fe9838ae2760..c726c232e18d 100644
--- a/flang/test/Semantics/selecttype01.f90
+++ b/flang/test/Semantics/selecttype01.f90
@@ -119,6 +119,7 @@ subroutine CheckC1159b
integer :: x
!ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
select type (a => x)
+ !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is (integer)
print *,'integer ',a
end select
@@ -127,6 +128,7 @@ subroutine CheckC1159b
subroutine CheckC1159c
!ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
select type (a => x)
+ !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is (integer)
print *,'integer ',a
end select
@@ -164,6 +166,16 @@ subroutine CheckC1162
type is (extsquare)
!Handle same types
type is (rectangle)
+ !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+ type is(integer)
+ !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+ type is(real)
+ !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+ type is(logical)
+ !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+ type is(character(len=*))
+ !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+ type is(complex)
end select
!Unlimited polymorphic objects are allowed.
@@ -187,6 +199,12 @@ subroutine CheckC1163
!ERROR: Type specification 'square' conflicts with previous type specification
class is (square)
end select
+ select type (unlim_polymorphic)
+ type is (INTEGER(4))
+ type is (shape)
+ !ERROR: Type specification 'INTEGER(4)' conflicts with previous type specification
+ type is (INTEGER(4))
+ end select
end
subroutine CheckC1164
diff --git a/flang/test/Semantics/symbol11.f90 b/flang/test/Semantics/symbol11.f90
index e6ae26c740e5..3d2be676967f 100644
--- a/flang/test/Semantics/symbol11.f90
+++ b/flang/test/Semantics/symbol11.f90
@@ -71,10 +71,12 @@ subroutine s3
!DEF: /s3/Block1/y TARGET AssocEntity TYPE(t2)
!REF: /s3/t2/a2
i = y%a2
- type is (integer(kind=8))
+ !REF: /s3/t1
+ type is (t1)
!REF: /s3/i
- !DEF: /s3/Block2/y TARGET AssocEntity INTEGER(8)
- i = y
+ !DEF: /s3/Block2/y TARGET AssocEntity TYPE(t1)
+ !REF: /s3/t1/a1
+ i = y%a1
class default
!DEF: /s3/Block3/y TARGET AssocEntity CLASS(t1)
print *, y
More information about the flang-commits
mailing list