diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h --- a/flang/include/flang/Lower/Allocatable.h +++ b/flang/include/flang/Lower/Allocatable.h @@ -33,6 +33,10 @@ struct DeallocateStmt; } // namespace parser +namespace semantics { +class Symbol; +} // namespace semantics + namespace lower { struct SymbolBox; @@ -75,6 +79,12 @@ /// Is \p expr a reference to an entity with the POINTER attribute? bool isWholePointer(const SomeExpr &expr); +/// Read the length from \p box for an assumed length character allocatable or +/// pointer dummy argument given by \p sym. +mlir::Value getAssumedCharAllocatableOrPointerLen( + fir::FirOpBuilder &builder, mlir::Location loc, + const Fortran::semantics::Symbol &sym, mlir::Value box); + } // namespace lower } // namespace Fortran diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -725,3 +725,36 @@ return Fortran::semantics::IsPointer(*sym); return false; } + +mlir::Value Fortran::lower::getAssumedCharAllocatableOrPointerLen( + fir::FirOpBuilder &builder, mlir::Location loc, + const Fortran::semantics::Symbol &sym, mlir::Value box) { + // Read length from fir.box (explicit expr cannot safely be re-evaluated + // here). + auto readLength = [&]() { + fir::BoxValue boxLoad = + builder.create(loc, fir::getBase(box)).getResult(); + return fir::factory::readCharLen(builder, loc, boxLoad); + }; + if (Fortran::semantics::IsOptional(sym)) { + mlir::IndexType idxTy = builder.getIndexType(); + // It is not safe to unconditionally read boxes of optionals in case + // they are absents. According to 15.5.2.12 3 (9), it is illegal to + // inquire the length of absent optional, even if non deferred, so + // it's fine to use undefOp in this case. + auto isPresent = builder.create(loc, builder.getI1Type(), + fir::getBase(box)); + mlir::Value len = + builder.genIfOp(loc, {idxTy}, isPresent, true) + .genThen( + [&]() { builder.create(loc, readLength()); }) + .genElse([&]() { + auto undef = builder.create(loc, idxTy); + builder.create(loc, undef.getResult()); + }) + .getResults()[0]; + return len; + } + + return readLength(); +} 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 @@ -1351,7 +1351,9 @@ lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx)) nonDeferredLenParams.push_back(len); else if (Fortran::semantics::IsAssumedLengthCharacter(sym)) - TODO(loc, "assumed length character allocatable"); + nonDeferredLenParams.push_back( + Fortran::lower::getAssumedCharAllocatableOrPointerLen( + builder, loc, sym, boxAlloc)); } else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) { if (const Fortran::semantics::DerivedTypeSpec *derived = declTy->AsDerived()) diff --git a/flang/lib/Lower/HostAssociations.cpp b/flang/lib/Lower/HostAssociations.cpp --- a/flang/lib/Lower/HostAssociations.cpp +++ b/flang/lib/Lower/HostAssociations.cpp @@ -270,35 +270,9 @@ builder.createIntegerConstant(loc, idxTy, *len)); } else if (Fortran::semantics::IsAssumedLengthCharacter(sym) || ba.getCharLenExpr()) { - // Read length from fir.box (explicit expr cannot safely be re-evaluated - // here). - auto readLength = [&]() { - fir::BoxValue boxLoad = - builder.create(loc, fir::getBase(args.valueInTuple)) - .getResult(); - return fir::factory::readCharLen(builder, loc, boxLoad); - }; - if (Fortran::semantics::IsOptional(sym)) { - // It is not safe to unconditionally read boxes of optionals in case - // they are absents. According to 15.5.2.12 3 (9), it is illegal to - // inquire the length of absent optional, even if non deferred, so - // it's fine to use undefOp in this case. - auto isPresent = builder.create( - loc, builder.getI1Type(), fir::getBase(args.valueInTuple)); - mlir::Value len = - builder.genIfOp(loc, {idxTy}, isPresent, true) - .genThen([&]() { - builder.create(loc, readLength()); - }) - .genElse([&]() { - auto undef = builder.create(loc, idxTy); - builder.create(loc, undef.getResult()); - }) - .getResults()[0]; - nonDeferredLenParams.push_back(len); - } else { - nonDeferredLenParams.push_back(readLength()); - } + nonDeferredLenParams.push_back( + Fortran::lower::getAssumedCharAllocatableOrPointerLen( + builder, loc, sym, args.valueInTuple)); } } else if (isDerivedWithLenParameters(sym)) { TODO(loc, "host associated derived type allocatable or pointer with " diff --git a/flang/test/Lower/allocatable-callee.f90 b/flang/test/Lower/allocatable-callee.f90 --- a/flang/test/Lower/allocatable-callee.f90 +++ b/flang/test/Lower/allocatable-callee.f90 @@ -142,3 +142,40 @@ ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len]] : (!fir.ref>, index) -> !fir.boxchar<2> ! CHECK: fir.call @_QPfoo2(%[[boxchar]]) : (!fir.boxchar<2>) -> () end subroutine + +! Check that assumed length character allocatables are reading the length from +! the descriptor. + +! CHECK-LABEL: _QPtest_char_assumed( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}} +subroutine test_char_assumed(a) + integer :: n + character(len=*), allocatable :: a + ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK: %[[argLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box>>) -> index + + n = len(a) + ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32 + ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref +end subroutine + +! CHECK-LABEL: _QPtest_char_assumed_optional( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}} +subroutine test_char_assumed_optional(a) + integer :: n + character(len=*), allocatable, optional :: a + ! CHECK: %[[argPresent:.*]] = fir.is_present %[[arg0]] : (!fir.ref>>>) -> i1 + ! CHECK: %[[argLen:.*]] = fir.if %[[argPresent]] -> (index) { + ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK: %[[argEleSz:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box>>) -> index + ! CHECK: fir.result %[[argEleSz]] : index + ! CHECK: } else { + ! CHECK: %[[undef:.*]] = fir.undefined index + ! CHECK: fir.result %[[undef]] : index + + if (present(a)) then + n = len(a) + ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32 + ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref + endif +end subroutine diff --git a/flang/test/Lower/pointer-args-callee.f90 b/flang/test/Lower/pointer-args-callee.f90 new file mode 100755 --- /dev/null +++ b/flang/test/Lower/pointer-args-callee.f90 @@ -0,0 +1,37 @@ +! Test calls with POINTER dummy arguments on the callee side. +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! CHECK-LABEL: func @_QPchar_assumed( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}} +subroutine char_assumed(a) + integer :: n + character(len=*), pointer :: a + ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK: %[[argLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box>>) -> index + + n = len(a) + ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32 + ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref +end subroutine + +! CHECK-LABEL: func @_QPchar_assumed_optional( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}} +subroutine char_assumed_optional(a) + integer :: n + character(len=*), pointer, optional :: a + ! CHECK: %[[argPresent:.*]] = fir.is_present %[[arg0]] : (!fir.ref>>>) -> i1 + ! CHECK: %[[argLen:.*]] = fir.if %[[argPresent]] -> (index) { + ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK: %[[argLoadLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box>>) -> index + ! CHECK: fir.result %[[argLoadLen]] : index + ! CHECK: } else { + ! CHECK: %[[undef:.*]] = fir.undefined index + ! CHECK: fir.result %[[undef]] : index + ! CHECK: } + + if (present(a)) then + n = len(a) + ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32 + ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref + endif +end subroutine