diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -705,8 +705,9 @@ } // CHARACTER with compile time constant length. if (cat == Fortran::common::TypeCategory::Character) - TODO(interface.converter.getCurrentLocation(), - "[translateDynamicType] Character"); + if (std::optional constantLen = + toInt64(dynamicType.GetCharLength())) + return getConverter().genType(cat, dynamicType.kind(), {*constantLen}); // INTEGER, REAL, LOGICAL, COMPLEX, and CHARACTER with dynamic length. return getConverter().genType(cat, dynamicType.kind()); } diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -430,7 +430,11 @@ /// one. ExtValue gen(Fortran::semantics::SymbolRef sym) { if (Fortran::lower::SymbolBox val = symMap.lookupSymbol(sym)) - return val.match([&val](auto &) { return val.toExtendedValue(); }); + return val.match( + [&](const Fortran::lower::SymbolBox::PointerOrAllocatable &boxAddr) { + return fir::factory::genMutableBoxRead(builder, getLoc(), boxAddr); + }, + [&val](auto &) { return val.toExtendedValue(); }); LLVM_DEBUG(llvm::dbgs() << "unknown symbol: " << sym << "\nmap: " << symMap << '\n'); fir::emitFatalError(getLoc(), "symbol is not mapped to any IR value"); @@ -1482,7 +1486,28 @@ if (arg.passBy == PassBy::BaseAddress) { caller.placeInput(arg, fir::getBase(argAddr)); } else { - TODO(loc, "procedureref PassBy::BoxChar"); + assert(arg.passBy == PassBy::BoxChar); + auto helper = fir::factory::CharacterExprHelper{builder, loc}; + auto boxChar = argAddr.match( + [&](const fir::CharBoxValue &x) { return helper.createEmbox(x); }, + [&](const fir::CharArrayBoxValue &x) { + return helper.createEmbox(x); + }, + [&](const auto &x) -> mlir::Value { + // Fortran allows an actual argument of a completely different + // type to be passed to a procedure expecting a CHARACTER in the + // dummy argument position. When this happens, the data pointer + // argument is simply assumed to point to CHARACTER data and the + // LEN argument used is garbage. Simulate this behavior by + // free-casting the base address to be a !fir.char reference and + // setting the LEN argument to undefined. What could go wrong? + auto dataPtr = fir::getBase(x); + assert(!dataPtr.getType().template isa()); + return builder.convertWithSemantics( + loc, argTy, dataPtr, + /*allowCharacterConversion=*/true); + }); + caller.placeInput(arg, boxChar); } } else if (arg.passBy == PassBy::Box) { // Before lowering to an address, handle the allocatable/pointer actual diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -646,6 +646,24 @@ assert(result.empty() || result.size() == box.dynamicBound().size()); } +/// Lower explicit character length if any. Return empty mlir::Value if no +/// explicit length. +static mlir::Value +lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, const Fortran::lower::BoxAnalyzer &box, + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + if (!box.isChar()) + return mlir::Value{}; + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + mlir::Type lenTy = builder.getCharacterLengthType(); + if (llvm::Optional len = box.getCharLenConst()) + return builder.createIntegerConstant(loc, lenTy, *len); + if (llvm::Optional lenExpr = box.getCharLenExpr()) + return genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx); + return mlir::Value{}; +} + /// Treat negative values as undefined. Assumed size arrays will return -1 from /// the front end for example. Using negative values can produce hard to find /// bugs much further along in the compilation. @@ -694,7 +712,11 @@ // Lower non deferred parameters. llvm::SmallVector nonDeferredLenParams; if (ba.isChar()) { - TODO(loc, "mapSymbolAttributes allocatble or pointer char"); + if (mlir::Value len = + lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx)) + nonDeferredLenParams.push_back(len); + else if (Fortran::semantics::IsAssumedLengthCharacter(sym)) + TODO(loc, "assumed length character allocatable"); } else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) { if (const Fortran::semantics::DerivedTypeSpec *derived = declTy->AsDerived()) diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp --- a/flang/lib/Optimizer/Builder/MutableBox.cpp +++ b/flang/lib/Optimizer/Builder/MutableBox.cpp @@ -104,8 +104,10 @@ /// Get base address of allocated/associated entity. mlir::Value readBaseAddress() { if (irBox) { - auto heapOrPtrTy = box.getBoxTy().getEleTy(); - return builder.create(loc, heapOrPtrTy, irBox); + auto memrefTy = box.getBoxTy().getEleTy(); + if (!fir::isa_ref_type(memrefTy)) + memrefTy = builder.getRefType(memrefTy); + return builder.create(loc, memrefTy, irBox); } auto addrVar = box.getMutableProperties().addr; return builder.create(loc, addrVar); @@ -144,7 +146,7 @@ /// also read into it. llvm::SmallVector readShape(llvm::SmallVectorImpl *lbounds = nullptr) { - llvm::SmallVector extents(box.rank()); + llvm::SmallVector extents; auto rank = box.rank(); for (decltype(rank) dim = 0; dim < rank; ++dim) { auto [lb, extent] = readShape(dim); diff --git a/flang/test/Lower/allocatable-callee.f90 b/flang/test/Lower/allocatable-callee.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/allocatable-callee.f90 @@ -0,0 +1,138 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test allocatable dummy argument on callee side + +! CHECK-LABEL: func @_QPtest_scalar( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>{{.*}}) +subroutine test_scalar(x) + real, allocatable :: x + + print *, x + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>) -> !fir.heap + ! CHECK: %[[val:.*]] = fir.load %[[addr]] : !fir.heap +end subroutine + +! CHECK-LABEL: func @_QPtest_array( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}}) +subroutine test_array(x) + integer, allocatable :: x(:,:) + + print *, x(1,2) + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK-DAG: fir.box_addr %[[box]] : (!fir.box>>) -> !fir.heap> + ! CHECK-DAG: fir.box_dims %[[box]], %c0{{.*}} : (!fir.box>>, index) -> (index, index, index) + ! CHECK-DAG: fir.box_dims %[[box]], %c1{{.*}} : (!fir.box>>, index) -> (index, index, index) +end subroutine + +! CHECK-LABEL: func @_QPtest_char_scalar_deferred( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}}) +subroutine test_char_scalar_deferred(c) + character(:), allocatable :: c + external foo1 + call foo1(c) + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>>) -> !fir.heap> + ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]] : (!fir.box>>) -> index + ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap>) -> !fir.ref> + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> () +end subroutine + +! CHECK-LABEL: func @_QPtest_char_scalar_explicit_cst( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}}) +subroutine test_char_scalar_explicit_cst(c) + character(10), allocatable :: c + external foo1 + call foo1(c) + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>>) -> !fir.heap> + ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap>) -> !fir.ref> + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %c10{{.*}} : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> () +end subroutine + +! CHECK-LABEL: func @_QPtest_char_scalar_explicit_dynamic( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}}, %[[arg1:.*]]: !fir.ref{{.*}}) +subroutine test_char_scalar_explicit_dynamic(c, n) + integer :: n + character(n), allocatable :: c + external foo1 + ! Check that the length expr was evaluated before the execution parts. + ! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref + n = n + 1 + ! CHECK: fir.store {{.*}} to %arg1 : !fir.ref + call foo1(c) + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>>) -> !fir.heap> + ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap>) -> !fir.ref> + ! CHECK-DAG: %[[len_cast:.*]] = fir.convert %[[len]] : (i32) -> index + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len_cast]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> () +end subroutine + +! CHECK-LABEL: func @_QPtest_char_array_deferred( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>>{{.*}}) +subroutine test_char_array_deferred(c) + character(:), allocatable :: c(:) + external foo1 + call foo1(c(10)) + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>>>> + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>>>) -> !fir.heap>> + ! CHECK-DAG: fir.box_dims %[[box]], %c0{{.*}} : (!fir.box>>>, index) -> (index, index, index) + ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]] : (!fir.box>>>) -> index + ! [...] address computation + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %{{.*}}, %[[len]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> () +end subroutine + +! CHECK-LABEL: func @_QPtest_char_array_explicit_cst( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>>{{.*}}) +subroutine test_char_array_explicit_cst(c) + character(10), allocatable :: c(:) + external foo1 + call foo1(c(3)) + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>>>> + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>>>) -> !fir.heap>> + ! [...] address computation + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %{{.*}}, %c10{{.*}} : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> () +end subroutine + +! CHECK-LABEL: func @_QPtest_char_array_explicit_dynamic( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>>{{.*}}, %[[arg1:.*]]: !fir.ref{{.*}}) +subroutine test_char_array_explicit_dynamic(c, n) + integer :: n + character(n), allocatable :: c(:) + external foo1 + ! Check that the length expr was evaluated before the execution parts. + ! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref + n = n + 1 + ! CHECK: fir.store {{.*}} to %arg1 : !fir.ref + call foo1(c(1)) + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>>>> + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>>>) -> !fir.heap>> + ! [...] address computation + ! CHECK: fir.coordinate_of + ! CHECK-DAG: %[[len_cast:.*]] = fir.convert %[[len]] : (i32) -> index + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %{{.*}}, %[[len_cast]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPfoo1(%[[boxchar]]) : (!fir.boxchar<1>) -> () +end subroutine + +! Check that when reading allocatable length from descriptor, the width is taking +! into account when the kind is not 1. + +! CHECK-LABEL: func @_QPtest_char_scalar_deferred_k2( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}}) +subroutine test_char_scalar_deferred_k2(c) + character(kind=2, len=:), allocatable :: c + external foo2 + call foo2(c) + ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box>>) -> !fir.heap> + ! CHECK-DAG: %[[size:.*]] = fir.box_elesize %[[box]] : (!fir.box>>) -> index + ! CHECK-DAG: %[[len:.*]] = arith.divsi %[[size]], %c2{{.*}} : index + ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap>) -> !fir.ref> + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len]] : (!fir.ref>, index) -> !fir.boxchar<2> + ! CHECK: fir.call @_QPfoo2(%[[boxchar]]) : (!fir.boxchar<2>) -> () +end subroutine