[flang] Lower BIND(C) assumed length to CFI descriptor

flang/lib/Lower/CallInterface.cpp

@@ -702,7 +702,7 @@ class Fortran::lower::CallInterfaceImpl {
               [&](const Fortran::evaluate::characteristics::DummyDataObject
                       &dummy) {
                 const auto &entity = getDataObjectEntity(std::get<1>(pair));
-                if (dummy.CanBePassedViaImplicitInterface())
+                if (!isBindC && dummy.CanBePassedViaImplicitInterface())
                   handleImplicitDummy(&argCharacteristics, dummy, entity);
                 else
                   handleExplicitDummy(&argCharacteristics, dummy, entity,
@@ -871,7 +871,8 @@ class Fortran::lower::CallInterfaceImpl {
 
   // Define when an explicit argument must be passed in a fir.box.
   bool dummyRequiresBox(
-      const Fortran::evaluate::characteristics::DummyDataObject &obj) {
+      const Fortran::evaluate::characteristics::DummyDataObject &obj,
+      bool isBindC) {
     using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
     using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attrs;
     constexpr ShapeAttrs shapeRequiringBox = {
@@ -888,6 +889,8 @@ class Fortran::lower::CallInterfaceImpl {
       if (const Fortran::semantics::Scope *scope = derived->scope())
         // Need to pass length type parameters in fir.box if any.
         return scope->IsDerivedTypeWithLengthParameter();
+    if (isBindC && obj.type.type().IsAssumedLengthCharacter())
+      return true; // Fortran 2018 18.3.6 point 2 (5)
     return false;
   }
 
@@ -973,7 +976,7 @@ class Fortran::lower::CallInterfaceImpl {
       addFirOperand(boxRefType, nextPassedArgPosition(), Property::MutableBox,
                     attrs);
       addPassedArg(PassEntityBy::MutableBox, entity, characteristics);
-    } else if (dummyRequiresBox(obj)) {
+    } else if (dummyRequiresBox(obj, isBindC)) {
       // Pass as fir.box or fir.class
       if (isValueAttr)
         TODO(loc, "assumed shape dummy argument with VALUE attribute");

flang/lib/Lower/ConvertVariable.cpp

@@ -1275,12 +1275,14 @@ static void instantiateCommon(Fortran::lower::AbstractConverter &converter,
 
 /// Helper to decide if a dummy argument must be tracked in an BoxValue.
 static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym,
-                            mlir::Value dummyArg) {
+                            mlir::Value dummyArg,
+                            Fortran::lower::AbstractConverter &converter) {
   // Only dummy arguments coming as fir.box can be tracked in an BoxValue.
   if (!dummyArg || !dummyArg.getType().isa<fir::BaseBoxType>())
     return false;
   // Non contiguous arrays must be tracked in an BoxValue.
-  if (sym.Rank() > 0 && !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS))
+  if (sym.Rank() > 0 && !Fortran::evaluate::IsSimplyContiguous(
+                            sym, converter.getFoldingContext()))
     return true;
   // Assumed rank and optional fir.box cannot yet be read while lowering the
   // specifications.
@@ -1713,16 +1715,60 @@ void Fortran::lower::mapSymbolAttributes(
 
   if (isDummy) {
     mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr();
-    if (lowerToBoxValue(sym, dummyArg)) {
+    if (lowerToBoxValue(sym, dummyArg, converter)) {
       llvm::SmallVector<mlir::Value> lbounds;
       llvm::SmallVector<mlir::Value> explicitExtents;
       llvm::SmallVector<mlir::Value> explicitParams;
       // Lower lower bounds, explicit type parameters and explicit
       // extents if any.
-      if (ba.isChar())
+      if (ba.isChar()) {
         if (mlir::Value len =
                 lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx))
           explicitParams.push_back(len);
+        if (sym.Rank() == 0) {
+          // Do not keep scalar characters as fir.box (even when optional).
+          // Lowering and FIR is not meant to deal with scalar characters as
+          // fir.box outside of calls.
+          auto boxTy = dummyArg.getType().dyn_cast<fir::BaseBoxType>();
+          mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
+          mlir::Type lenType = builder.getCharacterLengthType();
+          mlir::Value addr, len;
+          if (Fortran::semantics::IsOptional(sym)) {
+            auto isPresent = builder.create<fir::IsPresentOp>(
+                loc, builder.getI1Type(), dummyArg);
+            auto addrAndLen =
+                builder
+                    .genIfOp(loc, {refTy, lenType}, isPresent,
+                             /*withElseRegion=*/true)
+                    .genThen([&]() {
+                      mlir::Value readAddr =
+                          builder.create<fir::BoxAddrOp>(loc, refTy, dummyArg);
+                      mlir::Value readLength =
+                          charHelp.readLengthFromBox(dummyArg);
+                      builder.create<fir::ResultOp>(
+                          loc, mlir::ValueRange{readAddr, readLength});
+                    })
+                    .genElse([&] {
+                      mlir::Value readAddr = builder.genAbsentOp(loc, refTy);
+                      mlir::Value readLength =
+                          fir::factory::createZeroValue(builder, loc, lenType);
+                      builder.create<fir::ResultOp>(
+                          loc, mlir::ValueRange{readAddr, readLength});
+                    })
+                    .getResults();
+            addr = addrAndLen[0];
+            len = addrAndLen[1];
+          } else {
+            addr = builder.create<fir::BoxAddrOp>(loc, refTy, dummyArg);
+            len = charHelp.readLengthFromBox(dummyArg);
+          }
+          if (!explicitParams.empty())
+            len = explicitParams[0];
+          ::genDeclareSymbol(converter, symMap, sym, addr, len, /*extents=*/{},
+                             /*lbounds=*/{}, replace);
+          return;
+        }
+      }
       // TODO: derived type length parameters.
       lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx);
       lowerExplicitExtents(converter, loc, ba, lbounds, explicitExtents, symMap,

flang/lib/Optimizer/Builder/BoxValue.cpp

@@ -214,11 +214,6 @@ bool fir::BoxValue::verify() const {
     return false;
   if (!lbounds.empty() && lbounds.size() != rank())
     return false;
-  // Explicit extents are here to cover cases where an explicit-shape dummy
-  // argument comes as a fir.box. This can only happen with derived types and
-  // unlimited polymorphic.
-  if (!extents.empty() && !(isDerived() || isUnlimitedPolymorphic()))
-    return false;
   if (!extents.empty() && extents.size() != rank())
     return false;
   if (isCharacter() && explicitParams.size() > 1)

flang/test/Lower/HLFIR/bindc-assumed-length.f90

@@ -0,0 +1,41 @@
+! Test that assumed length character scalars and explicit shape arrays are passed via
+! CFI descriptor (fir.box) in BIND(C) procedures. They are passed only by address
+! and length  in non BIND(C) procedures. See Fortran 2018 standard 18.3.6 point 2(5).
+! RUN: bbc -hlfir -emit-fir -o - %s 2>&1 | FileCheck %s
+
+module bindcchar
+contains
+! CHECK-LABEL: func.func @bindc(
+! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.char<1,?>>
+! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.array<100x!fir.char<1,?>>>
+subroutine bindc(c1, c3) bind(c)
+  character(*) ::  c1, c3(100)
+ print *, c1(1:3), c3(5)(1:3)
+end subroutine
+
+! CHECK-LABEL:  func.func @bindc_optional(
+! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.char<1,?>>
+! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.array<100x!fir.char<1,?>>>
+subroutine bindc_optional(c1, c3) bind(c)
+  character(*), optional ::  c1, c3(100)
+ print *, c1(1:3), c3(5)(1:3)
+end subroutine
+
+! CHECK-LABEL:  func.func @_QMbindccharPnot_bindc(
+! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
+! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
+subroutine not_bindc(c1, c3)
+  character(*) :: c1,  c3(100)
+  call bindc(c1, c3)
+  call bindc_optional(c1, c3)
+end subroutine
+
+! CHECK-LABEL:  func.func @_QMbindccharPnot_bindc_optional(
+! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
+! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
+subroutine not_bindc_optional(c1, c3)
+  character(*), optional :: c1,  c3(100)
+  call bindc(c1, c3)
+  call bindc_optional(c1, c3)
+end subroutine
+end module