[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

Author: compinder

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);

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

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