[flang] Unlimited polymoprhic allocated as character

[clementval]

Summary

Allocation of unlimited polymorphic allocatable with
character intrinsic type is now done through
PointerNullifyCharacter or AllocatableInitCharacter so the length
is correctly set.

[jeanPerier]

LGTM

flang/lib/Lower/Allocatable.cpp

static void genRuntimeSetBounds(fir::FirOpBuilder &builder, mlir::Location loc,
   builder.create<fir::CallOp>(loc, callee, operands);
 }
 
 /// Generate runtime call to set the lengths of a character allocatable or
 /// pointer descriptor.
 static void genRuntimeInitCharacter(fir::FirOpBuilder &builder,
                                     mlir::Location loc,
                                     const fir::MutableBoxValue &box,
-                                    mlir::Value len) {
+                                    mlir::Value len, int64_t kind = 0) {
   mlir::func::FuncOp callee =
       box.isPointer()
           ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyCharacter)>(
                 loc, builder)
           : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableInitCharacter)>(
                 loc, builder);
   llvm::ArrayRef<mlir::Type> inputTypes = callee.getFunctionType().getInputs();
   if (inputTypes.size() != 5)
     fir::emitFatalError(
         loc, "AllocatableInitCharacter runtime interface not as expected");
   llvm::SmallVector<mlir::Value> args;
   args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
   args.push_back(builder.createConvert(loc, inputTypes[1], len));
-  int kind = box.getEleTy().cast<fir::CharacterType>().getFKind();
+  if (kind == 0)
+    kind = box.getEleTy().cast<fir::CharacterType>().getFKind();
   args.push_back(builder.createIntegerConstant(loc, inputTypes[2], kind));
   int rank = box.rank();
   args.push_back(builder.createIntegerConstant(loc, inputTypes[3], rank));
   // TODO: coarrays
   int corank = 0;
   args.push_back(builder.createIntegerConstant(loc, inputTypes[4], corank));
   builder.create<fir::CallOp>(loc, callee, args);
 }
void genSetType(const Allocation &alloc, const fir::MutableBoxValue &box,
     if (!typeSpec)
       typeSpec = &alloc.type;
     assert(typeSpec && "type spec missing for polymorphic allocation");
 
     // Set up the descriptor for allocation for intrinsic type spec on
     // unlimited polymorphic entity.
     if (typeSpec->AsIntrinsic() &&
         fir::isUnlimitedPolymorphicType(fir::getBase(box).getType())) {
+      if (typeSpec->AsIntrinsic()->category() == TypeCategory::Character) {
+        genRuntimeInitCharacter(
+            builder, loc, box, lenParams[0],
+            Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind())
+                .value());
+      } else {
         genInitIntrinsic(
             box, typeSpec->AsIntrinsic()->category(),
             Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()).value(),
             alloc.getSymbol().Rank());
+      }
       return;
     }
 
     // Do not generate calls for non derived-type type spec.
     if (!typeSpec->AsDerived())
       return;
 
     auto typeDescAddr = Fortran::lower::getTypeDescAddr(

flang/test/Lower/allocatable-polymorphic.f90

 ! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref<!fir.class<!fir.heap<!fir.array<?xnone>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK: %[[C1_I64:.*]] = fir.convert %[[C1]] : (index) -> i64
 ! CHECK: %[[C20_I64:.*]] = fir.convert %[[C20]] : (i32) -> i64
 ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableSetBounds(%[[A_BOX_NONE]], %[[C0]], %[[C1_I64]], %[[C20_I64]]) {{.*}} : (!fir.ref<!fir.box<none>>, i32, i64, i64) -> none
 ! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref<!fir.class<!fir.heap<!fir.array<?xnone>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK: %[[BOX_NONE_10:.*]] = fir.convert %[[EMBOX_10]] : (!fir.box<i32>) -> !fir.box<none>
 ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocateSource(%[[A_BOX_NONE]], %[[BOX_NONE_10]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
 
+  subroutine test_allocatable_up_character()
+    class(*), allocatable :: a
+    allocate(character*10::a)
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolyPtest_allocatable_up_character() {
+! CHECK: %[[A:.*]] = fir.alloca !fir.class<!fir.heap<none>> {bindc_name = "a", uniq_name = "_QMpolyFtest_allocatable_up_characterEa"}
+! CHECK: %[[LEN:.*]] = arith.constant 10 : i64
+! CHECK: %[[A_NONE:.*]] = fir.convert %[[A]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[KIND:.*]] = arith.constant 1 : i32
+! CHECK: %[[RANK:.*]] = arith.constant 0 : i32
+! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableInitCharacter(%[[A_NONE]], %[[LEN]], %[[KIND]], %[[RANK]], %[[CORANK]]) {{.*}} : (!fir.ref<!fir.box<none>>, i64, i32, i32, i32) -> none
+! CHECK: %[[A_NONE:.*]] = fir.convert %[[A:.*]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[A_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
 end module
 
 
 program test_alloc
   use poly
 
   call test_allocatable()
   call test_pointer()