[flang] Lower passing non assumed-rank/size to assumed-ranks (#79145)

Start implementing assumed-rank support as described in
https://github.com/llvm/llvm-project/blob/main/flang/docs/AssumedRank.md

This commit holds the minimal support for lowering calls to procedure
with assumed-rank arguments where the procedure implementation is done
in C.

The case for passing assumed-size to assumed-rank is left TODO since it
will be done a change in assumed-size lowering that is better done in
another patch.

Care is taken to set the lower bounds to zero when passing non allocatable no pointer as descriptor
to a BIND(C) procedure as required per 18.5.3 point 3. This was not done before while the requirements also applies to non assumed-rank descriptors. This change  required special attention with IGNORE_TKR(t) to avoid emitting invalid fir.rebox operations (the actual argument type must be used in this case as the output type). 

Implementation of Fortran procedure with assumed-rank arguments is still
TODO.

flang/include/flang/Optimizer/Builder/FIRBuilder.h

@@ -109,7 +109,8 @@ public:
   /// after type conversion and the imaginary part is zero.
   mlir::Value convertWithSemantics(mlir::Location loc, mlir::Type toTy,
                                    mlir::Value val,
-                                   bool allowCharacterConversion = false);
+                                   bool allowCharacterConversion = false,
+                                   bool allowRebox = false);
 
   /// Get the entry block of the current Function
   mlir::Block *getEntryBlock() { return &getFunction().front(); }

flang/include/flang/Optimizer/Builder/HLFIRTools.h

@@ -71,6 +71,9 @@ public:
   /// Is this an array or an assumed ranked entity?
   bool isArray() const { return getRank() != 0; }
 
+  /// Is this an assumed ranked entity?
+  bool isAssumedRank() const { return getRank() == -1; }
+
   /// Return the rank of this entity or -1 if it is an assumed rank.
   int getRank() const {
     mlir::Type type = fir::unwrapPassByRefType(fir::unwrapRefType(getType()));

flang/include/flang/Optimizer/Dialect/FIRType.h

@@ -46,6 +46,13 @@ public:
   /// Unwrap element type from fir.heap, fir.ptr and fir.array.
   mlir::Type unwrapInnerType() const;
 
+  /// Is this the box for an assumed rank?
+  bool isAssumedRank() const;
+
+  /// Return the same type, except for the shape, that is taken the shape
+  /// of shapeMold.
+  BaseBoxType getBoxTypeWithNewShape(mlir::Type shapeMold) const;
+
   /// Methods for support type inquiry through isa, cast, and dyn_cast.
   static bool classof(mlir::Type type);
 };
@@ -428,6 +435,13 @@ inline mlir::Type updateTypeForUnlimitedPolymorphic(mlir::Type ty) {
   return ty;
 }
 
+/// Replace the element type of \p type by \p newElementType, preserving
+/// all other layers of the type (fir.ref/ptr/heap/array/box/class).
+/// If \p turnBoxIntoClass and the input is a fir.box, it will be turned into
+/// a fir.class in the result.
+mlir::Type changeElementType(mlir::Type type, mlir::Type newElementType,
+                             bool turnBoxIntoClass);
+
 /// Is `t` an address to fir.box or class type?
 inline bool isBoxAddress(mlir::Type t) {
   return fir::isa_ref_type(t) && fir::unwrapRefType(t).isa<fir::BaseBoxType>();

flang/lib/Lower/CallInterface.cpp

@@ -867,9 +867,8 @@ private:
   getRefType(Fortran::evaluate::DynamicType dynamicType,
              const Fortran::evaluate::characteristics::DummyDataObject &obj) {
     mlir::Type type = translateDynamicType(dynamicType);
-    fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
-    if (!bounds.empty())
-      type = fir::SequenceType::get(bounds, type);
+    if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type))
+      type = fir::SequenceType::get(*bounds, type);
     return fir::ReferenceType::get(type);
   }
 
@@ -993,8 +992,6 @@ private:
     using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
     const Fortran::evaluate::characteristics::TypeAndShape::Attrs &shapeAttrs =
         obj.type.attrs();
-    if (shapeAttrs.test(ShapeAttr::AssumedRank))
-      TODO(loc, "assumed rank in procedure interface");
     if (shapeAttrs.test(ShapeAttr::Coarray))
       TODO(loc, "coarray: dummy argument coarray in procedure interface");
 
@@ -1003,9 +1000,8 @@ private:
 
     Fortran::evaluate::DynamicType dynamicType = obj.type.type();
     mlir::Type type = translateDynamicType(dynamicType);
-    fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
-    if (!bounds.empty())
-      type = fir::SequenceType::get(bounds, type);
+    if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type))
+      type = fir::SequenceType::get(*bounds, type);
     if (obj.attrs.test(Attrs::Allocatable))
       type = fir::HeapType::get(type);
     if (obj.attrs.test(Attrs::Pointer))
@@ -1123,14 +1119,14 @@ private:
           result.GetTypeAndShape();
       assert(typeAndShape && "expect type for non proc pointer result");
       mlirType = translateDynamicType(typeAndShape->type());
-      fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
       const auto *resTypeAndShape{result.GetTypeAndShape()};
       bool resIsPolymorphic =
           resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
       bool resIsAssumedType =
           resTypeAndShape && resTypeAndShape->type().IsAssumedType();
-      if (!bounds.empty())
-        mlirType = fir::SequenceType::get(bounds, mlirType);
+      if (std::optional<fir::SequenceType::Shape> bounds =
+              getBounds(*typeAndShape))
+        mlirType = fir::SequenceType::get(*bounds, mlirType);
       if (result.attrs.test(Attr::Allocatable))
         mlirType = fir::wrapInClassOrBoxType(
             fir::HeapType::get(mlirType), resIsPolymorphic, resIsAssumedType);
@@ -1157,9 +1153,17 @@ private:
     setSaveResult();
   }
 
