[Flang] Semantics for SELECT TYPE

[klausler]

flang/lib/Semantics/check-select-type.cpp

42

success is not necessary.

64

Just return evaluate::DynamicType::From(typeSpec.declTypeSpec); for the whole function body.

74–84

Your code code has no comments anywhere to explain what you're doing, and they would be helpful here. It looks like you're using move semantics to suck the contents out of the derived type spec and transfer them to a new derived type spec in the scope of the original derived type spec. This seems likely to wreck the representation of the original type, and I can't tell why you want to do it.

85

Just return; the if is not necessary.

129

If derived can't be null, use a reference. If it can be null, check it.

140

Is struct TypeCase nested in class TypeCaseValues?

179

You're just coping a single string to a stream to get the same string back.

195

Should be a function, not a function object; it has no state, and is only called directly.

196

Can be static rather than const, I think.

209

These six lines could be a single return statement.

218

The "but" here isn't reassuring, since the cases where compilation time matters are non-error cases.

241

I don't think that this closing brace is ending the namespace, but rather a class.

flang/lib/Semantics/resolve-names.cpp

5164

s/statements/statement/

s/ value//

5171

This error message is unclear. Explain why the expression cannot be used with an associate-name.

[sameeranjoshi]

Addressed comments by @klausler.

[sameeranjoshi]

This comment was removed by sameeranjoshi.

[sameeranjoshi]

flang/lib/Semantics/check-select-type.cpp

74–84

Ok, so wanted to extract the Evaluate::DynamicType from the parser::DerivedTypeSpec.
The only way I could figure out was,
step1:
convert from semantics::DerivedTypeSpec to semantics::DeclTypeSpec
step2:
further I knew that evaluate::DynamicType::From() converts semantics::DeclTypeSpec to Evaluate::DynamicType

Is there a better way you can suggest?

120

Given that derived is checked for null value, I will go with reference.

140

Yes, the similar way select-case has struct Case inside class CaseValues.

179

Why is it used in select case?
Does AsFortran in evaluate::Constant template it do something more ?

flang/lib/Semantics/resolve-names.cpp

5164

Is this what you wanna say?
replace statements => statement
and remove "value"

new message
"Selector '%s' in SELECT TYPE statement must be polymorphic"

5171

