[flang] Handle expression in SELECT TYPE selector

[clementval]

Summary

Expression in selector were raising an error. In some
cases expression can be found in selector. This patch
updates the code to accept expression and adds a lowering
test.

[PeteSteinfeld]

All builds and tests correctly and looks good.

[vdonaldson]

flang/lib/Lower/Bridge.cpp

2207

Could the expression generate a temp that requires deallocation?

[vdonaldson]

To add some detail - if an expression includes a function call that returns memory, the memory needs to be freed. And since the construct could have an early exit, the normal exit cleanup might not be invoked. That can be accommodated by immediately finalizing stmtCtx.

[vdonaldson]

We can delay dealing with rare early-exit cases until we have general code for handling them, which should be fairly soon. So this code is ok as is for now.

[clementval]

flang/lib/Lower/Bridge.cpp

2207

There is likely some cases where we need it. Since creation of polymorphic temporary is currently a TODO let's do it at the same time.

flang/lib/Lower/Bridge.cpp

for (Fortran::lower::pft::Evaluation &eval :
       if (auto *selectTypeStmt =
               eval.getIf<Fortran::parser::SelectTypeStmt>()) {
         // A genFIR(SelectTypeStmt) call would have unwanted side effects.
         maybeStartBlock(eval.block);
         // 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");
+        else if (const auto *e = std::get_if<Fortran::parser::Expr>(&s.u))
+          selector = genExprBox(loc, *Fortran::semantics::GetExpr(*e), stmtCtx);
 
         // 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>();

flang/test/Lower/select-type.f90

type, extends(p1) :: p3(k)
     integer, kind :: k
     real(k) :: r
   end type
 
   type, extends(p2) :: p4
     integer :: d
   end type
 
+  type :: p5
+    integer :: a
+  contains
+    procedure :: negate
+    generic :: operator(-) => negate
+  end type
+
 contains
 
   function get_class()
     class(p1), pointer :: get_class
   end function
-  
+  function negate(this)
+    class(p5), intent(in) :: this
+    class(p5), allocatable :: negate
+    allocate(negate, source=this)
+    negate%a = -this%a
+  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'
select type(a)
         end select
       class default
         print*,a%a
     end select
   end subroutine
 
   ! Just makes sure the example can be lowered.
   ! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type14
-   
+  subroutine select_type15(a)
+    class(p5) :: a
+
+    select type(x => -a)
+      type is (p5)
+        print*, x%a
+    end select
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type15(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<!fir.type<_QMselect_type_lower_testTp5{a:i32}>> {fir.bindc_name = "a"}) {
+! CHECK: %[[RES:.*]] = fir.alloca !fir.class<!fir.heap<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>> {bindc_name = ".result"}
+! CHECK: %[[TMP_RES:.*]] = fir.dispatch "negate"(%[[ARG0]] : !fir.class<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>) (%[[ARG0]] : !fir.class<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>) -> !fir.class<!fir.heap<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>> {pass_arg_pos = 0 : i32}
+! CHECK: fir.save_result %[[TMP_RES]] to %[[RES]] : !fir.class<!fir.heap<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>>, !fir.ref<!fir.class<!fir.heap<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>>>
+! CHECK: %[[LOAD_RES:.*]] = fir.load %[[RES]] : !fir.ref<!fir.class<!fir.heap<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>>>
+! CHECK: fir.select_type %[[LOAD_RES]] : !fir.class<!fir.heap<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>> [#fir.type_is<!fir.type<_QMselect_type_lower_testTp5{a:i32}>>, ^bb1, unit, ^bb2]
+
 end module
 
 program test_select_type
   use select_type_lower_test
 
   integer :: a
   integer :: arr(2)
   real :: b