-  fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
+  // Return nullopt for scalars, empty vector for assumed rank, and a vector
+  // with the shape (may contain unknown extents) for arrays.
+  std::optional<fir::SequenceType::Shape> getBounds(
+      const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape) {
+    using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
+    if (typeAndShape.shape().empty() &&
+        !typeAndShape.attrs().test(ShapeAttr::AssumedRank))
+      return std::nullopt;
     fir::SequenceType::Shape bounds;
-    for (const std::optional<Fortran::evaluate::ExtentExpr> &extent : shape) {
+    for (const std::optional<Fortran::evaluate::ExtentExpr> &extent :
+         typeAndShape.shape()) {
       fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent();
       if (std::optional<std::int64_t> i = toInt64(extent))
         bound = *i;

flang/lib/Lower/ConvertCall.cpp

@@ -373,8 +373,14 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
         // TODO: remove this TODO once the old lowering is gone.
         TODO(loc, "derived type argument passed by value");
       } else {
+        // With the lowering to HLFIR, box arguments have already been built
+        // according to the attributes, rank, bounds, and type they should have.
+        // Do not attempt any reboxing here that could break this.
+        bool legacyLowering =
+            !converter.getLoweringOptions().getLowerToHighLevelFIR();
         cast = builder.convertWithSemantics(loc, snd, fst,
-                                            callingImplicitInterface);
+                                            callingImplicitInterface,
+                                            /*allowRebox=*/legacyLowering);
       }
     }
     operands.push_back(cast);
@@ -650,6 +656,13 @@ struct CallContext {
     return false;
   }
 
+  /// Is this a call to a BIND(C) procedure?
+  bool isBindcCall() const {
+    if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
+      return Fortran::semantics::IsBindCProcedure(*symbol);
+    return false;
+  }
+
   const Fortran::evaluate::ProcedureRef &procRef;
   Fortran::lower::AbstractConverter &converter;
   Fortran::lower::SymMap &symMap;
@@ -859,6 +872,22 @@ static hlfir::Entity fixProcedureDummyMismatch(mlir::Location loc,
   return hlfir::Entity{boxProc};
 }
 
+mlir::Value static getZeroLowerBounds(mlir::Location loc,
+                                      fir::FirOpBuilder &builder,
+                                      hlfir::Entity entity) {
+  // Assumed rank should not fall here, but better safe than sorry until
+  // implemented.
+  if (entity.isAssumedRank())
+    TODO(loc, "setting lower bounds of assumed rank to zero before passing it "
+              "to BIND(C) procedure");
+  if (entity.getRank() < 1)
+    return {};
+  mlir::Value zero =
+      builder.createIntegerConstant(loc, builder.getIndexType(), 0);
+  llvm::SmallVector<mlir::Value> lowerBounds(entity.getRank(), zero);
+  return builder.genShift(loc, lowerBounds);
+}
+
 /// When dummy is not ALLOCATABLE, POINTER and is not passed in register,
 /// prepare the actual argument according to the interface. Do as needed:
 /// - address element if this is an array argument in an elemental call.
@@ -874,11 +903,10 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
     const Fortran::lower::PreparedActualArgument &preparedActual,
     mlir::Type dummyType,
     const Fortran::lower::CallerInterface::PassedEntity &arg,
-    const Fortran::lower::SomeExpr &expr,
-    Fortran::lower::AbstractConverter &converter) {
+    const Fortran::lower::SomeExpr &expr, CallContext &callContext) {
 
   Fortran::evaluate::FoldingContext &foldingContext =
-      converter.getFoldingContext();
+      callContext.converter.getFoldingContext();
 
   // Step 1: get the actual argument, which includes addressing the
   // element if this is an array in an elemental call.
@@ -922,8 +950,10 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
     return PreparedDummyArgument{actual, /*cleanups=*/{}};
   }
 
+  const bool ignoreTKRtype = arg.testTKR(Fortran::common::IgnoreTKR::Type);
   const bool passingPolymorphicToNonPolymorphic =
-      actual.isPolymorphic() && !fir::isPolymorphicType(dummyType);
+      actual.isPolymorphic() && !fir::isPolymorphicType(dummyType) &&
+      !ignoreTKRtype;
 
   // When passing a CLASS(T) to TYPE(T), only the "T" part must be
   // passed. Unless the entity is a scalar passed by raw address, a
@@ -942,6 +972,25 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
       (passingPolymorphicToNonPolymorphic ||
        !Fortran::evaluate::IsSimplyContiguous(expr, foldingContext));
 
+  const bool actualIsAssumedRank = actual.isAssumedRank();
+  // Create dummy type with actual argument rank when the dummy is an assumed
+  // rank. That way, all the operation to create dummy descriptors are ranked if
+  // the actual argument is ranked, which allows simple code generation.
+  mlir::Type dummyTypeWithActualRank = dummyType;
+  if (auto baseBoxDummy = mlir::dyn_cast<fir::BaseBoxType>(dummyType))
+    if (baseBoxDummy.isAssumedRank() ||
+        arg.testTKR(Fortran::common::IgnoreTKR::Rank))
+      dummyTypeWithActualRank =
+          baseBoxDummy.getBoxTypeWithNewShape(actual.getType());
+  // Preserve the actual type in the argument preparation in case IgnoreTKR(t)
+  // is set (descriptors must be created with the actual type in this case, and
+  // copy-in/copy-out should be driven by the contiguity with regard to the
+  // actual type).
+  if (ignoreTKRtype)
+    dummyTypeWithActualRank = fir::changeElementType(
+        dummyTypeWithActualRank, actual.getFortranElementType(),
+        actual.isPolymorphic());
+
   // Step 2: prepare the storage for the dummy arguments, ensuring that it
   // matches the dummy requirements (e.g., must be contiguous or must be
   // a temporary).
