[flang-commits] [flang] [Flang] Support for passing procedure pointer, reference to a function that returns a procedure pointer to structure constructor. (PR #86533)

[Daniel Chen via flang-commits]

https://github.com/DanielCChen created https://github.com/llvm/llvm-project/pull/86533

This PR fixes `not yet implemented: procedure pointer component in structure constructor` as shown in the following test case.

```
  MODULE M
    TYPE :: DT
      PROCEDURE(Fun), POINTER, NOPASS :: pp1
    END TYPE

    CONTAINS

    INTEGER FUNCTION Fun(Arg)
    INTEGER :: Arg
      Fun = Arg
    END FUNCTION

  END MODULE

  PROGRAM MAIN
  USE M
  IMPLICIT NONE
  TYPE (DT) :: v2
  PROCEDURE(FUN), POINTER :: pp2
  v2 = DT(pp2)
  v2 = DT(bar())
  CONTAINS
    FUNCTION BAR() RESULT(res)
      PROCEDURE(FUN), POINTER :: res
    END
  END
  ```

>From b16110f4130f172c29f47ee62c6e018f6ff34445 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 25 Mar 2024 13:07:48 -0400
Subject: [PATCH] [Flang] Support for passing procedure pointer, reference to a
 function that returns a procedure pointer to structure constructor.

---
 flang/lib/Lower/ConvertExprToHLFIR.cpp        |  8 +++--
 ...ointer-component-structure-constructor.f90 | 29 +++++++++++++++++--
 2 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index fe5ce4b17b2587..b6bdf1b26a3407 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -1767,8 +1767,12 @@ class HlfirBuilder {
 
       if (attrs && bitEnumContainsAny(attrs.getFlags(),
                                       fir::FortranVariableFlagsEnum::pointer)) {
-        if (Fortran::semantics::IsProcedure(sym))
-          TODO(loc, "procedure pointer component in structure constructor");
+        if (Fortran::semantics::IsProcedure(sym)) {
+          hlfir::Entity rhs(getBase(Fortran::lower::convertExprToAddress(
+              loc, converter, expr, symMap, stmtCtx)));
+          builder.createStoreWithConvert(loc, rhs, lhs);
+          continue;
+        }
         // Pointer component construction is just a copy of the box contents.
         fir::ExtendedValue lhsExv =
             hlfir::translateToExtendedValue(loc, builder, lhs);
diff --git a/flang/test/Lower/HLFIR/procedure-pointer-component-structure-constructor.f90 b/flang/test/Lower/HLFIR/procedure-pointer-component-structure-constructor.f90
index f41c832ee5ec6a..7b64634d10d4b0 100644
--- a/flang/test/Lower/HLFIR/procedure-pointer-component-structure-constructor.f90
+++ b/flang/test/Lower/HLFIR/procedure-pointer-component-structure-constructor.f90
@@ -1,8 +1,8 @@
 ! Test passing
 !  1. NULL(),
 !  2. procedure,
-!  3. procedure pointer, (pending)
-!  4. reference to a function that returns a procedure pointer (pending)
+!  3. procedure pointer,
+!  4. reference to a function that returns a procedure pointer.
 ! to a derived type structure constructor.
 ! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
 
@@ -25,10 +25,33 @@ PROGRAM MAIN
   IMPLICIT NONE
   TYPE (DT), PARAMETER :: v1 = DT(NULL())
   TYPE (DT) :: v2
+  PROCEDURE(FUN), POINTER :: pp2
   v2 = DT(fun)
+  v2 = DT(pp2)
+  v2 = DT(bar())
+  CONTAINS
+    FUNCTION BAR() RESULT(res)
+      PROCEDURE(FUN), POINTER :: res
+    END
   END
 
-! CDHECK-LABEL:  fir.global internal @_QFECv1 constant : !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}> {
+! CHECK-LABEL:  func.func @_QQmain() attributes {fir.bindc_name = "main"} {
+! CHECK:    %[[VAL_0:.*]] = fir.alloca !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
+! CHECK:    %[[VAL_1:.*]] = fir.alloca !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
+! CHECK:    %[[VAL_2:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> i32> {bindc_name = "pp2", uniq_name = "_QFEpp2"}
+! CHECK:    %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_2]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFEpp2"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> i32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> i32>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> i32>>)
+! CHECK:    %[[VAL_17:.*]]:2 = hlfir.declare %[[VAL_1]] {uniq_name = "ctor.temp"} : (!fir.ref<!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>>) -> (!fir.ref<!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>>, !fir.ref<!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>>)
+! CHECK:    %[[VAL_23:.*]] = hlfir.designate %[[VAL_17]]#0{"pp1"}   {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> i32>>
+! CHECK:    %[[VAL_24:.*]] = fir.load %[[VAL_5]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> i32>>
+! CHECK:    fir.store %[[VAL_24]] to %[[VAL_23]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> i32>>
+! CHECK:    %[[VAL_25:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "ctor.temp"} : (!fir.ref<!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>>) -> (!fir.ref<!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>>, !fir.ref<!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>>)
+! CHECK:    %[[VAL_31:.*]] = hlfir.designate %[[VAL_25]]#0{"pp1"}   {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> i32>>
+! CHECK:    %[[VAL_32:.*]] = fir.call @_QFPbar() fastmath<contract> : () -> !fir.boxproc<(!fir.ref<i32>) -> i32>
+! CHECK:    fir.store %[[VAL_32]] to %[[VAL_31]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> i32>>
+! CHECK:    return
+! CHECK:  }
+
+! CHECK-LABEL:  fir.global internal @_QFECv1 constant : !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}> {
 ! CHECK:    %[[VAL_0:.*]] = fir.undefined !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
 ! CHECK:    %[[VAL_1:.*]] = fir.field_index pp1, !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
 ! CHECK:    %[[VAL_2:.*]] = fir.zero_bits (!fir.ref<i32>) -> i32