From a98b031e4f38520dbf53c2f25efac6c4dd77d0b5 Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier@nvidia.com>
Date: Tue, 28 Feb 2023 14:11:39 +0100
Subject: [PATCH] [flang][hlfir] Support type bound procedure in type
 descriptors

In hlfir, procedure designators are propagated as fir.box_proc.
Derived type descriptors are compiler generated constant structure
constructors. They contain CFPTR components for the type bound
procedure addresses.
Before being cast to an integer type so that they can be stored
in the CFPTR components, the fir.box_proc addresses must be
obtained with a fir.box_addr.

Differential Revision: https://reviews.llvm.org/D144952
---
 flang/lib/Lower/ConvertConstant.cpp              |  2 ++
 flang/test/Lower/HLFIR/type-bound-proc-tdesc.f90 | 31 ++++++++++++++++++++++++
 2 files changed, 33 insertions(+)
 create mode 100644 flang/test/Lower/HLFIR/type-bound-proc-tdesc.f90

diff --git a/flang/lib/Lower/ConvertConstant.cpp b/flang/lib/Lower/ConvertConstant.cpp
index 331aa7e7..a391d71 100644
--- a/flang/lib/Lower/ConvertConstant.cpp
+++ b/flang/lib/Lower/ConvertConstant.cpp
@@ -374,6 +374,8 @@ static mlir::Value genInlinedStructureCtorLitImpl(
         // The Ev::Expr returned is an initializer that is a pointer (e.g.,
         // null) that must be inserted into an intermediate cptr record
         // value's address field, which ought to be an intptr_t on the target.
+        if (addr.getType().isa<fir::BoxProcType>())
+          addr = builder.create<fir::BoxAddrOp>(loc, addr);
         assert((fir::isa_ref_type(addr.getType()) ||
                 addr.getType().isa<mlir::FunctionType>()) &&
                "expect reference type for address field");
diff --git a/flang/test/Lower/HLFIR/type-bound-proc-tdesc.f90 b/flang/test/Lower/HLFIR/type-bound-proc-tdesc.f90
new file mode 100644
index 0000000..fed2097
--- /dev/null
+++ b/flang/test/Lower/HLFIR/type-bound-proc-tdesc.f90
@@ -0,0 +1,31 @@
+! Test lowering of type bound procedure in the derived type descriptors (that
+! are compiler generated constant structure constructors).
+! RUN: bbc -emit-fir -hlfir -o - %s | FileCheck %s
+
+module type_bound_proc_tdesc
+  type :: t
+  contains
+    procedure, nopass :: simple => simple_impl
+    procedure, nopass :: return_char => return_char_impl
+  end type
+
+interface
+  function return_char_impl()
+    character(10) :: return_char_impl
+  end function
+  subroutine simple_impl()
+  end subroutine
+end interface
+end
+  use type_bound_proc_tdesc
+  type(t) :: a
+end
+
+! CHECK-LABEL: fir.global {{.*}} @_QMtype_bound_proc_tdescE.v.t
+! CHECK:  fir.address_of(@_QPreturn_char_impl) : (!fir.ref<!fir.char<1,10>>, index) -> !fir.boxchar<1>
+! CHECK:  %[[VAL_8:.*]] = fir.extract_value %{{.*}}, [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK:  fir.box_addr %[[VAL_8]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! ...
+! CHECK:  %[[VAL_25:.*]] = fir.address_of(@_QPsimple_impl) : () -> ()
+! CHECK:  %[[VAL_26:.*]] = fir.emboxproc %[[VAL_25]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:  fir.box_addr %[[VAL_26]] : (!fir.boxproc<() -> ()>) -> (() -> ())
-- 
2.7.4