[flang] Initial lowering of SELECT TYPE construct to fir.select_type operation

[clementval]

Summary

This patch is the initial path to lower the SELECT TYPE construct to the
fir.select_type operation. More work is required in the AssocEntity
mapping but it will be done in a follow up patch to ease the review.

[PeteSteinfeld]

Things generally build and look correct, but when I run check-flang, I get a failure:

******************** TEST 'Flang :: Lower/module_use.f90' FAILED ********************
Script:
--
: 'RUN: at line 1';   bbc -emit-fir /local/home/psteinfeld/main/select/flang/test/Lower/module_definition.f90
: 'RUN: at line 2';   bbc -emit-fir /local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90 -o - | /local/home/psteinfeld/main/select/build/bin/FileCheck /local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90
--
Exit Code: 1

Command Output (stderr):
--
/local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90:15:15: error: CHECK-DAG: expected string not found in input
 ! CHECK-DAG: fir.address_of(@_QMm1Ex) : !fir.ref<f32>
              ^
<stdin>:4:22: note: scanning from here
func.func @_QPm1use() -> f32 {
                     ^
<stdin>:13:2: note: possible intended match here
 fir.store %5 to %1 : !fir.ref<f32>
 ^
/local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90:42:14: error: CHECK-DAG: expected string not found in input
! CHECK-DAG: fir.global @_QMm1Ex : f32
             ^
<stdin>:17:30: note: scanning from here
func.func @_QPmodcommon1use() -> f32 {
                             ^
<stdin>:36:17: note: possible intended match here
 %15 = arith.addf %13, %14 : f32
                ^

Input file: <stdin>
Check file: /local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90

-dump-input=help explains the following input dump.

Input was:
<<<<<<
          1: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8> 
          2: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8> 
          3: fir.global common @_QBnamed2(dense<0> : vector<4xi8>) : !fir.array<4xi8> 
          4: func.func @_QPm1use() -> f32 { 
dag:15'0                          X~~~~~~~~~ error: no match found
          5:  %0 = fir.alloca i32 {adapt.valuebyref} 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          6:  %1 = fir.alloca f32 {bindc_name = "m1use", uniq_name = "_QFm1useEm1use"} 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          7:  %2 = fir.alloca f32 {bindc_name = "x", uniq_name = "_QFm1useEx"} 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          8:  %3 = fir.load %2 : !fir.ref<f32> 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          9:  %c1_i32 = arith.constant 1 : i32 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         10:  fir.store %c1_i32 to %0 : !fir.ref<i32> 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         11:  %4 = fir.call @_QPy(%0) : (!fir.ref<i32>) -> f32 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         12:  %5 = arith.addf %3, %4 : f32 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         13:  fir.store %5 to %1 : !fir.ref<f32> 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dag:15'1      ?                                   possible intended match
         14:  %6 = fir.load %1 : !fir.ref<f32> 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         15:  return %6 : f32 
dag:15'0     ~~~~~~~~~~~~~~~~~
         16: } 
dag:15'0     ~~
         17: func.func @_QPmodcommon1use() -> f32 { 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dag:42'0                                  X~~~~~~~~~ error: no match found
         18:  %0 = fir.address_of(@_QBnamed2) : !fir.ref<!fir.array<4xi8>> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         19:  %1 = fir.convert %0 : (!fir.ref<!fir.array<4xi8>>) -> !fir.ref<!fir.array<?xi8>> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         20:  %c0 = arith.constant 0 : index 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         21:  %2 = fir.coordinate_of %1, %c0 : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         22:  %3 = fir.convert %2 : (!fir.ref<i8>) -> !fir.ref<i32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          .
          .
          .
         31:  %c0_1 = arith.constant 0 : index 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         32:  %11 = fir.coordinate_of %10, %c0_1 : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         33:  %12 = fir.convert %11 : (!fir.ref<i8>) -> !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         34:  %13 = fir.load %8 : !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         35:  %14 = fir.load %12 : !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         36:  %15 = arith.addf %13, %14 : f32 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dag:42'1                     ?                 possible intended match
         37:  %16 = fir.load %3 : !fir.ref<i32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         38:  %17 = fir.convert %16 : (i32) -> f32 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         39:  %18 = arith.addf %15, %17 : f32 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         40:  fir.store %18 to %4 : !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         41:  %19 = fir.load %4 : !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          .
          .
          .
>>>>>>

--

********************

[clementval]

In D137728#3917877, @PeteSteinfeld wrote:

Things generally build and look correct, but when I run check-flang, I get a failure:

******************** TEST 'Flang :: Lower/module_use.f90' FAILED ********************
Script:
--
: 'RUN: at line 1';   bbc -emit-fir /local/home/psteinfeld/main/select/flang/test/Lower/module_definition.f90
: 'RUN: at line 2';   bbc -emit-fir /local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90 -o - | /local/home/psteinfeld/main/select/build/bin/FileCheck /local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90
--
Exit Code: 1

Command Output (stderr):
--
/local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90:15:15: error: CHECK-DAG: expected string not found in input
 ! CHECK-DAG: fir.address_of(@_QMm1Ex) : !fir.ref<f32>
              ^
<stdin>:4:22: note: scanning from here
func.func @_QPm1use() -> f32 {
                     ^
<stdin>:13:2: note: possible intended match here
 fir.store %5 to %1 : !fir.ref<f32>
 ^
/local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90:42:14: error: CHECK-DAG: expected string not found in input
! CHECK-DAG: fir.global @_QMm1Ex : f32
             ^
<stdin>:17:30: note: scanning from here
func.func @_QPmodcommon1use() -> f32 {
                             ^
<stdin>:36:17: note: possible intended match here
 %15 = arith.addf %13, %14 : f32
                ^

Input file: <stdin>
Check file: /local/home/psteinfeld/main/select/flang/test/Lower/module_use.f90

-dump-input=help explains the following input dump.

Input was:
<<<<<<
          1: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8> 
          2: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8> 
          3: fir.global common @_QBnamed2(dense<0> : vector<4xi8>) : !fir.array<4xi8> 
          4: func.func @_QPm1use() -> f32 { 
dag:15'0                          X~~~~~~~~~ error: no match found
          5:  %0 = fir.alloca i32 {adapt.valuebyref} 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          6:  %1 = fir.alloca f32 {bindc_name = "m1use", uniq_name = "_QFm1useEm1use"} 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          7:  %2 = fir.alloca f32 {bindc_name = "x", uniq_name = "_QFm1useEx"} 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          8:  %3 = fir.load %2 : !fir.ref<f32> 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          9:  %c1_i32 = arith.constant 1 : i32 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         10:  fir.store %c1_i32 to %0 : !fir.ref<i32> 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         11:  %4 = fir.call @_QPy(%0) : (!fir.ref<i32>) -> f32 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         12:  %5 = arith.addf %3, %4 : f32 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         13:  fir.store %5 to %1 : !fir.ref<f32> 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dag:15'1      ?                                   possible intended match
         14:  %6 = fir.load %1 : !fir.ref<f32> 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         15:  return %6 : f32 
dag:15'0     ~~~~~~~~~~~~~~~~~
         16: } 
dag:15'0     ~~
         17: func.func @_QPmodcommon1use() -> f32 { 
dag:15'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dag:42'0                                  X~~~~~~~~~ error: no match found
         18:  %0 = fir.address_of(@_QBnamed2) : !fir.ref<!fir.array<4xi8>> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         19:  %1 = fir.convert %0 : (!fir.ref<!fir.array<4xi8>>) -> !fir.ref<!fir.array<?xi8>> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         20:  %c0 = arith.constant 0 : index 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         21:  %2 = fir.coordinate_of %1, %c0 : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         22:  %3 = fir.convert %2 : (!fir.ref<i8>) -> !fir.ref<i32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          .
          .
          .
         31:  %c0_1 = arith.constant 0 : index 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         32:  %11 = fir.coordinate_of %10, %c0_1 : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         33:  %12 = fir.convert %11 : (!fir.ref<i8>) -> !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         34:  %13 = fir.load %8 : !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         35:  %14 = fir.load %12 : !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         36:  %15 = arith.addf %13, %14 : f32 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dag:42'1                     ?                 possible intended match
         37:  %16 = fir.load %3 : !fir.ref<i32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         38:  %17 = fir.convert %16 : (i32) -> f32 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         39:  %18 = arith.addf %15, %17 : f32 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         40:  fir.store %18 to %4 : !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         41:  %19 = fir.load %4 : !fir.ref<f32> 
dag:42'0     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          .
          .
          .
>>>>>>

--

********************

That looks weird. I’ll try to reproduce but so far I do not have this failure on my side.

[clementval]

Update test module name to avoid collision.

[clementval]

@PeteSteinfeld The problem was coming from a collision between the module names. The module in flang/test/Lower/select-type.f90 was m1 and also in the tests checking for module use.

[jeanPerier]

Mostly questions to clarify what is final and what will change in the future mapping (given the tests, I expect array are not intended to be covered here, and most of my questions are about this). Looks great otherwise.

flang/lib/Lower/Bridge.cpp

2120

This will hopefully get a bit simpler in the future with the updated lowering, but I think getExprAddr might not be the right thing to call since I believe that it would cause assumed shape polymorphic to be copied into a contiguous temp... genExprBox might be what is needed here instead.
genExprBox will cause POINTER/ALLOCATABLEs to be dereferenced, but as I understand from the standard, this is not an issue in SELECT TYPE since the associated entity does not have the POINTER/ALLOCATABLE attributes as per 11.1.3.3.

2206

That's a clever way to find the scope !

2214

You may be aware of this since you mention more needs to be done for the mapping, but the lower bounds may be incorrect since they are dropped on the floor whenever going from from an fir::ExtendedValue to an mlir::Value via fir::getBase(). You would need to keep the selector as a fir::ExtendedValue to keep them.

2215

nit: extra braces around the if (except if you wanted to add a break;) and for

2231

This only makes sense if the variable is a scalar, right ? Is the array part planned in another patch ?

2241

Don't you need to convert to a more refined class type here too ?

[clementval]

In D137728#3919360, @jeanPerier wrote:

Mostly questions to clarify what is final and what will change in the future mapping (given the tests, I expect array are not intended to be covered here, and most of my questions are about this). Looks great otherwise.

Thanks for the review. I'll update the patch today. As you mentioned, array are not covered yet in this patch.

flang/lib/Lower/Bridge.cpp

2120

Good to know. I'll update that.

2214

Yes, array are not supported yet.

2231

Yes. For array there is more work needed and we will likely keep the descriptor around.

2241

I did not see any use cases where it would be useful but I might when I can run more tests on this.

[jeanPerier]

flang/lib/Lower/Bridge.cpp

2241

Isn't it needed if there is an access to one of the type guard's type component that is not a component of the selector type ?

I expect lowering would have troubles issuing a fir.coordinate for a field if it is not part of the static type of the base.

module test
type t1
 integer :: i
end type
type, extends(t1) :: t2
  integer :: j
end type
contains
subroutine print_if_has_j(a)
  class(t1) :: a
  select type (a)
  class is (t2)
    print *, a%j
  class default
    print *, "has no j member"
  end select
end subroutine
end module

[clementval]

Address review comments

flang/lib/Lower/Bridge.cpp

2241

Correct. Updated.

[clementval]

Fix exit with no default

[jeanPerier]

LGTM

flang/include/flang/Optimizer/Builder/BoxValue.h

public:
   unsigned rank() const {
     return match([](const fir::UnboxedValue &box) -> unsigned { return 0; },
                  [](const fir::CharBoxValue &box) -> unsigned { return 0; },
                  [](const fir::ProcBoxValue &box) -> unsigned { return 0; },
                  [](const fir::PolymorphicValue &box) -> unsigned { return 0; },
                  [](const auto &box) -> unsigned { return box.rank(); });
   }
 
+  bool isPolymorphic() const {
+    return match([](const fir::PolymorphicValue &box) -> bool { return true; },
+                 [](const fir::ArrayBoxValue &box) -> bool {
+                   return box.getTdesc() ? true : false;
+                 },
+                 [](const auto &box) -> bool { return false; });
+  }
+
   /// Is this an assumed size array ?
   bool isAssumedSize() const;
 
   /// LLVM style debugging of extended values
   LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this << '\n'; }
 
   friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
                                        const ExtendedValue &);

flang/lib/Lower/Bridge.cpp

   void genFIR(const Fortran::parser::SelectRankStmt &) {
     TODO(toLocation(), "SelectRankStmt implementation");
   }
   void genFIR(const Fortran::parser::SelectRankCaseStmt &) {
     TODO(toLocation(), "SelectRankCaseStmt implementation");
   }
 
   void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) {
-    setCurrentPositionAt(selectTypeConstruct);
-    TODO(toLocation(), "SelectTypeConstruct implementation");
+    mlir::Location loc = toLocation();
+    mlir::MLIRContext *context = builder->getContext();
+    Fortran::lower::StatementContext stmtCtx;
+    fir::ExtendedValue selector;
+    llvm::SmallVector<mlir::Attribute> attrList;
+    llvm::SmallVector<mlir::Block *> blockList;
+    unsigned typeGuardIdx = 0;
+    bool hasLocalScope = false;
+
+    for (Fortran::lower::pft::Evaluation &eval :
+         getEval().getNestedEvaluations()) {
+      if (auto *selectTypeStmt =
+              eval.getIf<Fortran::parser::SelectTypeStmt>()) {
+        // Retrieve the selector
+        const auto &s = std::get<Fortran::parser::Selector>(selectTypeStmt->t);
+        if (const auto *v = std::get_if<Fortran::parser::Variable>(&s.u))
+          selector = genExprBox(loc, *Fortran::semantics::GetExpr(*v), stmtCtx);
+        else
+          fir::emitFatalError(
+              loc, "selector with expr not expected in select type statement");
+
+        // Going through the controlSuccessor first to create the
+        // fir.select_type operation.
+        mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block;
+        for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;
+             e = e->controlSuccessor) {
+          const auto &typeGuardStmt =
+              e->getIf<Fortran::parser::TypeGuardStmt>();
+          const auto &guard =
+              std::get<Fortran::parser::TypeGuardStmt::Guard>(typeGuardStmt->t);
+          assert(e->block && "missing TypeGuardStmt block");
+          // CLASS DEFAULT
+          if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {
+            defaultBlock = e->block;
+            continue;
+          }
+
+          blockList.push_back(e->block);
+          if (const auto *typeSpec =
+                  std::get_if<Fortran::parser::TypeSpec>(&guard.u)) {
+            // TYPE IS
+            mlir::Type ty;
+            if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(
+                    typeSpec->u)) {
+              const Fortran::semantics::IntrinsicTypeSpec *intrinsic =
+                  typeSpec->declTypeSpec->AsIntrinsic();
+              int kind =
+                  Fortran::evaluate::ToInt64(intrinsic->kind()).value_or(kind);
+              llvm::SmallVector<Fortran::lower::LenParameterTy> params;
+              if (intrinsic->category() ==
+                      Fortran::common::TypeCategory::Character ||
+                  intrinsic->category() ==
+                      Fortran::common::TypeCategory::Derived)
+                TODO(loc, "typeSpec with length parameters");
+              ty = genType(intrinsic->category(), kind, params);
+            } else {
+              const Fortran::semantics::DerivedTypeSpec *derived =
+                  typeSpec->declTypeSpec->AsDerived();
+              ty = genType(*derived);
+            }
+            attrList.push_back(fir::ExactTypeAttr::get(ty));
+          } else if (const auto *derived =
+                         std::get_if<Fortran::parser::DerivedTypeSpec>(
+                             &guard.u)) {
+            // CLASS IS
+            assert(derived->derivedTypeSpec && "derived type spec is null");
+            mlir::Type ty = genType(*(derived->derivedTypeSpec));
+            attrList.push_back(fir::SubclassAttr::get(ty));
+          }
+        }
+        attrList.push_back(mlir::UnitAttr::get(context));
+        blockList.push_back(defaultBlock);
+        builder->create<fir::SelectTypeOp>(loc, fir::getBase(selector),
+                                           attrList, blockList);
+      } else if (auto *typeGuardStmt =
+                     eval.getIf<Fortran::parser::TypeGuardStmt>()) {
+        // Map the type guard local symbol for the selector to a more precise
+        // typed entity in the TypeGuardStmt when necessary.
+        const auto &guard =
+            std::get<Fortran::parser::TypeGuardStmt::Guard>(typeGuardStmt->t);
+        if (hasLocalScope)
+          localSymbols.popScope();
+        localSymbols.pushScope();
+        hasLocalScope = true;
+        assert(attrList.size() >= typeGuardIdx &&
+               "TypeGuard attribute missing");
+        mlir::Attribute typeGuardAttr = attrList[typeGuardIdx];
+        mlir::Block *typeGuardBlock = blockList[typeGuardIdx];
+        const Fortran::semantics::Scope &guardScope =
+            bridge.getSemanticsContext().FindScope(eval.position);
+        mlir::OpBuilder::InsertPoint crtInsPt = builder->saveInsertionPoint();
+        builder->setInsertionPointToStart(typeGuardBlock);
+
+        auto addAssocEntitySymbol = [&](fir::ExtendedValue exv) {
+          for (auto &symbol : guardScope.GetSymbols()) {
+            if (symbol->GetUltimate()
+                    .detailsIf<Fortran::semantics::AssocEntityDetails>()) {
+              localSymbols.addSymbol(symbol, exv);
+              break;
             }
-  void genFIR(const Fortran::parser::SelectTypeStmt &) {
-    TODO(toLocation(), "SelectTypeStmt implementation");
           }
-  void genFIR(const Fortran::parser::TypeGuardStmt &) {
-    TODO(toLocation(), "TypeGuardStmt implementation");
+        };
+
+        if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {
+          // CLASS DEFAULT
+          addAssocEntitySymbol(selector);
+        } else if (const auto *typeSpec =
+                       std::get_if<Fortran::parser::TypeSpec>(&guard.u)) {
+          // TYPE IS
+          fir::ExactTypeAttr attr =
+              typeGuardAttr.dyn_cast<fir::ExactTypeAttr>();
+          mlir::Value exactValue;
+          if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(
+                  typeSpec->u)) {
+            exactValue = builder->create<fir::BoxAddrOp>(
+                loc, fir::ReferenceType::get(attr.getType()),
+                fir::getBase(selector));
+          } else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(
+                         typeSpec->u)) {
+            exactValue = builder->create<fir::ConvertOp>(
+                loc, fir::BoxType::get(attr.getType()), fir::getBase(selector));
+          }
+          addAssocEntitySymbol(exactValue);
+        } else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(
+                       guard.u)) {
+          // CLASS IS
+          fir::SubclassAttr attr = typeGuardAttr.dyn_cast<fir::SubclassAttr>();
+          mlir::Value derived = builder->create<fir::ConvertOp>(
+              loc, fir::ClassType::get(attr.getType()), fir::getBase(selector));
+          addAssocEntitySymbol(derived);
+        }
+        builder->restoreInsertionPoint(crtInsPt);
+        ++typeGuardIdx;
+      } else if (eval.getIf<Fortran::parser::EndSelectStmt>()) {
+        if (hasLocalScope)
+          localSymbols.popScope();
+        stmtCtx.finalize();
+      }
+      genFIR(eval);
+    }
   }
 
   //===--------------------------------------------------------------------===//
   // IO statements (see io.h)
   //===--------------------------------------------------------------------===//
 
   void genFIR(const Fortran::parser::BackspaceStmt &stmt) {
     mlir::Value iostat = genBackspaceStatement(*this, stmt);
#endif
   void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {} // nop
   void genFIR(const Fortran::parser::EndSelectStmt &) {}       // nop
   void genFIR(const Fortran::parser::EndSubroutineStmt &) {}   // nop
   void genFIR(const Fortran::parser::EntryStmt &) {}           // nop
   void genFIR(const Fortran::parser::IfStmt &) {}              // nop
   void genFIR(const Fortran::parser::IfThenStmt &) {}          // nop
   void genFIR(const Fortran::parser::NonLabelDoStmt &) {}      // nop
   void genFIR(const Fortran::parser::OmpEndLoopDirective &) {} // nop
+  void genFIR(const Fortran::parser::SelectTypeStmt &) {}      // nop
+  void genFIR(const Fortran::parser::TypeGuardStmt &) {}       // nop
 
   void genFIR(const Fortran::parser::NamelistStmt &) {
     TODO(toLocation(), "NamelistStmt lowering");
   }
 
   /// Generate FIR for the Evaluation `eval`.
   void genFIR(Fortran::lower::pft::Evaluation &eval,
               bool unstructuredContext = true) {

flang/lib/Lower/ConvertExpr.cpp

private:
   }
 
   /// Convert the original value, \p origVal, to type \p eleTy. When in a
   /// pointer assignment context, generate an appropriate `fir.rebox` for
   /// dealing with any bounds parameters on the pointer assignment.
   mlir::Value convertElementForUpdate(mlir::Location loc, mlir::Type eleTy,
                                       mlir::Value origVal) {
     if (auto origEleTy = fir::dyn_cast_ptrEleTy(origVal.getType()))
-      if (origEleTy.isa<fir::BoxType>()) {
+      if (origEleTy.isa<fir::BaseBoxType>()) {
         // If origVal is a box variable, load it so it is in the value domain.
         origVal = builder.create<fir::LoadOp>(loc, origVal);
       }
     if (origVal.getType().isa<fir::BoxType>() && !eleTy.isa<fir::BoxType>()) {
       if (isPointerAssignment())
         TODO(loc, "lhs of pointer assignment returned unexpected value");
       TODO(loc, "invalid box conversion in elemental computation");
     }
if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
     fir::ExtendedValue result =
         Fortran::lower::createSomeArrayBox(converter, expr, symMap, stmtCtx);
     if (isParentComponent(expr))
       result = updateBoxForParentComponent(converter, result, expr);
     return result;
   }
   fir::ExtendedValue addr = Fortran::lower::createSomeExtendedAddress(
       loc, converter, expr, symMap, stmtCtx);
-  fir::ExtendedValue result =
-      fir::BoxValue(converter.getFirOpBuilder().createBox(loc, addr));
+  fir::ExtendedValue result = fir::BoxValue(
+      converter.getFirOpBuilder().createBox(loc, addr, addr.isPolymorphic()));
   if (isParentComponent(expr))
     result = updateBoxForParentComponent(converter, result, expr);
   return result;
 }
 
 mlir::Value Fortran::lower::createSubroutineCall(
     AbstractConverter &converter, const evaluate::ProcedureRef &call,
     ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,

flang/lib/Lower/SymbolMap.cpp

void Fortran::lower::SymMap::addSymbol(Fortran::semantics::SymbolRef sym,
                                        const fir::ExtendedValue &exv,
                                        bool force) {
   exv.match([&](const fir::UnboxedValue &v) { addSymbol(sym, v, force); },
             [&](const fir::CharBoxValue &v) { makeSym(sym, v, force); },
             [&](const fir::ArrayBoxValue &v) { makeSym(sym, v, force); },
             [&](const fir::CharArrayBoxValue &v) { makeSym(sym, v, force); },
             [&](const fir::BoxValue &v) { makeSym(sym, v, force); },
             [&](const fir::MutableBoxValue &v) { makeSym(sym, v, force); },
+            [&](const fir::PolymorphicValue &v) { makeSym(sym, v, force); },
             [](auto) {
               llvm::report_fatal_error("value not added to symbol table");
             });
 }
 
 Fortran::lower::SymbolBox toSymbolBox(
     std::variant<Fortran::lower::SymbolBox, fir::FortranVariableOpInterface>
         symboxOrdefiningOp) {

flang/test/Lower/select-type.f90

+! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
+
+module select_type_lower_test
+  type p1
+    integer :: a
+    integer :: b
+  end type
+
+  type, extends(p1) :: p2
+    integer :: c
+  end type
+
+  type, extends(p1) :: p3(k)
+    integer, kind :: k
+    real(k) :: r
+  end type
+
+contains
+
+  function get_class()
+    class(p1), pointer :: get_class
+  end function
+  
+  subroutine select_type1(a)
+    class(p1), intent(in) :: a
+
+    select type (a)
+    type is (p1)
+      print*, 'type is p1'
+    class is (p1)
+      print*, 'class is p1'
+    class is (p2)
+      print*, 'class is p2', a%c
+    class default
+      print*,'default'
+    end select
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type1(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>> {fir.bindc_name = "a"})
+
+! CHECK: fir.select_type %[[ARG0]] : !fir.class<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>
+! CHECK-SAME: [#fir.type_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^[[TYPE_IS_BLK:.*]], #fir.class_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^[[CLASS_IS_P1_BLK:.*]], #fir.class_is<!fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}>>, ^[[CLASS_IS_P2_BLK:.*]], unit, ^[[DEFAULT_BLOCK:.*]]]
+! CHECK: ^[[TYPE_IS_BLK]]
+! CHECK: ^[[CLASS_IS_P1_BLK]]
+! CHECK: ^[[CLASS_IS_P2_BLK]]
+! CHECK: %[[P2:.*]] = fir.convert %[[ARG0:.*]] : (!fir.class<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>) -> !fir.class<!fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}>>
+! CHECK: %[[FIELD:.*]] = fir.field_index c, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}>
+! CHECK: %{{.*}} = fir.coordinate_of %[[P2]], %[[FIELD]] : (!fir.class<!fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}>>, !fir.field) -> !fir.ref<i32>
+! CHECK: ^[[DEFAULT_BLOCK]]
+
+  subroutine select_type2()
+    select type (a => get_class())
+    type is (p1)
+      print*, 'type is p1'
+    class is (p1)
+      print*, 'class is p1'
+    class default
+      print*,'default'
+    end select
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type2()
+! CHECK: %[[RESULT:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>> {bindc_name = ".result"}
+! CHECK: %[[FCTCALL:.*]] = fir.call @_QMselect_type_lower_testPget_class() : () -> !fir.class<!fir.ptr<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>
+! CHECK: fir.save_result %[[FCTCALL]] to %[[RESULT]] : !fir.class<!fir.ptr<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>, !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>>
+! CHECK: %[[SELECTOR:.*]] = fir.load %[[RESULT]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>>
+! CHECK: fir.select_type %[[SELECTOR]] : !fir.class<!fir.ptr<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>
+! CHECK-SAME: [#fir.type_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^[[TYPE_IS_BLK:.*]], #fir.class_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^[[CLASS_IS_BLK:.*]], unit, ^[[DEFAULT_BLK:.*]]]
+! CHECK: ^[[TYPE_IS_BLK]]
+! CHECK: ^[[CLASS_IS_BLK]]
+! CHECK: ^[[DEFAULT_BLK]]
+
+  subroutine select_type3(a)
+    class(p1), pointer, intent(in) :: a(:)
+
+    select type (x => a(1))
+    type is (p1)
+      print*, 'type is p1'
+    class is (p1)
+      print*, 'class is p1'
+    class default
+      print*,'default'
+    end select
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type3(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>>> {fir.bindc_name = "a"})
+! CHECK: %[[ARG0_LOAD:.*]] = fir.load %[[ARG0]] : !fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>>>
+! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[ARG0_LOAD]], %{{.*}} : (!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>>, i64) -> !fir.ref<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>
+! CHECK: %[[TDESC:.*]] = fir.box_tdesc %[[ARG0_LOAD]] : (!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>>) -> !fir.tdesc<none>
+! CHECK: %[[SELECTOR:.*]] = fir.embox %[[COORD]] tdesc %[[TDESC]] : (!fir.ref<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, !fir.tdesc<none>) -> !fir.class<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>
+! CHECK: fir.select_type %[[SELECTOR]] : !fir.class<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>
+! CHECK-SAME: [#fir.type_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^[[TYPE_IS_BLK:.*]], #fir.class_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^[[CLASS_IS_BLK:.*]], unit, ^[[DEFAULT_BLK:.*]]]
+! CHECK: ^[[TYPE_IS_BLK]]
+! CHECK: ^[[CLASS_IS_BLK]]
+! CHECK: ^[[DEFAULT_BLK]]
+
+  subroutine select_type4(a)
+    class(p1), intent(in) :: a
+    select type(a)
+    type is(p3(8))
+      print*, 'type is p3(8)'
+    type is(p3(4))
+      print*, 'type is p3(4)'
+    class is (p1)
+      print*, 'class is p1'
+    end select
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type4(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>> {fir.bindc_name = "a"})
+! CHECK: fir.select_type %[[ARG0]] : !fir.class<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>
+! CHECK-SAME: [#fir.type_is<!fir.type<_QMselect_type_lower_testTp3K8{a:i32,b:i32,r:f64}>>, ^[[P3_8:.*]], #fir.type_is<!fir.type<_QMselect_type_lower_testTp3K4{a:i32,b:i32,r:f32}>>, ^[[P3_4:.*]], #fir.class_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^[[P1:.*]], unit, ^[[EXIT:.*]]]
+! CHECK: ^[[P3_8]]
+! CHECK: ^[[P3_4]]
+! CHECK: ^[[P1]]
+! CHECK: ^[[EXIT]]
+
+  subroutine select_type5(a)
+    class(*), intent(in) :: a
+
+    select type (x => a)
+    type is (integer(1))
+      print*, 'type is integer(1)'
+    type is (integer(4))
+      print*, 'type is integer(4)'
+    type is (real(4))
+      print*, 'type is real'
+    type is (logical)
+      print*, 'type is logical'
+    class default
+      print*,'default'
+    end select
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type5(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<none> {fir.bindc_name = "a"})
+! CHECK: fir.select_type %[[ARG0]] : !fir.class<none>
+! CHECK-SAME: [#fir.type_is<i8>, ^[[I8_BLK:.*]], #fir.type_is<i32>, ^[[I32_BLK:.*]], #fir.type_is<f32>, ^[[F32_BLK:.*]], #fir.type_is<!fir.logical<4>>, ^[[LOG_BLK:.*]], unit, ^[[DEFAULT:.*]]] 
+! CHECK: ^[[I8_BLK]]
+! CHECK: ^[[I32_BLK]]
+! CHECK: ^[[F32_BLK]]
+! CHECK: ^[[LOG_BLK]]
+! CHECK: ^[[DEFAULT_BLOCK]]
+
+
+  subroutine select_type6(a)
+    class(*), intent(out) :: a
+
+    select type(a)
+    type is (integer)
+      a = 100
+    type is (real)
+      a = 2.0
+    class default
+      stop 'error'
+    end select
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type6(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<none> {fir.bindc_name = "a"})
+
+! CHECK: fir.select_type %[[ARG0]] : !fir.class<none> [#fir.type_is<i32>, ^[[INT_BLK:.*]], #fir.type_is<f32>, ^[[REAL_BLK:.*]], unit, ^[[DEFAULT_BLK:.*]]]
+! CHECK: ^[[INT_BLK]]
+! CHECK:  %[[BOX_ADDR:.*]] = fir.box_addr %[[ARG0]] : (!fir.class<none>) -> !fir.ref<i32>
+! CHECK:  %[[C100:.*]] = arith.constant 100 : i32
+! CHECK:  fir.store %[[C100]] to %[[BOX_ADDR]] : !fir.ref<i32>
+
+! CHECK: ^[[REAL_BLK]]:  // pred: ^bb0
+! CHECK:  %[[BOX_ADDR:.*]] = fir.box_addr %[[ARG0]] : (!fir.class<none>) -> !fir.ref<f32>
+! CHECK:  %[[C2:.*]] = arith.constant 2.000000e+00 : f32
+! CHECK:  fir.store %[[C2]] to %[[BOX_ADDR]] : !fir.ref<f32>
+
+end module
+
+