@@ -952,8 +1001,11 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
     if (mustSetDynamicTypeToDummyType) {
       // Note: this is important to do this before any copy-in or copy so
       // that the dummy is contiguous according to the dummy type.
-      mlir::Type boxType =
-          fir::BoxType::get(hlfir::getFortranElementOrSequenceType(dummyType));
+      if (actualIsAssumedRank)
+        TODO(loc, "passing polymorphic assumed-rank to non polymorphic dummy "
+                  "argument");
+      mlir::Type boxType = fir::BoxType::get(
+          hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
       entity = hlfir::Entity{builder.create<fir::ReboxOp>(
           loc, boxType, entity, /*shape=*/mlir::Value{},
           /*slice=*/mlir::Value{})};
@@ -978,6 +1030,8 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
       // Copy-in non contiguous variables.
       assert(entity.getType().isa<fir::BaseBoxType>() &&
              "expect non simply contiguous variables to be boxes");
+      if (actualIsAssumedRank)
+        TODO(loc, "copy-in and copy-out of assumed-rank arguments");
       // TODO: for non-finalizable monomorphic derived type actual
       // arguments associated with INTENT(OUT) dummy arguments
       // we may avoid doing the copy and only allocate the temporary.
@@ -996,7 +1050,7 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
   } else {
     // The actual is an expression value, place it into a temporary
     // and register the temporary destruction after the call.
-    mlir::Type storageType = converter.genType(expr);
+    mlir::Type storageType = callContext.converter.genType(expr);
     mlir::NamedAttribute byRefAttr = fir::getAdaptToByRefAttr(builder);
     hlfir::AssociateOp associate = hlfir::genAssociateExpr(
         loc, builder, entity, storageType, "", byRefAttr);
@@ -1010,8 +1064,9 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
       // TODO: this can probably be optimized by associating the expression
       // with properly typed temporary, but this needs either a new operation
       // or making the hlfir.associate more complex.
-      mlir::Type boxType =
-          fir::BoxType::get(hlfir::getFortranElementOrSequenceType(dummyType));
+      assert(!actualIsAssumedRank && "only variables are assumed-rank");
+      mlir::Type boxType = fir::BoxType::get(
+          hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
       entity = hlfir::Entity{builder.create<fir::ReboxOp>(
           loc, boxType, entity, /*shape=*/mlir::Value{},
           /*slice=*/mlir::Value{})};
@@ -1029,9 +1084,9 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
   // Step 3: now that the dummy argument storage has been prepared, package
   // it according to the interface.
   mlir::Value addr;
-  if (dummyType.isa<fir::BoxCharType>()) {
+  if (dummyTypeWithActualRank.isa<fir::BoxCharType>()) {
     addr = hlfir::genVariableBoxChar(loc, builder, entity);
-  } else if (dummyType.isa<fir::BaseBoxType>()) {
+  } else if (dummyTypeWithActualRank.isa<fir::BaseBoxType>()) {
     entity = hlfir::genVariableBox(loc, builder, entity);
     // Ensures the box has the right attributes and that it holds an
     // addendum if needed.
@@ -1043,39 +1098,55 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
     // has the dummy attributes in BIND(C) contexts.
     const bool actualBoxHasAllocatableOrPointerFlag =
         fir::isa_ref_type(boxEleType);
+    // Fortran 2018 18.5.3, pp3: BIND(C) non pointer allocatable descriptors
+    // must have zero lower bounds.
+    bool needsZeroLowerBounds = callContext.isBindcCall() && entity.isArray();
     // On the callee side, the current code generated for unlimited
     // polymorphic might unconditionally read the addendum. Intrinsic type
     // descriptors may not have an addendum, the rebox below will create a
     // descriptor with an addendum in such case.
     const bool actualBoxHasAddendum = fir::boxHasAddendum(actualBoxType);
     const bool needToAddAddendum =
-        fir::isUnlimitedPolymorphicType(dummyType) && !actualBoxHasAddendum;
-    mlir::Type reboxType = dummyType;
-    if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag) {
-      if (fir::getBoxRank(dummyType) != fir::getBoxRank(actualBoxType)) {
-        // This may happen only with IGNORE_TKR(R).
-        if (!arg.testTKR(Fortran::common::IgnoreTKR::Rank))
-          DIE("actual and dummy arguments must have equal ranks");
-        // Only allow it for unlimited polymorphic dummy arguments
-        // for now.
-        if (!fir::isUnlimitedPolymorphicType(dummyType))
-          TODO(loc, "actual/dummy rank mismatch for not unlimited polymorphic "
-                    "dummy.");
-        auto elementType = fir::updateTypeForUnlimitedPolymorphic(boxEleType);
-        if (fir::isAssumedType(dummyType))
-          reboxType = fir::BoxType::get(elementType);
+        fir::isUnlimitedPolymorphicType(dummyTypeWithActualRank) &&
+        !actualBoxHasAddendum;
+    if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag ||
+        needsZeroLowerBounds) {
+      if (actualIsAssumedRank) {
+        if (needToAddAddendum)
+          TODO(loc, "passing intrinsic assumed-rank to unlimited polymorphic "
+                    "assumed-rank");
         else
-          reboxType = fir::ClassType::get(elementType);
+          TODO(loc, "passing pointer or allocatable assumed-rank to non "
+                    "pointer non allocatable assumed-rank");
       }
+      mlir::Value shift{};
+      if (needsZeroLowerBounds)
+        shift = getZeroLowerBounds(loc, builder, entity);
       entity = hlfir::Entity{builder.create<fir::ReboxOp>(
-          loc, reboxType, entity, /*shape=*/mlir::Value{},
+          loc, dummyTypeWithActualRank, entity, /*shape=*/shift,
           /*slice=*/mlir::Value{})};
     }
     addr = entity;
   } else {
     addr = hlfir::genVariableRawAddress(loc, builder, entity);
   }
-  preparedDummy.dummy = builder.createConvert(loc, dummyType, addr);
+  // The last extent created for assumed-rank descriptors must be -1 (18.5.3
+  // point 5.). This should be done when creating the assumed-size shape for
+  // consistency.
+  if (auto baseBoxDummy = mlir::dyn_cast<fir::BaseBoxType>(dummyType))
+    if (baseBoxDummy.isAssumedRank())
+      if (const Fortran::semantics::Symbol *sym =
+              Fortran::evaluate::UnwrapWholeSymbolDataRef(expr))
+        if (Fortran::semantics::IsAssumedSizeArray(sym->GetUltimate()))
+          TODO(loc, "passing assumed-size to assumed-rank array");
+
+  // For ranked actual passed to assumed-rank dummy, the cast to assumed-rank
+  // box is inserted when building the fir.call op. Inserting it here would
+  // cause the fir.if results to be assumed-rank in case of OPTIONAL dummy,
+  // causing extra runtime costs due to the unknown runtime size of assumed-rank
+  // descriptors.
+  preparedDummy.dummy =
+      builder.createConvert(loc, dummyTypeWithActualRank, addr);
   return preparedDummy;
 }
 
@@ -1087,11 +1158,10 @@ static PreparedDummyArgument prepareUserCallActualArgument(
     const Fortran::lower::PreparedActualArgument &preparedActual,
     mlir::Type dummyType,
     const Fortran::lower::CallerInterface::PassedEntity &arg,
-    const Fortran::lower::SomeExpr &expr,
-    Fortran::lower::AbstractConverter &converter) {
+    const Fortran::lower::SomeExpr &expr, CallContext &callContext) {
   if (!preparedActual.handleDynamicOptional())
     return preparePresentUserCallActualArgument(
-        loc, builder, preparedActual, dummyType, arg, expr, converter);
+        loc, builder, preparedActual, dummyType, arg, expr, callContext);
 
   // Conditional dummy argument preparation. The actual may be absent
   // at runtime, causing any addressing, copy, and packaging to have
@@ -1113,7 +1183,7 @@ static PreparedDummyArgument prepareUserCallActualArgument(
   builder.setInsertionPointToStart(preparationBlock);
   PreparedDummyArgument unconditionalDummy =
       preparePresentUserCallActualArgument(loc, builder, preparedActual,
-                                           dummyType, arg, expr, converter);
+                                           dummyType, arg, expr, callContext);
   builder.restoreInsertionPoint(insertPt);
 
   // TODO: when forwarding an optional to an optional of the same kind
@@ -1216,9 +1286,8 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
     case PassBy::BaseAddress:
     case PassBy::BoxProcRef:
     case PassBy::BoxChar: {
-      PreparedDummyArgument preparedDummy =
-          prepareUserCallActualArgument(loc, builder, *preparedActual, argTy,
-                                        arg, *expr, callContext.converter);
+      PreparedDummyArgument preparedDummy = prepareUserCallActualArgument(
+          loc, builder, *preparedActual, argTy, arg, *expr, callContext);
       callCleanUps.append(preparedDummy.cleanups.rbegin(),
                           preparedDummy.cleanups.rend());
       caller.placeInput(arg, preparedDummy.dummy);
@@ -1261,10 +1330,20 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
         // Passing a non POINTER actual argument to a POINTER dummy argument.
         // Create a pointer of the dummy argument type and assign the actual
         // argument to it.
-        mlir::Type dataTy = fir::unwrapRefType(argTy);
+        auto dataTy = llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(argTy));
         fir::ExtendedValue actualExv = Fortran::lower::convertToAddress(
             loc, callContext.converter, actual, callContext.stmtCtx,
             hlfir::getFortranElementType(dataTy));
+        // If the dummy is an assumed-rank pointer, allocate a pointer
+        // descriptor with the actual argument rank (if it is not assumed-rank
+        // itself).
+        if (dataTy.isAssumedRank()) {
+          dataTy =
+              dataTy.getBoxTypeWithNewShape(fir::getBase(actualExv).getType());
+          if (dataTy.isAssumedRank())
+            TODO(loc, "associating assumed-rank target to pointer assumed-rank "
+                      "argument");
+        }
         mlir::Value irBox = builder.createTemporary(loc, dataTy);
         fir::MutableBoxValue ptrBox(irBox,
                                     /*nonDeferredParams=*/mlir::ValueRange{},
@@ -1277,8 +1356,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
       // Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE.
       assert(actual.isMutableBox() && "actual must be a mutable box");
       if (fir::isAllocatableType(argTy) && arg.isIntentOut() &&
-          Fortran::semantics::IsBindCProcedure(
-              *callContext.procRef.proc().GetSymbol())) {
+          callContext.isBindcCall()) {
         // INTENT(OUT) allocatables are deallocated on the callee side,
         // but BIND(C) procedures may be implemented in C, so deallocation is
         // also done on the caller side (if the procedure is implemented in
@@ -2186,8 +2264,7 @@ genProcedureRef(CallContext &callContext) {
   // intrinsic unless it is bind(c) (since implementation is external from
   // module).
   if (Fortran::lower::isIntrinsicModuleProcRef(callContext.procRef) &&
-      !Fortran::semantics::IsBindCProcedure(
-          *callContext.procRef.proc().GetSymbol()))
+      !callContext.isBindcCall())
     return genIntrinsicRef(nullptr, callContext);
 
   if (callContext.isStatementFunctionCall())

flang/lib/Lower/ConvertExprToHLFIR.cpp

@@ -405,8 +405,8 @@ private:
         .Case<fir::SequenceType>([&](fir::SequenceType seqTy) -> mlir::Type {
           return fir::SequenceType::get(seqTy.getShape(), newEleTy);
         })
-        .Case<fir::PointerType, fir::HeapType, fir::ReferenceType,
-              fir::BoxType>([&](auto t) -> mlir::Type {
+        .Case<fir::PointerType, fir::HeapType, fir::ReferenceType, fir::BoxType,
+              fir::ClassType>([&](auto t) -> mlir::Type {
           using FIRT = decltype(t);
           return FIRT::get(changeElementType(t.getEleTy(), newEleTy));
         })

flang/lib/Lower/ConvertVariable.cpp

@@ -1834,6 +1834,9 @@ void Fortran::lower::mapSymbolAttributes(
     return;
   }
 
+  if (Fortran::evaluate::IsAssumedRank(sym))
+    TODO(loc, "assumed-rank variable in procedure implemented in Fortran");
+
   Fortran::lower::BoxAnalyzer ba;
   ba.analyze(sym);
 

flang/lib/Optimizer/Builder/FIRBuilder.cpp

@@ -308,10 +308,9 @@ fir::GlobalOp fir::FirOpBuilder::createGlobal(
   return glob;
 }
 
-mlir::Value
-fir::FirOpBuilder::convertWithSemantics(mlir::Location loc, mlir::Type toTy,
-                                        mlir::Value val,
-                                        bool allowCharacterConversion) {
+mlir::Value fir::FirOpBuilder::convertWithSemantics(
+    mlir::Location loc, mlir::Type toTy, mlir::Value val,
+    bool allowCharacterConversion, bool allowRebox) {
   assert(toTy && "store location must be typed");
   auto fromTy = val.getType();
   if (fromTy == toTy)
@@ -369,13 +368,15 @@ fir::FirOpBuilder::convertWithSemantics(mlir::Location loc, mlir::Type toTy,
     return create<fir::EmboxProcOp>(loc, toTy, proc);
   }
 
-  if (((fir::isPolymorphicType(fromTy) &&
-        (fir::isAllocatableType(fromTy) || fir::isPointerType(fromTy)) &&
-        fir::isPolymorphicType(toTy)) ||
-       (fir::isPolymorphicType(fromTy) && toTy.isa<fir::BoxType>())) &&
-      !(fir::isUnlimitedPolymorphicType(fromTy) && fir::isAssumedType(toTy)))
-    return create<fir::ReboxOp>(loc, toTy, val, mlir::Value{},
-                                /*slice=*/mlir::Value{});
+  // Legacy: remove when removing non HLFIR lowering path.
+  if (allowRebox)
+    if (((fir::isPolymorphicType(fromTy) &&
+          (fir::isAllocatableType(fromTy) || fir::isPointerType(fromTy)) &&
+          fir::isPolymorphicType(toTy)) ||
+         (fir::isPolymorphicType(fromTy) && toTy.isa<fir::BoxType>())) &&
+        !(fir::isUnlimitedPolymorphicType(fromTy) && fir::isAssumedType(toTy)))
+      return create<fir::ReboxOp>(loc, toTy, val, mlir::Value{},
+                                  /*slice=*/mlir::Value{});
 
   return createConvert(loc, toTy, val);
 }

flang/lib/Optimizer/Dialect/FIRType.cpp

@@ -588,6 +588,33 @@ std::string getTypeAsString(mlir::Type ty, const fir::KindMapping &kindMap,
   return name.str();
 }
 
+mlir::Type changeElementType(mlir::Type type, mlir::Type newElementType,
+                             bool turnBoxIntoClass) {
+  return llvm::TypeSwitch<mlir::Type, mlir::Type>(type)
+      .Case<fir::SequenceType>([&](fir::SequenceType seqTy) -> mlir::Type {
+        return fir::SequenceType::get(seqTy.getShape(), newElementType);
+      })
+      .Case<fir::PointerType, fir::HeapType, fir::ReferenceType,
+            fir::ClassType>([&](auto t) -> mlir::Type {
+        using FIRT = decltype(t);
+        return FIRT::get(
+            changeElementType(t.getEleTy(), newElementType, turnBoxIntoClass));
+      })
+      .Case<fir::BoxType>([&](fir::BoxType t) -> mlir::Type {
+        mlir::Type newInnerType =
+            changeElementType(t.getEleTy(), newElementType, false);
+        if (turnBoxIntoClass)
+          return fir::ClassType::get(newInnerType);
+        return fir::BoxType::get(newInnerType);
+      })
+      .Default([&](mlir::Type t) -> mlir::Type {
+        assert((fir::isa_trivial(t) || llvm::isa<fir::RecordType>(t) ||
+                llvm::isa<mlir::NoneType>(t)) &&
+               "unexpected FIR leaf type");
+        return newElementType;
+      });
+}
+
 } // namespace fir
 
 namespace {
@@ -1242,6 +1269,46 @@ mlir::Type BaseBoxType::unwrapInnerType() const {
   return fir::unwrapInnerType(getEleTy());
 }
 
+static mlir::Type
+changeTypeShape(mlir::Type type,
+                std::optional<fir::SequenceType::ShapeRef> newShape) {
+  return llvm::TypeSwitch<mlir::Type, mlir::Type>(type)
+      .Case<fir::SequenceType>([&](fir::SequenceType seqTy) -> mlir::Type {
+        if (newShape)
+          return fir::SequenceType::get(*newShape, seqTy.getEleTy());
+        return seqTy.getEleTy();
+      })
+      .Case<fir::PointerType, fir::HeapType, fir::ReferenceType, fir::BoxType,
+            fir::ClassType>([&](auto t) -> mlir::Type {
+        using FIRT = decltype(t);
+        return FIRT::get(changeTypeShape(t.getEleTy(), newShape));
+      })
+      .Default([&](mlir::Type t) -> mlir::Type {
+        assert((fir::isa_trivial(t) || llvm::isa<fir::RecordType>(t) ||
+                llvm::isa<mlir::NoneType>(t)) &&
+               "unexpected FIR leaf type");
+        if (newShape)
+          return fir::SequenceType::get(*newShape, t);
+        return t;
+      });
+}
+
+fir::BaseBoxType
+fir::BaseBoxType::getBoxTypeWithNewShape(mlir::Type shapeMold) const {
+  fir::SequenceType seqTy = fir::unwrapUntilSeqType(shapeMold);
+  std::optional<fir::SequenceType::ShapeRef> newShape;
+  if (seqTy)
+    newShape = seqTy.getShape();
+  return mlir::cast<fir::BaseBoxType>(changeTypeShape(*this, newShape));
+}
+
+bool fir::BaseBoxType::isAssumedRank() const {
+  if (auto seqTy =
+          mlir::dyn_cast<fir::SequenceType>(fir::unwrapRefType(getEleTy())))
+    return seqTy.hasUnknownShape();
+  return false;
+}
+
 //===----------------------------------------------------------------------===//
 // FIROpsDialect
 //===----------------------------------------------------------------------===//

flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90

@@ -0,0 +1,75 @@
+! Test lowering of calls to interface with pointer or allocatable
+! assumed rank dummy arguments.
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+module ifaces_ptr_alloc
+  interface
+    subroutine alloc_assumed_rank(y)
+      real, allocatable :: y(..)
+    end subroutine
+    subroutine pointer_assumed_rank(y)
+      real, optional, pointer :: y(..)
+    end subroutine
+    subroutine pointer_assumed_rank2(y)
+      real, intent(in), pointer :: y(..)
+    end subroutine
+  end interface
+end module
+
+subroutine scalar_alloc_to_assumed_rank(x)
+  use ifaces_ptr_alloc, only : alloc_assumed_rank
+  real, allocatable :: x
+  call alloc_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPscalar_alloc_to_assumed_rank(
+! CHECK-SAME:                                               %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<f32>>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFscalar_alloc_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> (!fir.ref<!fir.box<!fir.heap<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>)
+! CHECK:           %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK:           fir.call @_QPalloc_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>) -> ()
+
+subroutine r2_alloc_to_assumed_rank(x)
+  use ifaces_ptr_alloc, only : alloc_assumed_rank
+  real, allocatable :: x(:, :)
+  call alloc_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPr2_alloc_to_assumed_rank(
+! CHECK-SAME:                                           %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFr2_alloc_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>)
+! CHECK:           %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK:           fir.call @_QPalloc_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>) -> ()
+
+subroutine scalar_pointer_to_assumed_rank(x)
+  use ifaces_ptr_alloc, only : pointer_assumed_rank
+  real, pointer :: x
+  call pointer_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPscalar_pointer_to_assumed_rank(
+! CHECK-SAME:                                                 %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFscalar_pointer_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.ptr<f32>>>) -> (!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.ptr<f32>>>)
+! CHECK:           %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.box<!fir.ptr<f32>>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>
+! CHECK:           fir.call @_QPpointer_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> ()
+
+subroutine r2_pointer_to_assumed_rank(x)
+  use ifaces_ptr_alloc, only : pointer_assumed_rank
+  real, pointer :: x(:, :)
+  call pointer_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPr2_pointer_to_assumed_rank(
+! CHECK-SAME:                                             %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFr2_pointer_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>)
+! CHECK:           %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>
+! CHECK:           fir.call @_QPpointer_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> ()
+
+subroutine r2_target_to_pointer_assumed_rank(x)
+  use ifaces_ptr_alloc, only : pointer_assumed_rank2
+  real, target :: x(:, :)
+  call pointer_assumed_rank2(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPr2_target_to_pointer_assumed_rank(
+! CHECK-SAME:                                                    %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xf32>> {fir.bindc_name = "x", fir.target}) {
+! CHECK:           %[[VAL_1:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+! CHECK:           %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFr2_target_to_pointer_assumed_rankEx"} : (!fir.box<!fir.array<?x?xf32>>) -> (!fir.box<!fir.array<?x?xf32>>, !fir.box<!fir.array<?x?xf32>>)
+! CHECK:           %[[VAL_3:.*]] = fir.rebox %[[VAL_2]]#1 : (!fir.box<!fir.array<?x?xf32>>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+! CHECK:           fir.store %[[VAL_3]] to %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>
+! CHECK:           fir.call @_QPpointer_assumed_rank2(%[[VAL_4]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> ()

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

@@ -0,0 +1,141 @@
+! Test lowering of calls to interface with non pointer non allocatable
+! assumed rank dummy arguments.
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+module ifaces
+  interface
+    subroutine int_assumed_rank(y)
+      integer :: y(..)
+    end subroutine
+    subroutine int_opt_assumed_rank(y)
+      integer, optional :: y(..)
+    end subroutine
+    subroutine int_assumed_rank_bindc(y) bind(c)
+      integer :: y(..)
+    end subroutine
+  end interface
+end module
+
+subroutine int_scalar_to_assumed_rank(x)
+  use ifaces, only : int_assumed_rank
+  integer :: x
+  call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPint_scalar_to_assumed_rank(
+! CHECK-SAME:                                             %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFint_scalar_to_assumed_rankEx"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK:           %[[VAL_2:.*]] = fir.embox %[[VAL_1]]#0 : (!fir.ref<i32>) -> !fir.box<i32>
+! CHECK:           %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.box<i32>) -> !fir.box<!fir.array<*:i32>>
+! CHECK:           fir.call @_QPint_assumed_rank(%[[VAL_3]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_scalar_to_assumed_rank_bindc(x)
+  use ifaces, only : int_assumed_rank_bindc
+  integer :: x
+  call int_assumed_rank_bindc(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPint_scalar_to_assumed_rank_bindc(
+! CHECK-SAME:                                                   %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFint_scalar_to_assumed_rank_bindcEx"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK:           %[[VAL_2:.*]] = fir.embox %[[VAL_1]]#0 : (!fir.ref<i32>) -> !fir.box<i32>
+! CHECK:           %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.box<i32>) -> !fir.box<!fir.array<*:i32>>
+! CHECK:           fir.call @int_assumed_rank_bindc(%[[VAL_3]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_r1_to_assumed_rank(x)
+  use ifaces, only : int_assumed_rank
+  integer :: x(10)
+  call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPint_r1_to_assumed_rank(
+! CHECK-SAME:                                         %[[VAL_0:.*]]: !fir.ref<!fir.array<10xi32>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]] = arith.constant 10 : index
+! CHECK:           %[[VAL_2:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1>
+! CHECK:           %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]](%[[VAL_2]]) {uniq_name = "_QFint_r1_to_assumed_rankEx"} : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> (!fir.ref<!fir.array<10xi32>>, !fir.ref<!fir.array<10xi32>>)
+! CHECK:           %[[VAL_4:.*]] = fir.embox %[[VAL_3]]#0(%[[VAL_2]]) : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xi32>>
+! CHECK:           %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.box<!fir.array<10xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK:           fir.call @_QPint_assumed_rank(%[[VAL_5]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_r4_to_assumed_rank(x)
+  use ifaces, only : int_assumed_rank
+  integer :: x(2,3,4,5)
+  call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPint_r4_to_assumed_rank(
+! CHECK-SAME:                                         %[[VAL_0:.*]]: !fir.ref<!fir.array<2x3x4x5xi32>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]] = arith.constant 2 : index
+! CHECK:           %[[VAL_2:.*]] = arith.constant 3 : index
+! CHECK:           %[[VAL_3:.*]] = arith.constant 4 : index
+! CHECK:           %[[VAL_4:.*]] = arith.constant 5 : index
+! CHECK:           %[[VAL_5:.*]] = fir.shape %[[VAL_1]], %[[VAL_2]], %[[VAL_3]], %[[VAL_4]] : (index, index, index, index) -> !fir.shape<4>
+! CHECK:           %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_0]](%[[VAL_5]]) {uniq_name = "_QFint_r4_to_assumed_rankEx"} : (!fir.ref<!fir.array<2x3x4x5xi32>>, !fir.shape<4>) -> (!fir.ref<!fir.array<2x3x4x5xi32>>, !fir.ref<!fir.array<2x3x4x5xi32>>)
+! CHECK:           %[[VAL_7:.*]] = fir.embox %[[VAL_6]]#0(%[[VAL_5]]) : (!fir.ref<!fir.array<2x3x4x5xi32>>, !fir.shape<4>) -> !fir.box<!fir.array<2x3x4x5xi32>>
+! CHECK:           %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.array<2x3x4x5xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK:           fir.call @_QPint_assumed_rank(%[[VAL_8]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_assumed_shape_to_assumed_rank(x)
+  use ifaces, only : int_assumed_rank
+  integer :: x(:, :)
+  call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPint_assumed_shape_to_assumed_rank(
+! CHECK-SAME:                                                    %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xi32>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFint_assumed_shape_to_assumed_rankEx"} : (!fir.box<!fir.array<?x?xi32>>) -> (!fir.box<!fir.array<?x?xi32>>, !fir.box<!fir.array<?x?xi32>>)
+! CHECK:           %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK:           fir.call @_QPint_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_assumed_shape_to_assumed_rank_bindc(x)
+  use ifaces, only : int_assumed_rank_bindc
+  integer :: x(:, :)
+  call int_assumed_rank_bindc(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPint_assumed_shape_to_assumed_rank_bindc(
+! CHECK-SAME:                                                          %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xi32>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFint_assumed_shape_to_assumed_rank_bindcEx"} : (!fir.box<!fir.array<?x?xi32>>) -> (!fir.box<!fir.array<?x?xi32>>, !fir.box<!fir.array<?x?xi32>>)
+! CHECK:           %[[VAL_2:.*]] = arith.constant 0 : index
+! CHECK:           %[[VAL_3:.*]] = fir.shift %[[VAL_2]], %[[VAL_2]] : (index, index) -> !fir.shift<2>
+! CHECK:           %[[VAL_4:.*]] = fir.rebox %[[VAL_1]]#0(%[[VAL_3]]) : (!fir.box<!fir.array<?x?xi32>>, !fir.shift<2>) -> !fir.box<!fir.array<?x?xi32>>
+! CHECK:           %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK:           fir.call @int_assumed_rank_bindc(%[[VAL_5]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_allocatable_to_assumed_rank(x)
+  use ifaces, only : int_assumed_rank
+  integer, allocatable :: x(:, :)
+  call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPint_allocatable_to_assumed_rank(
+! CHECK-SAME:                                                  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFint_allocatable_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>) -> (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>)
+! CHECK:           %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>
+! CHECK:           %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>) -> !fir.box<!fir.array<?x?xi32>>
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK:           fir.call @_QPint_assumed_rank(%[[VAL_4]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_allocatable_to_assumed_rank_opt(x)
+  use ifaces, only : int_opt_assumed_rank
+  integer, allocatable :: x(:, :)
+  call int_opt_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPint_allocatable_to_assumed_rank_opt(
+! CHECK-SAME:                                                      %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFint_allocatable_to_assumed_rank_optEx"} : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>) -> (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>)
+! CHECK:           %[[VAL_2:.*]] = fir.load %[[VAL_1]]#1 : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>
+! CHECK:           %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>) -> !fir.heap<!fir.array<?x?xi32>>
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap<!fir.array<?x?xi32>>) -> i64
+! CHECK:           %[[VAL_5:.*]] = arith.constant 0 : i64
+! CHECK:           %[[VAL_6:.*]] = arith.cmpi ne, %[[VAL_4]], %[[VAL_5]] : i64
+! CHECK:           %[[VAL_7:.*]] = fir.if %[[VAL_6]] -> (!fir.box<!fir.array<?x?xi32>>) {
+! CHECK:             %[[VAL_8:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>
+! CHECK:             %[[VAL_9:.*]] = fir.rebox %[[VAL_8]] : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>) -> !fir.box<!fir.array<?x?xi32>>
+! CHECK:             fir.result %[[VAL_9]] : !fir.box<!fir.array<?x?xi32>>
+! CHECK:           } else {
+! CHECK:             %[[VAL_10:.*]] = fir.absent !fir.box<!fir.array<?x?xi32>>
+! CHECK:             fir.result %[[VAL_10]] : !fir.box<!fir.array<?x?xi32>>
+! CHECK:           }
+! CHECK:           %[[VAL_11:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK:           fir.call @_QPint_opt_assumed_rank(%[[VAL_11]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+! TODO: set assumed size last extent to -1.
+!subroutine int_r2_assumed_size_to_assumed_rank(x)
+!  use ifaces, only : int_assumed_rank
+!  integer :: x(10, *)
+!  call int_assumed_rank(x)
+!end subroutine

flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90

@@ -65,8 +65,8 @@ end subroutine test_real_2d_pointer
 ! CHECK-SAME:                                       %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>> {fir.bindc_name = "x"}) {
 ! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_real_2d_pointerEx"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>)
 ! CHECK:           %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
-! CHECK:           %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>) -> !fir.class<!fir.ptr<!fir.array<?x?xnone>>>
-! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.ptr<!fir.array<?x?xnone>>>) -> !fir.class<none>
+! CHECK:           %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>) -> !fir.class<!fir.array<?x?xnone>>
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.array<?x?xnone>>) -> !fir.class<none>
 ! CHECK:           fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
 ! CHECK:           return
 ! CHECK:         }
@@ -102,8 +102,9 @@ end subroutine test_derived_explicit_shape_array
 ! CHECK:           %[[VAL_8:.*]] = fir.convert %[[VAL_5]] : (!fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>) -> !fir.box<none>
 ! CHECK:           %[[VAL_10:.*]] = fir.call @_FortranAInitialize(%[[VAL_8]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> none
 ! CHECK:           %[[VAL_11:.*]] = fir.embox %[[VAL_3]]#0(%[[VAL_2]]) : (!fir.ref<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>
-! CHECK:           %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>) -> !fir.class<none>
-! CHECK:           fir.call @_QPcallee(%[[VAL_12]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK:           %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>) -> !fir.class<!fir.array<10xnone>>
+! CHECK:           %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (!fir.class<!fir.array<10xnone>>) -> !fir.class<none>
+! CHECK:           fir.call @_QPcallee(%[[VAL_13]]) fastmath<contract> : (!fir.class<none>) -> ()
 ! CHECK:           return
 ! CHECK:         }
 
@@ -116,8 +117,8 @@ end subroutine test_up_allocatable_2d_array
 ! CHECK-SAME:                                               %[[VAL_0:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>> {fir.bindc_name = "x"}) {
 ! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFtest_up_allocatable_2d_arrayEx"} : (!fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>) -> (!fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>, !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>)
 ! CHECK:           %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>
-! CHECK:           %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> !fir.class<!fir.heap<!fir.array<?x?xnone>>>
-! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> !fir.class<none>
+! CHECK:           %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> !fir.class<!fir.array<?x?xnone>>
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.array<?x?xnone>>) -> !fir.class<none>
 ! CHECK:           fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
 ! CHECK:           return
 ! CHECK:         }
@@ -131,8 +132,8 @@ end subroutine test_up_pointer_1d_array
 ! CHECK-SAME:                                           %[[VAL_0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>> {fir.bindc_name = "x"}) {
 ! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_up_pointer_1d_arrayEx"} : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>, !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>)
 ! CHECK:           %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>
-! CHECK:           %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.ptr<!fir.array<?xnone>>>) -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
-! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.ptr<!fir.array<?xnone>>>) -> !fir.class<none>
+! CHECK:           %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.ptr<!fir.array<?xnone>>>) -> !fir.class<!fir.array<?xnone>>
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.array<?xnone>>) -> !fir.class<none>
 ! CHECK:           fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
 ! CHECK:           return
 ! CHECK:         }

flang/test/Lower/HLFIR/ignore-type-assumed-shape.f90

@@ -0,0 +1,62 @@
+! Test descriptor dummy argument preparation when the
+! dummy has IGNORE_TKR(t). The descriptor should be prepared
+! according to the actual argument type, but its bounds and
+! attributes should still be set as expected for the dummy.
+! RUN: bbc -emit-hlfir --polymorphic-type -o - %s | FileCheck %s
+
+module tkr_ifaces
+  interface
+    subroutine takes_assumed_shape_ignore_tkr_t(x) bind(c)
+      !dir$ ignore_tkr (t) x
+      integer :: x(:)
+    end subroutine
+  end interface
+end module
+
+subroutine test_ignore_t_1(x)
+  use tkr_ifaces
+  real :: x(10)
+  call takes_assumed_shape_ignore_tkr_t(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_ignore_t_1(
+! CHECK:           %[[VAL_5:.*]] = arith.constant 0 : index
+! CHECK:           %[[VAL_6:.*]] = fir.shift %[[VAL_5]] : (index) -> !fir.shift<1>
+! CHECK:           %[[VAL_7:.*]] = fir.rebox %{{.*}}(%[[VAL_6]]) : (!fir.box<!fir.array<10xf32>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
+! CHECK:           %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xi32>>
+! CHECK:           fir.call @takes_assumed_shape_ignore_tkr_t(%[[VAL_8]]) fastmath<contract> : (!fir.box<!fir.array<?xi32>>) -> ()
+
+subroutine test_ignore_t_2(x)
+  use tkr_ifaces
+  class(*) :: x(:)
+  call takes_assumed_shape_ignore_tkr_t(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_ignore_t_2(
+! CHECK:           %[[VAL_2:.*]] = arith.constant 0 : index
+! CHECK:           %[[VAL_3:.*]] = fir.shift %[[VAL_2]] : (index) -> !fir.shift<1>
+! CHECK:           %[[VAL_4:.*]] = fir.rebox %{{.*}}(%[[VAL_3]]) : (!fir.class<!fir.array<?xnone>>, !fir.shift<1>) -> !fir.class<!fir.array<?xnone>>
+! CHECK:           %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.class<!fir.array<?xnone>>) -> !fir.box<!fir.array<?xi32>>
+! CHECK:           fir.call @takes_assumed_shape_ignore_tkr_t(%[[VAL_5]]) fastmath<contract> : (!fir.box<!fir.array<?xi32>>) -> ()
+
+subroutine test_ignore_t_3(x)
+  use tkr_ifaces
+  real :: x(10)
+  call takes_assumed_shape_ignore_tkr_t(x+1.0)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_ignore_t_3(
+! CHECK:           %[[VAL_12:.*]] = arith.constant 0 : index
+! CHECK:           %[[VAL_13:.*]] = fir.shift %[[VAL_12]] : (index) -> !fir.shift<1>
+! CHECK:           %[[VAL_14:.*]] = fir.rebox %{{.*}}(%[[VAL_13]]) : (!fir.box<!fir.array<10xf32>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
+! CHECK:           %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xi32>>
+! CHECK:           fir.call @takes_assumed_shape_ignore_tkr_t(%[[VAL_15]]) fastmath<contract> : (!fir.box<!fir.array<?xi32>>) -> ()
+
+subroutine test_ignore_t_4(x)
+  use tkr_ifaces
+  real, pointer :: x(:)
+  call takes_assumed_shape_ignore_tkr_t(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_ignore_t_4(
+! CHECK:           %[[VAL_3:.*]] = arith.constant 0 : index
+! CHECK:           %[[VAL_4:.*]] = fir.shift %[[VAL_3]] : (index) -> !fir.shift<1>
+! CHECK:           %[[VAL_5:.*]] = fir.rebox %{{.*}}(%[[VAL_4]]) : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
+! CHECK:           %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xi32>>
+! CHECK:           fir.call @takes_assumed_shape_ignore_tkr_t(%[[VAL_6]]) fastmath<contract> : (!fir.box<!fir.array<?xi32>>) -> ()