[flang] Semantics for SELECT TYPE

Summary:
    Added support for all semantic checks except C1157
    was previously implemented.

    Address review comments.

    Reviewers: PeteSteinfeld, tskeith, klausler, DavidTruby, kiranktp, anchu-rajendran, sscalpone

    Subscribers: kiranchandramohan, llvm-commits, flang-commits

    Tags: #llvm, #flang

    Differential Revision: https://reviews.llvm.org/D79851

flang/lib/Semantics/CMakeLists.txt

@@ -21,6 +21,7 @@ add_flang_library(FortranSemantics
   check-purity.cpp
   check-return.cpp
   check-select-rank.cpp
+  check-select-type.cpp
   check-stop.cpp
   compute-offsets.cpp
   expression.cpp

flang/lib/Semantics/assignment.cpp

@@ -75,7 +75,7 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
       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);
         }
       }

flang/lib/Semantics/check-call.cpp

@@ -332,7 +332,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     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);
       }

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

@@ -0,0 +1,262 @@
+//===-- 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()}) {
+        if (const auto *selDerivedTypeSpec{
+                evaluate::GetDerivedTypeSpec(selectorType_)}) {
+          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/check-select-type.h

@@ -0,0 +1,31 @@
+//===-- 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/resolve-names.cpp

@@ -5147,6 +5147,12 @@ void ConstructVisitor::Post(const parser::SelectTypeStmt &x) {
     // 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)}) {
@@ -5156,6 +5162,13 @@ void ConstructVisitor::Post(const parser::SelectTypeStmt &x) {
             "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);

flang/lib/Semantics/semantics.cpp

@@ -26,6 +26,7 @@
 #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"
@@ -157,7 +158,8 @@ 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) {

flang/test/Semantics/selecttype01.f90

@@ -0,0 +1,241 @@
+! 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

@@ -0,0 +1,51 @@
+! 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

@@ -0,0 +1,123 @@
+! 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