Probably because selector has a vector subscript.
`Neither 'associate-name =>' nor any subobject must appear in selector, if it has a vector subscript"

looks good?

[sameeranjoshi]

In D79851#2035703, @sameeranjoshi wrote:

Addressed comments by @klausler.

@klausler if you can point me some high level pointers on implementing C1162, would be much helpful, so I can start working on it.
Thanks.

[PeteSteinfeld]

Thanks for working on this!

Let me know if you have any questions.

flang/lib/Semantics/check-select-type.cpp

87

A more evocative name would be "PassesChecksOnGuard()"

94–95

C1160 applies to LEN type parameters for both character and derived types. It doesn't look like you're checking or testing for LEN parameters on derived types. Can you please add a check and test?

119

A more evocative name would be "PassesDerivedTypeChecks()".

123–124

It would be more consistent for the message to be "The type specification statement must not specify "

"a type with a SEQUENCE attribute or a BIND attribute"

184

I'd prefer a more evocative name, such as "TypesAreDifferent()"

195

I'd prefer a more evocative name such as "AreTypeKindCompatible()"

199

There's an extra "//" here

208

There should be single quotes around the name of the conflicting type specification -- as in "Type specification '%s' conflicts with previous type specification"_err_en_US,

211

There should be single quotes around the name of the conflicting type specification -- as in "Conflicting type specification '%s'"_en_US.

flang/lib/Semantics/resolve-names.cpp

5169–5170

C1158 also applies to selectors that are not variables. Can you please add a check and test for that situation?

flang/test/Semantics/selecttype01.f90

2

Can you please add tests for C1165?

[sameeranjoshi]

flang/lib/Semantics/resolve-names.cpp

5169–5170

I was confused from the wordings of standard.
This is what I understand,
If selector is not a variable => throw respective error
if selector is a variable that has a vector subscript -> throw error

Is this what you meant, that I am missing the first check?

[sameeranjoshi]

flang/lib/Semantics/check-select-type.cpp

94–95

Do you mean a test like below?

type :: t(n)
   integer, len :: n
end type

And inside SELECT TYPE something like :
type is ( t(n=*) ) !<-- assumed length-type

[PeteSteinfeld]

There's a lot to digest here. Let me know if you have questions.

flang/lib/Semantics/check-select-type.cpp

94–95

Exactly.

flang/lib/Semantics/resolve-names.cpp

5169–5170

Here's my understanding of C1158 in pseudo code:

if (!selector-is-variable || selector-is-variable-with-vector-subscript) {
   if (associate-name-appears-in-variable-definition-context ||
     associate-name-subobject-appears-in-variable-definition-context) {
     emit error message;
   }
 }

Suppose you have a function that returns a polymorphic type. Then, you call that function in a select-type-stmt and associate it with an associate-name. Then, suppose the associate-name appears on the left-hand side of an assignment statement or you use it as an actual argument to a procedure that has a dummy argument with INTENT(OUT) or INTENT(INOUT). I think that's the situation that C1158 is trying to avoid.

So it's OK to use something other than a variable, as long as you don't try to change the value of the associate-name. In standards-speak, that means that the associate-name can't appear in a "variable definition context" (see section 19.6.7 for details). Note also that if the selector is a variable, it's OK to use it in a variable definition context.

In fact, now that I've explained this in more detail. I don't think that your existing check or test is correct. To trigger an error, you should have a test where the associate-name appears on the left hand side of an assignment statement in the code of the construct of the SELECT TYPE statement. The test should look something like this:

select type(func_call(x) => func_result)
type is (xxx)
  call sub_with_inout_param(func_result) ! Bad since func-result is in a variable definition context
end select

So to implement this check, you'll need to look at all occurrences of the associate-name in the body of the select-type construct and see if the associate-name is associated with something other than a variable and if it is used in a variable definition context. In such cases, you should emit an error message.

As a model for implementation, you can look in in check-do-forall.cpp. Constraint C1130 requires that a variable used in a DO CONCURRENT construct must have its locality explicitly specified. So there's code in there that walks the DO CONCURRENT construct looking for variables that violate this requirement.

You might also find it useful to call the function WhyNotModifiable() in tools.h to figure out whether a Symbol is modifiable in a Scope. See section 19.6.7 for details on variable definition contexts.

[PeteSteinfeld]

flang/lib/Semantics/resolve-names.cpp

5169–5170

I've been looking at the existing code in the compiler. All that you may need to do is add some code to WhyNotModifiable() to handle SELECT TYPE associate-names. I see that there's already a test for a name that's construct associated. Start by writing tests that cover the two situations for C1158 and see if the appropriate things happen.

[sameeranjoshi]

Addressed comments by @PeteSteinfeld

[PeteSteinfeld]

All of my comments have been addressed. @klausler, if things look good to you, this is ready to merge.

[klausler]

flang/lib/Semantics/check-select-type.cpp

135

C1162 is important; please implement it. There can't be TYPE IS or CLASS IS cases in a SELECT TYPE that are not possible for the selector.

140

But why is this necessary?

flang/test/Semantics/selecttype03.f90

49

The comment states that the test is trying to force an error by associating a selector with a designator that has a vector subscript, but that's not what's happening in the code.

[sameeranjoshi]

flang/lib/Semantics/check-select-type.cpp

135

I have a test already added in selecttype01.f90 in subroutine CheckC1162.
If @PeteSteinfeld @klausler that LG, I think IsExtensibleType when passed with parentDerived would help in code implementation?

Can we extract the ancestor chain of a particular type as well as the types which derive from it?

Can you point some test file if present or the code file which could be already handling this?

140

Here's how I see it.
TypeCase nested in TypeCaseValues creates a logical nesting which becomes easy to read code and figure out the similar functions which would operate on some particular data of struct.

The way select-type-construct in below snippet from standard

R1152 select-type-construct 
select-type-stmt
[ type-guard-stmt block ] ...
[ type-guard-stmt block ] ...
...
end-select-type-stmt

Tries to seperate type-guard-stmt block and created a list of such blocks, similarly I see for TypeCase .
Also various helper functions and data members which logically would come in mind when it comes to implementing type-guard-stmt block are grouped in same struct.

Do you suggest instead of having a nested struct better to have these functions and struct data members in the parent class?

[PeteSteinfeld]

Thanks for working on this. There's still more to be done here.

flang/lib/Semantics/check-select-type.cpp

2

Does this file need to have clang-format run on it?

57

The & is not needed for any of these variants.

62

Specifying the return type is not necessary for this variant.

74–84

I'm not sure what the best answer here is. But the std::move() seems like a dangerous thing to do. I suggest looking around the rest of the files that do semantics checking for how they extract Evaluate::DynamicType objects and see if you can glean some wisdom from them.

92

The & is not needed.

98

Please make this fit into 80 columns.

120

Other methods are preceded by a blank line. Please insert one for consistency.

125

Please make this fit into 80 columns.

135

I don't understand your first question about "code implementation".

In resolve-names.cpp, there's a function called FindSymbol() that searches though a chain of extended derived types. Also, take a look at the Post() function for parser::DerivedTypeStmt. It processes the EXTENDS clause of a derived type definition.

207

Peter's comment about this is that the normal case is that there are no errors. So why have this comment at all?

237

Variable names should start with a lower-case letter. Please change this to selector. See flang//documentation/C++style.md for guidance.

flang/lib/Semantics/resolve-names.cpp

5164

This looks good to me.

flang/test/Semantics/selecttype01.f90

2

The RUN command has changed. It's now

! RUN: %S/test_errors.sh %s %t %f18

flang/test/Semantics/selecttype02.f90

2

The RUN command has changed. It's now

! RUN: %S/test_errors.sh %s %t %f18

flang/test/Semantics/selecttype03.f90

2

The RUN command has changed. It's now

! RUN: %S/test_errors.sh %s %t %f18

49

There's a comment in selecttype01.f90 that says it tests c1158. But I couldn't find a test that tests vector subscripts.

[sameeranjoshi]

flang/lib/Semantics/check-select-type.cpp

2

I ran git-clang-format and I wasn't seeing any changes in licence part.

[sameeranjoshi]

Update more review comments given by @PeteSteinfeld .
C1162 implemented.

[kiranchandramohan]

flang/lib/Semantics/check-select-type.cpp

140

Is it guaranteed that selectorType will be derived here? Bad code can have a selector which is not derived.

flang/lib/Semantics/resolve-names.cpp

5143–5151

The polymorphic selector check should happen here also to catch cases like the following.

program test
  integer :: x
  select type (a => x)
  type is (integer)
    print *,'integer ',a
  end select
end program

flang/test/Semantics/selecttype02.f90

24–38

try to use same number of spaces for alignment.

41–56

alignment

flang/test/Semantics/selecttype03.f90

18–24

Alignment

60–67

Alignment

[PeteSteinfeld]

Thanks again for working on this. Here's a summary of the changes I think are needed:

• Fix the creation of a DynamicType in GetGuardType()
• Fix the check for assumed length of derived types
• Add a test that uses class is (derived(param=*)) as a guard
• Add a test where the selector is unlimited polymorphic (class(*))
• Add test without a polymorphic selector: "select type (a => x)"
• Fix selecttype01.f90 to have the correct test for assumed length derived types
• Format the tests and remove all tabs

flang/lib/Semantics/check-select-type.cpp

67–79

You can create the required object as follows:

return evaluate::DynamicType(*derivedTypeSpec);

I don't think that you have any tests that actually exercise this code. The existing test resolve73.f90 does, though. Here's a smaller test that will exercise the variant parser::TypeSpec:

subroutine s()
  type derived(param)
    integer, len :: param
    class(*), allocatable :: x
  end type

  select type (ax => a%x)
    class is (derived(param=*))
      print *, "hello"
  end select
end subroutine s

124

There should be a ! preceding the pair.second.isAssumed().

144

Please make this fit into 80 columns.

234

Please make this fit into 80 columns.

flang/lib/Semantics/resolve-names.cpp

5143–5151

@kiranchandramohan is correct. Also, test a version of the program that does not include the declaration of integer :: x. That also fails.

Also, it would be good to include a test that actually has an integer type guard. Here's an example:

subroutine s(arg)
  class(*) :: arg
    select type (arg)
        type is (integer)
    end select
end

flang/test/Semantics/selecttype01.f90

56–57

This is the line that's in error, since the LEN is not assumed (*).

57–59

Please use spaces rather than tabs. There are other lines in this file that also contain tabs.

Also, please align the !ERROR and other comment lines with the associated lines that contain errors.

Also, please make the amount of indentation is inconsistent. Please indent two spaces everywhere.

Please do all of this for the other select type tests, too.

58–59

This is not an error. C1160 requires that the LEN be assumed, which is what this source code does.

218–224

Note that tests do not need a main program. We're only testing the semantic checking. There's no need to pretend that we can create an executable program.

flang/test/Semantics/selecttype02.f90

2

Please remove all tabs from this file.

flang/test/Semantics/selecttype03.f90

2

Please remove all tabs from this file.

[sameeranjoshi]

Thanks @kiranchandramohan and @PeteSteinfeld for reviewing.
I have addressed them.

[PeteSteinfeld]

Looks good!

Please make that change to check-select-type.cpp before pushing.

Thanks for sticking with this.

[PeteSteinfeld]

flang/lib/Semantics/check-select-type.cpp

126–127

You should embed the declaration of selDerivedTypeSpec into the if condition to reduce its scope.

[sameeranjoshi]

Merged by this commit
https://github.com/llvm/llvm-project/commit/70ad73b6b76838bd7c72123922102b175e5d478a

[PeteSteinfeld]

Note that a Bugzilla report has been filed on this -- https://bugs.llvm.org/show_bug.cgi?id=46789. @sameeranjoshi , can you please take a look?

flang/lib/Semantics/CMakeLists.txt

add_flang_library(FortranSemantics
   check-if-stmt.cpp
   check-io.cpp
   check-namelist.cpp
   check-nullify.cpp
   check-omp-structure.cpp
   check-purity.cpp
   check-return.cpp
   check-select-rank.cpp
+  check-select-type.cpp
   check-stop.cpp
   compute-offsets.cpp
   expression.cpp
   mod-file.cpp
   pointer-assignment.cpp
   program-tree.cpp
   resolve-labels.cpp
   resolve-names.cpp

flang/lib/Semantics/assignment.cpp

if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
     if (shape && !shape->empty() && !shape->back().has_value()) { // C1014
       Say(lhsLoc,
           "Left-hand side of assignment may not be a whole assumed-size array"_err_en_US);
     }
     if (CheckForPureContext(lhs, rhs, rhsLoc, false)) {
       const Scope &scope{context_.FindScope(lhsLoc)};
       if (auto whyNot{WhyNotModifiable(lhsLoc, lhs, scope, true)}) {
         if (auto *msg{Say(lhsLoc,
-                "Left-hand side of assignment is not modifiable"_err_en_US)}) {
+                "Left-hand side of assignment is not modifiable"_err_en_US)}) { // C1158
           msg->Attach(*whyNot);
         }
       }
     }
     if (whereDepth_ > 0) {
       CheckShape(lhsLoc, &lhs);
     }
   }

flang/lib/Semantics/check-call.cpp

static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   } else if (dummyIsVolatile) {
     reason = "VOLATILE";
   }
   if (reason && scope) {
     bool vectorSubscriptIsOk{isElemental || dummyIsValue}; // 15.5.2.4(21)
     if (auto why{WhyNotModifiable(
             messages.at(), actual, *scope, vectorSubscriptIsOk)}) {
       if (auto *msg{messages.Say(
-              "Actual argument associated with %s %s must be definable"_err_en_US,
+              "Actual argument associated with %s %s must be definable"_err_en_US, // C1158
               reason, dummyName)}) {
         msg->Attach(*why);
       }
     }
   }
 
   // Cases when temporaries might be needed but must not be permitted.
   bool dummyIsPointer{

flang/lib/Semantics/check-select-type.h

+//===-- lib/Semantics/check-select-type.h -----------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_SEMANTICS_CHECK_SELECT_TYPE_H_
+#define FORTRAN_SEMANTICS_CHECK_SELECT_TYPE_H_
+
+#include "flang/Semantics/semantics.h"
+
+namespace Fortran::parser {
+struct SelectTypeConstruct;
+struct Selector;
+} // namespace Fortran::parser
+
+namespace Fortran::semantics {
+
+class SelectTypeChecker : public virtual BaseChecker {
+public:
+  explicit SelectTypeChecker(SemanticsContext &context) : context_{context} {};
+  void Enter(const parser::SelectTypeConstruct &);
+
+private:
+  const SomeExpr *GetExprFromSelector(const parser::Selector &);
+  SemanticsContext &context_;
+};
+} // namespace Fortran::semantics
+#endif // FORTRAN_SEMANTICS_CHECK_SELECT_TYPE_H_

flang/lib/Semantics/check-select-type.cpp

+//===-- lib/Semantics/check-select-type.cpp -------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "check-select-type.h"
+#include "flang/Common/idioms.h"
+#include "flang/Common/reference.h"
+#include "flang/Evaluate/fold.h"
+#include "flang/Evaluate/type.h"
+#include "flang/Parser/parse-tree.h"
+#include "flang/Semantics/semantics.h"
+#include "flang/Semantics/tools.h"
+#include <optional>
+
+namespace Fortran::semantics {
+
+class TypeCaseValues {
+public:
+  TypeCaseValues(SemanticsContext &c, const evaluate::DynamicType &t)
+      : context_{c}, selectorType_{t} {}
+  void Check(const std::list<parser::SelectTypeConstruct::TypeCase> &cases) {
+    for (const auto &c : cases) {
+      AddTypeCase(c);
+    }
+    if (!hasErrors_) {
+      ReportConflictingTypeCases();
+    }
+  }
+
+private:
+  void AddTypeCase(const parser::SelectTypeConstruct::TypeCase &c) {
+    const auto &stmt{std::get<parser::Statement<parser::TypeGuardStmt>>(c.t)};
+    const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
+    const auto &guard{std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t)};
+    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)) {
+        typeCases_.emplace_back(stmt, *type);
+      } else {
+        hasErrors_ = true;
+      }
+    } else {
+      hasErrors_ = true;
+    }
+  }
+
+  std::optional<evaluate::DynamicType> GetGuardType(
+      const parser::TypeGuardStmt::Guard &guard) {
+    return std::visit(
+        common::visitors{
+            [](const parser::Default &)
+                -> std::optional<evaluate::DynamicType> {
+              return std::nullopt;
+            },
+            [](const parser::TypeSpec &typeSpec) {
+              return evaluate::DynamicType::From(typeSpec.declTypeSpec);
+            },
+            [](const parser::DerivedTypeSpec &spec)
+                -> std::optional<evaluate::DynamicType> {
+              if (const auto *derivedTypeSpec{spec.derivedTypeSpec}) {
+                return evaluate::DynamicType(*derivedTypeSpec);
+              }
+              return std::nullopt;
+            },
+        },
+        guard.u);
+  }
+
+  bool PassesChecksOnGuard(const parser::TypeGuardStmt::Guard &guard,
+      const evaluate::DynamicType &guardDynamicType) {
+    return std::visit(
+        common::visitors{
+            [](const parser::Default &) { return true; },
+            [&](const parser::TypeSpec &typeSpec) {
+              if (const DeclTypeSpec * spec{typeSpec.declTypeSpec}) {
+                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;
+                }
+                if (const DerivedTypeSpec * derived{spec->AsDerived()}) {
+                  return PassesDerivedTypeChecks(
+                      *derived, parser::FindSourceLocation(typeSpec));
+                }
+                return false;
+              }
+              return false;
+            },
+            [&](const parser::DerivedTypeSpec &x) {
+              if (const semantics::DerivedTypeSpec *
+                  derived{x.derivedTypeSpec}) {
+                return PassesDerivedTypeChecks(
+                    *derived, parser::FindSourceLocation(x));
+              }
+              return false;
+            },
+        },
+        guard.u);
+  }
+
+  bool PassesDerivedTypeChecks(const semantics::DerivedTypeSpec &derived,
+      parser::CharBlock sourceLoc) const {
+    for (const auto &pair : derived.parameters()) {
+      if (pair.second.isLen() && !pair.second.isAssumed()) { // C1160
+        context_.Say(sourceLoc,
+            "The type specification statement must have "
+            "LEN type parameter as assumed"_err_en_US);
+        return false;
+      }
+    }
+    if (!IsExtensibleType(&derived)) { // C1161
+      context_.Say(sourceLoc,
+          "The type specification statement must not specify "
+          "a type with a SEQUENCE attribute or a BIND attribute"_err_en_US);
+      return false;
+    }
+    if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162
+      if (const semantics::Scope * guardScope{derived.typeSymbol().scope()}) {
+        const auto *selDerivedTypeSpec{
+            evaluate::GetDerivedTypeSpec(selectorType_)};
+        if (selDerivedTypeSpec) {
+          if (!(derived == *selDerivedTypeSpec) &&
+              !guardScope->FindComponent(selDerivedTypeSpec->name())) {
+            context_.Say(sourceLoc,
+                "Type specification '%s' must be an extension"
+                " of TYPE '%s'"_err_en_US,
+                derived.AsFortran(), selDerivedTypeSpec->AsFortran());
+            return false;
+          }
+        }
+      }
+    }
+    return true;
+  }
+
+  struct TypeCase {
+    explicit TypeCase(const parser::Statement<parser::TypeGuardStmt> &s,
+        std::optional<evaluate::DynamicType> guardTypeDynamic)
+        : stmt{s} {
+      SetGuardType(guardTypeDynamic);
+    }
+
+    void SetGuardType(std::optional<evaluate::DynamicType> guardTypeDynamic) {
+      const auto &guard{GetGuardFromStmt(stmt)};
+      std::visit(common::visitors{
+                     [&](const parser::Default &) {},
+                     [&](const auto &) { guardType_ = *guardTypeDynamic; },
+                 },
+          guard.u);
+    }
+
+    bool IsDefault() const {
+      const auto &guard{GetGuardFromStmt(stmt)};
+      return std::holds_alternative<parser::Default>(guard.u);
+    }
+
+    bool IsTypeSpec() const {
+      const auto &guard{GetGuardFromStmt(stmt)};
+      return std::holds_alternative<parser::TypeSpec>(guard.u);
+    }
+
+    bool IsDerivedTypeSpec() const {
+      const auto &guard{GetGuardFromStmt(stmt)};
+      return std::holds_alternative<parser::DerivedTypeSpec>(guard.u);
+    }
+
+    const parser::TypeGuardStmt::Guard &GetGuardFromStmt(
+        const parser::Statement<parser::TypeGuardStmt> &stmt) const {
+      const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
+      return std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t);
+    }
+
+    std::optional<evaluate::DynamicType> guardType() const {
+      return guardType_;
+    }
+
+    std::string AsFortran() const {
+      std::string result;
+      if (this->guardType()) {
+        auto type{*this->guardType()};
+        result += type.AsFortran();
+      } else {
+        result += "DEFAULT";
+      }
+      return result;
+    }
+    const parser::Statement<parser::TypeGuardStmt> &stmt;
+    std::optional<evaluate::DynamicType> guardType_; // is this POD?
+  };
+
+  // Returns true if and only if the values are different
+  // Does apple to apple comparision, in case of TypeSpec or DerivedTypeSpec
+  // checks for kinds as well.
+  static bool TypesAreDifferent(const TypeCase &x, const TypeCase &y) {
+    if (x.IsDefault()) { // C1164
+      return !y.IsDefault();
+    } else if (x.IsTypeSpec() && y.IsTypeSpec()) { // C1163
+      return !AreTypeKindCompatible(x, y);
+    } else if (x.IsDerivedTypeSpec() && y.IsDerivedTypeSpec()) { // C1163
+      return !AreTypeKindCompatible(x, y);
+    }
+    return true;
+  }
+
+  static bool AreTypeKindCompatible(const TypeCase &x, const TypeCase &y) {
+    return (*x.guardType()).IsTkCompatibleWith((*y.guardType()));
+  }
+
+  void ReportConflictingTypeCases() {
+    for (auto iter{typeCases_.begin()}; iter != typeCases_.end(); ++iter) {
+      parser::Message *msg{nullptr};
+      for (auto p{typeCases_.begin()}; p != typeCases_.end(); ++p) {
+        if (p->stmt.source.begin() < iter->stmt.source.begin() &&
+            !TypesAreDifferent(*p, *iter)) {
+          if (!msg) {
+            msg = &context_.Say(iter->stmt.source,
+                "Type specification '%s' conflicts with "
+                "previous type specification"_err_en_US,
+                iter->AsFortran());
+          }
+          msg->Attach(p->stmt.source,
+              "Conflicting type specification '%s'"_en_US, p->AsFortran());
+        }
+      }
+    }
+  }
+
+  SemanticsContext &context_;
+  const evaluate::DynamicType &selectorType_;
+  std::list<TypeCase> typeCases_;
+  bool hasErrors_{false};
+};
+
+void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) {
+  const auto &selectTypeStmt{
+      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);
+  }
+}
+
+const SomeExpr *SelectTypeChecker::GetExprFromSelector(
+    const parser::Selector &selector) {
+  return std::visit([](const auto &x) { return GetExpr(x); }, selector.u);
+}
+} // namespace Fortran::semantics

flang/lib/Semantics/resolve-names.cpp

 
 void ConstructVisitor::Post(const parser::SelectTypeConstruct &) {
   PopAssociation();
 }
 
 void ConstructVisitor::Post(const parser::SelectTypeStmt &x) {
   auto &association{GetCurrentAssociation()};
   if (const std::optional<parser::Name> &name{std::get<1>(x.t)}) {
     // This isn't a name in the current scope, it is in each TypeGuardStmt
     MakePlaceholder(*name, MiscDetails::Kind::SelectTypeAssociateName);
     association.name = &*name;
+    auto exprType{association.selector.expr->GetType()};
+    if (exprType && !exprType->IsPolymorphic()) { // C1159
+      Say(association.selector.source,
+          "Selector '%s' in SELECT TYPE statement must be "
+          "polymorphic"_err_en_US);
+    }
   } else {
     if (const Symbol *
         whole{UnwrapWholeSymbolDataRef(association.selector.expr)}) {
       ConvertToObjectEntity(const_cast<Symbol &>(*whole));
       if (!IsVariableName(*whole)) {
         Say(association.selector.source, // C901
             "Selector is not a variable"_err_en_US);
         association = {};
       }
+      if (const DeclTypeSpec * type{whole->GetType()}) {
+        if (!type->IsPolymorphic()) { // C1159
+          Say(association.selector.source,
+              "Selector '%s' in SELECT TYPE statement must be "
+              "polymorphic"_err_en_US);
+        }
+      }
     } else {
       Say(association.selector.source, // C1157
           "Selector is not a named variable: 'associate-name =>' is required"_err_en_US);
       association = {};
     }
   }
 }
 
 void ConstructVisitor::Post(const parser::SelectRankStmt &x) {
   auto &association{GetCurrentAssociation()};
   if (const std::optional<parser::Name> &name{std::get<1>(x.t)}) {
     // This isn't a name in the current scope, it is in each SelectRankCaseStmt

flang/lib/Semantics/semantics.cpp

 #include "check-if-stmt.h"
 #include "check-io.h"
 #include "check-namelist.h"
 #include "check-nullify.h"
 #include "check-omp-structure.h"
 #include "check-purity.h"
 #include "check-return.h"
 #include "check-select-rank.h"
+#include "check-select-type.h"
 #include "check-stop.h"
 #include "compute-offsets.h"
 #include "mod-file.h"
 #include "resolve-labels.h"
 #include "resolve-names.h"
 #include "rewrite-parse-tree.h"
 #include "flang/Common/default-kinds.h"
 #include "flang/Parser/parse-tree-visitor.h"
private:
   SemanticsContext &context_;
 };
 
 using StatementSemanticsPass1 = ExprChecker;
 using StatementSemanticsPass2 = SemanticsVisitor<AllocateChecker,
     ArithmeticIfStmtChecker, AssignmentChecker, CaseChecker, CoarrayChecker,
     DataChecker, DeallocateChecker, DoForallChecker, IfStmtChecker, IoChecker,
     MiscChecker, NamelistChecker, NullifyChecker, OmpStructureChecker,
-    PurityChecker, ReturnStmtChecker, SelectRankConstructChecker, StopChecker>;
+    PurityChecker, ReturnStmtChecker, SelectRankConstructChecker,
+    SelectTypeChecker, StopChecker>;
 
 static bool PerformStatementSemantics(
     SemanticsContext &context, parser::Program &program) {
   ResolveNames(context, program);
   RewriteParseTree(context, program);
   ComputeOffsets(context);
   CheckDeclarations(context);
   StatementSemanticsPass1{context}.Walk(program);

flang/test/Semantics/selecttype01.f90

+! RUN: %S/test_errors.sh %s %t %f18
+! Test for checking select type constraints,
+module m1
+  use ISO_C_BINDING
+  type shape
+    integer :: color
+    logical :: filled
+    integer :: x
+    integer :: y
+  end type shape
+
+  type, extends(shape) :: rectangle
+    integer :: length
+    integer :: width
+  end type rectangle
+
+  type, extends(rectangle) :: square
+  end type square
+
+  type, extends(square) :: extsquare
+  end type
+
+  type :: unrelated
+    logical :: some_logical
+  end type
+
+  type withSequence
+    SEQUENCE
+    integer :: x
+  end type
+
+  type, BIND(C) :: withBind
+    INTEGER(c_int) ::int_in_c
+  end type
+
+  TYPE(shape), TARGET :: shape_obj
+  TYPE(rectangle), TARGET :: rect_obj
+  TYPE(square), TARGET :: squr_obj
+  !define polymorphic objects
+  class(*), pointer :: unlim_polymorphic
+  class(shape), pointer :: shape_lim_polymorphic
+end
+module m
+  type :: t(n)
+    integer, len :: n
+  end type
+contains
+  subroutine CheckC1160( a )
+    class(*), intent(in) :: a
+    select type ( a )
+      !ERROR: The type specification statement must have LEN type parameter as assumed
+      type is ( character(len=10) ) !<-- assumed length-type
+      ! OK
+      type is ( character(len=*) )
+      !ERROR: The type specification statement must have LEN type parameter as assumed
+      type is ( t(n=10) )
+      ! OK
+      type is ( t(n=*) )   !<-- assumed length-type
+      !ERROR: Derived type 'character' not found
+      class is ( character(len=10) ) !<-- assumed length-type
+    end select
+  end subroutine
+
+  subroutine s()
+    type derived(param)
+      integer, len :: param
+      class(*), allocatable :: x
+    end type
+    TYPE(derived(10)) :: a
+    select type (ax => a%x)
+      class is (derived(param=*))
+        print *, "hello"
+    end select
+  end subroutine s
+end module
+
+subroutine CheckC1157
+  use m1
+  integer, parameter :: const_var=10
+  !ERROR: Selector is not a named variable: 'associate-name =>' is required
+  select type(10)
+  end select
+  !ERROR: Selector is not a named variable: 'associate-name =>' is required
+  select type(const_var)
+  end select
+  !ERROR: Selector is not a named variable: 'associate-name =>' is required
+  select type (4.999)
+  end select
+  !ERROR: Selector is not a named variable: 'associate-name =>' is required
+  select type (shape_obj%x)
+  end select
+end subroutine
+
+!CheckPloymorphicSelectorType
+subroutine CheckC1159a
+  integer :: int_variable
+  real :: real_variable
+  complex :: complex_var = cmplx(3.0, 4.0)
+  logical :: log_variable
+  character (len=10) :: char_variable = "OM"
+  !ERROR: Selector 'int_variable' in SELECT TYPE statement must be polymorphic
+  select type (int_variable)
+  end select
+  !ERROR: Selector 'real_variable' in SELECT TYPE statement must be polymorphic
+  select type (real_variable)
+  end select
+  !ERROR: Selector 'complex_var' in SELECT TYPE statement must be polymorphic
+  select type(complex_var)
+  end select
+  !ERROR: Selector 'logical_variable' in SELECT TYPE statement must be polymorphic
+  select type(logical_variable)
+  end select
+  !ERROR: Selector 'char_variable' in SELECT TYPE statement must be polymorphic
+  select type(char_variable)
+  end select
+end
+
+subroutine CheckC1159b
+  integer :: x
+  !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
+  select type (a => x)
+  type is (integer)
+    print *,'integer ',a
+  end select
+end
+
+subroutine CheckC1159c
+  !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
+  select type (a => x)
+  type is (integer)
+    print *,'integer ',a
+  end select
+end
+
+subroutine s(arg)
+  class(*) :: arg
+    select type (arg)
+        type is (integer)
+    end select
+end
+
+subroutine CheckC1161
+  use m1
+  shape_lim_polymorphic => rect_obj
+  select type(shape_lim_polymorphic)
+    !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
+    type is (withSequence)
+    !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
+    type is (withBind)
+  end select
+end
+
+subroutine CheckC1162
+  use m1
+  class(rectangle), pointer :: rectangle_polymorphic
+  !not unlimited polymorphic objects
+  select type (rectangle_polymorphic)
+    !ERROR: Type specification 'shape' must be an extension of TYPE 'rectangle'
+    type is (shape)
+    !ERROR: Type specification 'unrelated' must be an extension of TYPE 'rectangle'
+    type is (unrelated)
+    !all are ok
+    type is (square)
+    type is (extsquare)
+    !Handle same types
+    type is (rectangle)
+  end select
+
+  !Unlimited polymorphic objects are allowed.
+  unlim_polymorphic => rect_obj
+  select type (unlim_polymorphic)
+    type is (shape)
+    type is (unrelated)
+  end select
+end
+
+subroutine CheckC1163
+  use m1
+  !assign dynamically
+  shape_lim_polymorphic => rect_obj
+  unlim_polymorphic => shape_obj
+  select type (shape_lim_polymorphic)
+    type is (shape)
+    !ERROR: Type specification 'shape' conflicts with previous type specification
+    type is (shape)
+    class is (square)
+    !ERROR: Type specification 'square' conflicts with previous type specification
+    class is (square)
+  end select
+end
+
+subroutine CheckC1164
+  use m1
+  shape_lim_polymorphic => rect_obj
+  unlim_polymorphic => shape_obj
+  select type (shape_lim_polymorphic)
+    CLASS DEFAULT
+    !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
+    CLASS DEFAULT
+    TYPE IS (shape)
+    TYPE IS (rectangle)
+    !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
+    CLASS DEFAULT
+  end select
+
+  !Saving computation if some error in guard by not computing RepeatingCases
+  select type (shape_lim_polymorphic)
+    CLASS DEFAULT
+    CLASS DEFAULT
+    !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
+    TYPE IS(withSequence)
+  end select
+end subroutine
+
+subroutine WorkingPolymorphism
+  use m1
+  !assign dynamically
+  shape_lim_polymorphic => rect_obj
+  unlim_polymorphic => shape_obj
+  select type (shape_lim_polymorphic)
+    type is  (shape)
+      print *, "hello shape"
+    type is  (rectangle)
+      print *, "hello rect"
+    type is  (square)
+      print *, "hello square"
+    CLASS DEFAULT
+      print *, "default"
+  end select
+  print *, "unlim polymorphism"
+  select type (unlim_polymorphic)
+    type is  (shape)
+      print *, "hello shape"
+    type is  (rectangle)
+      print *, "hello rect"
+    type is  (square)
+      print *, "hello square"
+    CLASS DEFAULT
+      print *, "default"
+  end select
+end

flang/test/Semantics/selecttype02.f90

+! RUN: %S/test_errors.sh %s %t %f18
+module m1
+  use ISO_C_BINDING
+  type shape
+    integer :: color
+    logical :: filled
+    integer :: x
+    integer :: y
+  end type shape
+  type, extends(shape) :: rectangle
+    integer :: length
+    integer :: width
+  end type rectangle
+  type, extends(rectangle) :: square
+  end type square
+
+  TYPE(shape), TARGET :: shape_obj
+  TYPE(rectangle), TARGET :: rect_obj
+ !define polymorphic objects
+  class(shape), pointer :: shape_lim_polymorphic
+end
+subroutine C1165a
+  use m1
+  shape_lim_polymorphic => rect_obj
+  label : select type (shape_lim_polymorphic)
+  end select label
+  label1 : select type (shape_lim_polymorphic)
+  !ERROR: SELECT TYPE construct name required but missing
+  end select
+  select type (shape_lim_polymorphic)
+  !ERROR: SELECT TYPE construct name unexpected
+  end select label2
+  select type (shape_lim_polymorphic)
+  end select
+end subroutine
+subroutine C1165b
+  use m1
+  shape_lim_polymorphic => rect_obj
+!type-guard-stmt realted checks
+label : select type (shape_lim_polymorphic)
+  type is (shape) label
+  end select label
+ select type (shape_lim_polymorphic)
+  !ERROR: SELECT TYPE name not allowed
+  type is (shape) label
+  end select
+label : select type (shape_lim_polymorphic)
+  !ERROR: SELECT TYPE name mismatch
+  type is (shape) labelll
+  end select label
+end subroutine

flang/test/Semantics/selecttype03.f90

+! RUN: %S/test_errors.sh %s %t %f18
+! Test various conditions in C1158.
+implicit none
+
+type :: t1
+  integer :: i
+end type
+
+type, extends(t1) :: t2
+end type
+
+type(t1),target :: x1
+type(t2),target :: x2
+
+class(*), pointer :: ptr
+class(t1), pointer :: p_or_c
+!vector subscript related
+class(t1),DIMENSION(:,:),allocatable::array1
+class(t2),DIMENSION(:,:),allocatable::array2
+integer, dimension(2) :: V
+V = (/ 1,2 /)
+allocate(array1(3,3))
+allocate(array2(3,3))
+
+! A) associate with function, i.e (other than variables)
+select type ( y => fun(1) )
+  type is (t1)
+    print *, rank(y%i)
+end select
+
+select type ( y => fun(1) )
+  type is (t1)
+    !ERROR: Left-hand side of assignment is not modifiable
+    y%i = 1 !VDC
+  type is (t2)
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
+    call sub_with_in_and_inout_param(y,y) !VDC
+end select
+
+! B) associated with a variable:
+p_or_c => x1
+select type ( a => p_or_c )
+  type is (t1)
+    a%i = 10
+end select
+
+select type ( a => p_or_c )
+  type is (t1)
+end select
+
+!C)Associate with  with vector subscript
+select type (b => array1(V,2))
+  type is (t1)
+    !ERROR: Left-hand side of assignment is not modifiable
+    b%i  = 1 !VDC
+  type is (t2)
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
+    call sub_with_in_and_inout_param_vector(b,b) !VDC
+end select
+select type(b =>  foo(1) )
+  type is (t1)
+    !ERROR: Left-hand side of assignment is not modifiable
+    b%i = 1 !VDC
+  type is (t2)
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
+    call sub_with_in_and_inout_param_vector(b,b) !VDC
+end select
+
+!D) Have no association and should be ok.
+!1. points to function
+ptr => fun(1)
+select type ( ptr )
+type is (t1)
+  ptr%i = 1
+end select
+
+!2. points to variable
+ptr=>x1
+select type (ptr)
+  type is (t1)
+    ptr%i = 10
+end select
+
+contains
+
+  function fun(i)
+    class(t1),pointer :: fun
+    integer :: i
+    if (i>0) then
+      fun => x1
+    else if (i<0) then
+      fun => x2
+    else
+      fun => NULL()
+    end if
+  end function
+
+  function foo(i)
+    integer :: i
+    class(t1),DIMENSION(:),allocatable :: foo
+    integer, dimension(2) :: U
+    U = (/ 1,2 /)  
+    if (i>0) then
+      foo = array1(2,U)
+    else if (i<0) then
+      !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t1) and TYPE(t2)
+      foo = array2(2,U)
+    end if
+  end function
+
+  subroutine sub_with_in_and_inout_param(y, z)
+    type(t2), INTENT(IN) :: y
+    class(t2), INTENT(INOUT) :: z
+    z%i = 10
+  end subroutine
+
+  subroutine sub_with_in_and_inout_param_vector(y, z)
+    type(t2),DIMENSION(:), INTENT(IN) :: y
+    class(t2),DIMENSION(:), INTENT(INOUT) :: z
+    z%i = 10
+  end subroutine
+
+end