Index: flang/lib/Semantics/check-select-type.cpp =================================================================== --- flang/lib/Semantics/check-select-type.cpp +++ flang/lib/Semantics/check-select-type.cpp @@ -39,7 +39,7 @@ if (std::holds_alternative(guard.u)) { typeCases_.emplace_back(stmt, std::nullopt); } else if (std::optional type{GetGuardType(guard)}) { - if (PassesChecksOnGuard(guard, *type)) { + if (PassesChecksOnGuard(stmt, *type)) { typeCases_.emplace_back(stmt, *type); } else { hasErrors_ = true; @@ -71,35 +71,46 @@ guard.u); } - bool PassesChecksOnGuard(const parser::TypeGuardStmt::Guard &guard, + bool PassesChecksOnGuard(const parser::Statement &stmt, const evaluate::DynamicType &guardDynamicType) { + const parser::TypeGuardStmt &typeGuardStmt{stmt.statement}; + const auto &guard{std::get(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}; + bool typeSpecRetVal{false}; + CHECK(spec); + CHECK(spec->AsIntrinsic() || spec->AsDerived()); + 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); Index: flang/test/Semantics/selecttype01.f90 =================================================================== --- flang/test/Semantics/selecttype01.f90 +++ flang/test/Semantics/selecttype01.f90 @@ -119,6 +119,7 @@ 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 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 @@ 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 @@ !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 Index: flang/test/Semantics/symbol11.f90 =================================================================== --- flang/test/Semantics/symbol11.f90 +++ flang/test/Semantics/symbol11.f90 @@ -71,10 +71,12 @@ !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