[flang-commits] [flang] f5cca3c - [flang] Handle expression in SELECT TYPE selector

[Valentin Clement via flang-commits]

Author: Valentin Clement
Date: 2023-02-16T21:00:53+01:00
New Revision: f5cca3c5ce7a1a6d9934e22c60e47ccd1834cf99

URL: https://github.com/llvm/llvm-project/commit/f5cca3c5ce7a1a6d9934e22c60e47ccd1834cf99
DIFF: https://github.com/llvm/llvm-project/commit/f5cca3c5ce7a1a6d9934e22c60e47ccd1834cf99.diff

LOG: [flang] Handle expression in SELECT TYPE selector

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.

Reviewed By: PeteSteinfeld, vdonaldson

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

Added: 
    

Modified: 
    flang/lib/Lower/Bridge.cpp
    flang/test/Lower/select-type.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 717bdeccd5572..0a2cf3ca3ec30 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -2203,9 +2203,8 @@ class FirConverter : public Fortran::lower::AbstractConverter {
         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.

diff  --git a/flang/test/Lower/select-type.f90 b/flang/test/Lower/select-type.f90
index b58518500cdeb..3463cda4e9a94 100644
--- a/flang/test/Lower/select-type.f90
+++ b/flang/test/Lower/select-type.f90
@@ -19,11 +19,25 @@ module select_type_lower_test
     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
@@ -772,7 +786,24 @@ subroutine select_type14(a, b)
 
   ! 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