[flang] fix passing characters to polymorphic array pointers

[jeanPerier]

The existing code failed to detect character array as being character because of the extra fir.array type indirection. Use fir::getFortranElementType for a more generic type handling.

Fixes #150749.

[llvmbot]

@llvm/pr-subscribers-flang-fir-hlfir

Author: None (jeanPerier)

Changes

The existing code failed to detect character array as being character because of the extra fir.array type indirection. Use fir::getFortranElementType for a more generic type handling.

Fixes #150749.

---

Full diff: https://github.com/llvm/llvm-project/pull/157813.diff

3 Files Affected:

• (modified) flang/lib/Optimizer/Builder/MutableBox.cpp (+1-1)
• (modified) flang/test/Lower/HLFIR/actual_target_for_dummy_pointer.f90 (+1-1)
• (added) flang/test/Lower/call-character-array-to-polymorphic-pointer.f90 (+29)

diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp
index d4cdfecd0b088..bcec49b3e3c8e 100644
--- a/flang/lib/Optimizer/Builder/MutableBox.cpp
+++ b/flang/lib/Optimizer/Builder/MutableBox.cpp
@@ -67,7 +67,7 @@ createNewFirBox(fir::FirOpBuilder &builder, mlir::Location loc,
       cleanedLengths.append(lengths.begin(), lengths.end());
   } else if (fir::isUnlimitedPolymorphicType(box.getBoxTy())) {
     if (auto charTy = mlir::dyn_cast<fir::CharacterType>(
-            fir::dyn_cast_ptrEleTy(addr.getType()))) {
+            fir::getFortranElementType(addr.getType()))) {
       if (charTy.getLen() == fir::CharacterType::unknownLen())
         cleanedLengths.append(lengths.begin(), lengths.end());
     }
diff --git a/flang/test/Lower/HLFIR/actual_target_for_dummy_pointer.f90 b/flang/test/Lower/HLFIR/actual_target_for_dummy_pointer.f90
index cd0398c1850fb..efe9e6dd190c0 100644
--- a/flang/test/Lower/HLFIR/actual_target_for_dummy_pointer.f90
+++ b/flang/test/Lower/HLFIR/actual_target_for_dummy_pointer.f90
@@ -246,7 +246,7 @@ end subroutine char_explicit_shape_array
 ! CHECK:           fir.store %[[VAL_30]] to %[[VAL_2]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>
 ! CHECK:           fir.call @_QPchar_explicit_shape_array_assumed_len_callee(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>) -> ()
 ! CHECK:           %[[VAL_31:.*]] = fir.shape %[[VAL_14]] : (index) -> !fir.shape<1>
-! CHECK:           %[[VAL_32:.*]] = fir.embox %[[VAL_16]]#1(%[[VAL_31]]) : (!fir.ref<!fir.array<100x!fir.char<1,?>>>, !fir.shape<1>) -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
+! CHECK:           %[[VAL_32:.*]] = fir.embox %[[VAL_16]]#1(%[[VAL_31]]) typeparams %[[VAL_12]]#1 : (!fir.ref<!fir.array<100x!fir.char<1,?>>>, !fir.shape<1>, index) -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
 ! CHECK:           fir.store %[[VAL_32]] to %[[VAL_1]] : !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>
 ! CHECK:           fir.call @_QPchar_explicit_shape_array_uclass_callee(%[[VAL_1]]) fastmath<contract> : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> ()
 ! CHECK:           return
diff --git a/flang/test/Lower/call-character-array-to-polymorphic-pointer.f90 b/flang/test/Lower/call-character-array-to-polymorphic-pointer.f90
new file mode 100644
index 0000000000000..8644a4a3faf7f
--- /dev/null
+++ b/flang/test/Lower/call-character-array-to-polymorphic-pointer.f90
@@ -0,0 +1,29 @@
+! Test passing character array to unlimited polymorphic array pointer.
+! Regression test from https://github.com/llvm/llvm-project/issues/150749
+
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+subroutine char_explicit_shape_array(a2)
+interface
+subroutine char_explicit_shape_array_uclass_callee(p)
+ class(*), pointer, intent(in) :: p(:)
+end subroutine char_explicit_shape_array_uclass_callee
+end interface
+character(*), target :: a2(100)
+call char_explicit_shape_array_uclass_callee(a2)
+end subroutine char_explicit_shape_array
+! CHECK-LABEL:   func.func @_QPchar_explicit_shape_array(
+! CHECK-SAME:      %[[ARG0:.*]]: !fir.boxchar<1> {fir.bindc_name = "a2", fir.target}) {
+! CHECK:           %[[VAL_0:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.array<?xnone>>>
+! CHECK:           %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! CHECK:           %[[VAL_2:.*]]:2 = fir.unboxchar %[[ARG0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+! CHECK:           %[[VAL_3:.*]] = fir.convert %[[VAL_2]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<100x!fir.char<1,?>>>
+! CHECK:           %[[VAL_4:.*]] = arith.constant 100 : index
+! CHECK:           %[[VAL_5:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1>
+! CHECK:           %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_3]](%[[VAL_5]]) typeparams %[[VAL_2]]#1 dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFchar_explicit_shape_arrayEa2"} : (!fir.ref<!fir.array<100x!fir.char<1,?>>>, !fir.shape<1>, index, !fir.dscope) -> (!fir.box<!fir.array<100x!fir.char<1,?>>>, !fir.ref<!fir.array<100x!fir.char<1,?>>>)
+! CHECK:           %[[VAL_7:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1>
+! CHECK:           %[[VAL_8:.*]] = fir.embox %[[VAL_6]]#1(%[[VAL_7]]) typeparams %[[VAL_2]]#1 : (!fir.ref<!fir.array<100x!fir.char<1,?>>>, !fir.shape<1>, index) -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
+! CHECK:           fir.store %[[VAL_8]] to %[[VAL_0]] : !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>
+! CHECK:           fir.call @_QPchar_explicit_shape_array_uclass_callee(%[[VAL_0]]) fastmath<contract> : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> ()
+! CHECK:           return
+! CHECK:         }

[vzakhari]

Thank you, Jean!

[clementval]

LGTM