[flang] implement assumed-rank in ENTRY

flang/lib/Lower/ConvertType.cpp

@@ -280,10 +280,11 @@ struct TypeBuilderImpl {
     if (ultimate.IsObjectArray()) {
       auto shapeExpr =
           Fortran::evaluate::GetShape(converter.getFoldingContext(), ultimate);
-      if (!shapeExpr)
-        TODO(loc, "assumed rank symbol type");
       fir::SequenceType::Shape shape;
-      translateShape(shape, std::move(*shapeExpr));
+      // If there is no shapExpr, this is an assumed-rank, and the empty shape
+      // will build the desired fir.array<*:T> type.
+      if (shapeExpr)
+        translateShape(shape, std::move(*shapeExpr));
       ty = fir::SequenceType::get(shape, ty);
     }
     if (Fortran::semantics::IsPointer(symbol))

flang/lib/Lower/ConvertVariable.cpp

@@ -2036,11 +2036,6 @@ void Fortran::lower::mapSymbolAttributes(
     if (isUnusedEntryDummy) {
       assert(!Fortran::semantics::IsAllocatableOrPointer(sym) &&
              "handled above");
-      // Need to add support for allocatable assumed-rank to use
-      // logic below, or to simplify it and add codegen for fir.zero
-      // !fir.box<> instead.
-      if (isAssumedRank)
-        TODO(loc, "assumed rank in ENTRY");
       // The box is read right away because lowering code does not expect
       // a non pointer/allocatable symbol to be mapped to a MutableBox.
       mlir::Type ty = converter.genType(var);

flang/lib/Optimizer/Builder/MutableBox.cpp

@@ -329,7 +329,18 @@ class MutablePropertyWriter {
 mlir::Value fir::factory::createUnallocatedBox(
     fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type boxType,
     mlir::ValueRange nonDeferredParams, mlir::Value typeSourceBox) {
-  auto baseAddrType = mlir::dyn_cast<fir::BaseBoxType>(boxType).getEleTy();
+  auto baseBoxType = mlir::cast<fir::BaseBoxType>(boxType);
+  // Giving unallocated/disassociated status to assumed-rank POINTER/
+  // ALLOCATABLE is not directly possible to a Fortran user. But the
+  // compiler may need to create such temporary descriptor to deal with
+  // cases like ENTRY or host association. In such case, all that mater
+  // is that the base address is set to zero and the rank is set to
+  // some defined value. Hence, a scalar descriptor is created and
+  // cast to assumed-rank.
+  const bool isAssumedRank = baseBoxType.isAssumedRank();
+  if (isAssumedRank)
+    baseBoxType = baseBoxType.getBoxTypeWithNewShape(/*rank=*/0);
+  auto baseAddrType = baseBoxType.getEleTy();
   if (!fir::isa_ref_type(baseAddrType))
     baseAddrType = builder.getRefType(baseAddrType);
   auto type = fir::unwrapRefType(baseAddrType);
@@ -361,8 +372,11 @@ mlir::Value fir::factory::createUnallocatedBox(
     }
   }
   mlir::Value emptySlice;
-  return builder.create<fir::EmboxOp>(loc, boxType, nullAddr, shape, emptySlice,
-                                      lenParams, typeSourceBox);
+  auto embox = builder.create<fir::EmboxOp>(
+      loc, baseBoxType, nullAddr, shape, emptySlice, lenParams, typeSourceBox);
+  if (isAssumedRank)
+    return builder.createConvert(loc, boxType, embox);
+  return embox;
 }
 
 fir::MutableBoxValue fir::factory::createTempMutableBox(

flang/test/Lower/HLFIR/assumed-rank-entry.f90

@@ -0,0 +1,28 @@
+! Test assumed-rank dummy argument that is not present in
+! all ENTRY statements.
+! RUN: bbc -emit-hlfir -allow-assumed-rank -o - %s | FileCheck %s
+
+subroutine test_main_entry(x)
+  real :: x(..)
+  interface
+  subroutine some_proc(x)
+    real :: x(..)
+  end subroutine
+  end interface
+  call some_proc(x)
+entry test_alternate_entry()
+  call the_end()
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_main_entry(
+! CHECK-SAME:                                  %[[VAL_0:.*]]: !fir.box<!fir.array<*:f32>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! CHECK:           %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {uniq_name = "_QFtest_main_entryEx"} : (!fir.box<!fir.array<*:f32>>, !fir.dscope) -> (!fir.box<!fir.array<*:f32>>, !fir.box<!fir.array<*:f32>>)
+
+! CHECK-LABEL:   func.func @_QPtest_alternate_entry() {
+! CHECK:           %[[VAL_0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<*:f32>>>
+! CHECK:           %[[VAL_1:.*]] = fir.zero_bits !fir.heap<f32>
+! CHECK:           %[[VAL_2:.*]] = fir.embox %[[VAL_1]] : (!fir.heap<f32>) -> !fir.box<!fir.heap<f32>>
+! CHECK:           %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.box<!fir.heap<f32>>) -> !fir.box<!fir.heap<!fir.array<*:f32>>>
+! CHECK:           fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK:           %[[VAL_4:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK:           %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]] {uniq_name = "_QFtest_main_entryEx"} : (!fir.box<!fir.heap<!fir.array<*:f32>>>) -> (!fir.box<!fir.heap<!fir.array<*:f32>>>, !fir.box<!fir.heap<!fir.array<*:f32>>>)