[flang] Handle dispatch on nopass procedure from array element

[clementval]

Summary

When a fir.dispatch is done with a NOPASS type-bound
procedure, the object in fir.dispatch is just used to gather the vtable.
Therefore, no transformation is done on it and the original entity
is used. The current code generation didn't expect the entity to be an array.
This patch update the code generation to be able to retrieve the vtable
accordingly.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Optimizer/CodeGen/CodeGen.cpp

struct DispatchOpConversion : public FIROpConversion<fir::DispatchOp> {
   matchAndRewrite(fir::DispatchOp dispatch, OpAdaptor adaptor,
                   mlir::ConversionPatternRewriter &rewriter) const override {
     mlir::Location loc = dispatch.getLoc();
 
     if (bindingTables.empty())
       return emitError(loc) << "no binding tables found";
 
     // Get derived type information.
-    auto declaredType = llvm::TypeSwitch<mlir::Type, mlir::Type>(
-                            dispatch.getObject().getType().getEleTy())
-                            .Case<fir::PointerType, fir::HeapType>(
-                                [](auto p) { return p.getEleTy(); })
-                            .Default([](mlir::Type t) { return t; });
-
+    auto declaredType =
+        llvm::TypeSwitch<mlir::Type, mlir::Type>(
+            .Case<fir::PointerType, fir::HeapType, fir::SequenceType>(
+                [](auto p) {
+                  if (auto seq =
+                          p.getEleTy().template dyn_cast<fir::SequenceType>())
+                    return seq.getEleTy();
+                  return p.getEleTy();
+                })
     assert(declaredType.isa<fir::RecordType>() && "expecting fir.type");
     auto recordType = declaredType.dyn_cast<fir::RecordType>();
     std::string typeDescName =
         fir::NameUniquer::getTypeDescriptorName(recordType.getName());
     std::string typeDescBindingTableName =
         fir::NameUniquer::getTypeDescriptorBindingTableName(
             recordType.getName());
 

flang/test/Fir/dispatch.f90

subroutine display_class(p)
     call p%display1()
     call p%aproc()
     i = p%get_value()
     call p%proc_with_values(2.5)
     call p%proc_nopass()
     call p%proc_pass(1)
   end subroutine
 
+  subroutine no_pass_array(a)
+    class(p1) :: a(:)
+    call a(1)%proc_nopass()
+  end subroutine
+
+  subroutine no_pass_array_allocatable(a)
+    class(p1), allocatable :: a(:)
+    call a(1)%proc_nopass()
+  end subroutine
+
+  subroutine no_pass_array_pointer(a)
+    class(p1), allocatable :: a(:)
+    call a(1)%proc_nopass()
+  end subroutine
+
 end module
 
 program test_type_to_class
   use dispatch1
   type(p1) :: t1 = p1(1,2)
   type(p2) :: t2 = p2(1,2,3)
 
   call display_class(t1)

 ! CHECK: %[[BINDING_BASE_ADDR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[DT]], 0
 ! CHECK: %[[BINDING_PTR:.*]] = getelementptr %_QM__fortran_type_infoTbinding, ptr %[[BINDING_BASE_ADDR]], i32 5
 ! CHECK: %[[LOADED_BINDING:.*]] = load %_QM__fortran_type_infoTbinding, ptr %[[BINDING_PTR]]
 ! CHECK: %[[BUILTIN_FUNC_PTR:.*]] = extractvalue %_QM__fortran_type_infoTbinding %[[LOADED_BINDING]], 0
 ! CHECK: %[[FUNC_ADDR:.*]] = extractvalue %_QM__fortran_builtinsT__builtin_c_funptr %[[BUILTIN_FUNC_PTR]], 0
 ! CHECK: %[[FUNC_PTR:.*]] = inttoptr i64 %[[FUNC_ADDR]] to ptr
 ! CHECK: call void %[[FUNC_PTR]](ptr %[[INT32]], ptr %[[CLASS]])
 
+! CHECK-LABEL: _QMdispatch1Pno_pass_array
+! CHECK-LABEL: _QMdispatch1Pno_pass_array_allocatable
+! CHECK-LABEL: _QMdispatch1Pno_pass_array_pointer
 
 ! Check the layout of the binding table. This is easier to do in FIR than in 
 ! LLVM IR.
 
 ! BT-LABEL: fir.global linkonce_odr @_QMdispatch1E.v.p1 constant target : !fir.array<7x!fir.type<_QM__fortran_type_infoTbinding{proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>,name:!fir.box<!fir.ptr<!fir.char<1,?>>>}>> {
 ! BT: %{{.*}} = fir.address_of(@_QMdispatch1Paproc) : (!fir.class<!fir.type<_QMdispatch1Tp1{a:i32,b:i32}>>) -> ()
 ! BT: %{{.*}} = fir.address_of(@_QMdispatch1Pdisplay1_p1) : (!fir.class<!fir.type<_QMdispatch1Tp1{a:i32,b:i32}>>) -> ()
 ! BT: %{{.*}} = fir.address_of(@_QMdispatch1Pdisplay2_p1) : (!fir.class<!fir.type<_QMdispatch1Tp1{a:i32,b:i32}>>) -> ()