[flang-commits] [flang] a459a24 - [flang] Fix SELECT TYPE lowering when CLASS DEFAULT is not the last type guard

[Valentin Clement via flang-commits]

Author: Valentin Clement
Date: 2023-01-19T17:32:31+01:00
New Revision: a459a2485b54fbd9e1f8a48061e79cdcd12b12a5

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

LOG: [flang] Fix SELECT TYPE lowering when CLASS DEFAULT is not the last type guard

CLASS DEFAULT needs to be the last attribute when fir.select_type op is created.
It needs to be at its actual position in the Fortran code when the TypeGuardStmt
are processed. The current lowering was crashing when CLASS DEFAULT was not at
the last position.
This patch fixes the issue by tracking the actual position of the CLASS DEFAULT
type guard and set it at the correct position after the fir.select_type op
is created.

Reviewed By: jeanPerier, PeteSteinfeld

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

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 71e06ed347cd..9e5898e9db0e 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -2133,6 +2133,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
     llvm::SmallVector<mlir::Attribute> attrList;
     llvm::SmallVector<mlir::Block *> blockList;
     unsigned typeGuardIdx = 0;
+    std::size_t defaultAttrPos = std::numeric_limits<size_t>::max();
     bool hasLocalScope = false;
 
     for (Fortran::lower::pft::Evaluation &eval :
@@ -2162,6 +2163,9 @@ class FirConverter : public Fortran::lower::AbstractConverter {
           // CLASS DEFAULT
           if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {
             defaultBlock = e->block;
+            // Keep track of the actual position of the CLASS DEFAULT type guard
+            // in the SELECT TYPE construct.
+            defaultAttrPos = attrList.size();
             continue;
           }
 
@@ -2197,6 +2201,21 @@ class FirConverter : public Fortran::lower::AbstractConverter {
         blockList.push_back(defaultBlock);
         builder->create<fir::SelectTypeOp>(loc, fir::getBase(selector),
                                            attrList, blockList);
+
+        // If the actual position of CLASS DEFAULT type guard is not the last
+        // one, it needs to be put back at its correct position for the rest of
+        // the processing. TypeGuardStmt are processed in the same order they
+        // appear in the Fortran code.
+        if (defaultAttrPos < attrList.size() - 1) {
+          auto attrIt = attrList.begin();
+          attrIt = attrIt + defaultAttrPos;
+          auto blockIt = blockList.begin();
+          blockIt = blockIt + defaultAttrPos;
+          attrList.insert(attrIt, mlir::UnitAttr::get(context));
+          blockList.insert(blockIt, defaultBlock);
+          attrList.pop_back();
+          blockList.pop_back();
+        }
       } else if (auto *typeGuardStmt =
                      eval.getIf<Fortran::parser::TypeGuardStmt>()) {
         // Map the type guard local symbol for the selector to a more precise

diff  --git a/flang/test/Lower/select-type.f90 b/flang/test/Lower/select-type.f90
index 23f60cd7cc36..846758281be8 100644
--- a/flang/test/Lower/select-type.f90
+++ b/flang/test/Lower/select-type.f90
@@ -722,6 +722,40 @@ subroutine select_type12(a)
 ! CHECK: ^bb{{.*}}:  // pred: ^bb0
 ! CHECK:  %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class<!fir.array<?x!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>>) -> !fir.box<!fir.array<?x!fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}>>>
 
+
+  ! Test correct lowering when CLASS DEFAULT is not at the last position in the
+  ! SELECT TYPE construct.
+  subroutine select_type13(a)
+    class(p1), pointer :: a(:)
+    select type (a)
+      class default
+        print*, 'default'
+      class is (p1)
+        print*, 'class'
+    end select
+
+    select type (a)
+      type is (p1)
+        print*, 'type'
+      class default
+        print*, 'default'
+      class is (p1)
+        print*, 'class'
+    end select
+
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type13
+! CHECK: fir.select_type %{{.*}} : !fir.class<!fir.array<?x!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>> [#fir.class_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^bb2, unit, ^bb1]
+! CHECK: ^bb1:
+! CHECK: ^bb2:
+! CHECK: ^bb3:
+! CHECK: fir.select_type %{{.*}} : !fir.class<!fir.array<?x!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>> [#fir.type_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^bb4, #fir.class_is<!fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}>>, ^bb6, unit, ^bb5]
+! CHECK: ^bb4:
+! CHECK: ^bb5:
+! CHECK: ^bb6:
+! CHECK: ^bb7:
+
 end module
 
 program test_select_type