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 @@ -2324,6 +2324,8 @@ const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol(); assert(symbol && "expected symbol in ProcedureRef of statement functions"); const auto &details = symbol->get(); + mlir::Location loc = getLoc(); + fir::factory::CharacterExprHelper charHelper(builder, loc); // Statement functions have their own scope, we just need to associate // the dummy symbols to argument expressions. They are no @@ -2350,9 +2352,20 @@ type->characterTypeSpec().length().GetExplicit()) { mlir::Value len = fir::getBase(genval(*lenExpr)); // F2018 7.4.4.2 point 5. - len = fir::factory::genMaxWithZero(builder, getLoc(), len); - symMap.addSymbol(*arg, - replaceScalarCharacterLength(gen(*expr), len)); + len = fir::factory::genMaxWithZero(builder, loc, len); + + fir::ExtendedValue replaced = + replaceScalarCharacterLength(gen(*expr), len); + + // Make a temporary copy of the actual dummy argument length. + const fir::CharBoxValue *charBox = replaced.getCharBox(); + mlir::Value charAddr = charBox->getAddr(); + mlir::Type charType = fir::unwrapPassByRefType(charAddr.getType()); + fir::CharBoxValue charTemp = + charHelper.createCharacterTemp(charType, len); + charHelper.createCopy(charTemp, *charBox, len); + + symMap.addSymbol(*arg, charTemp); continue; } symMap.addSymbol(*arg, gen(*expr)); @@ -2368,6 +2381,44 @@ symMap.addSymbol(*sym, gen(details->symbol())); ExtValue result = genval(details.stmtFunction().value()); + + // Create a temporary of the result length and assign the actual result. + // Padding is added if the actual result is smaller than the result langth. + if (const fir::CharBoxValue *charBox = result.getCharBox()) { + mlir::Operation *op = fir::getBase(result).getDefiningOp(); + if (mlir::isa(*op)) { + fir::ConvertOp convert = mlir::cast(*op); + if (fir::CharacterType currentResultType = + fir::unwrapPassByRefType(convert.getValue().getType()) + .cast()) { + mlir::Value currentResultLen = builder.createIntegerConstant( + loc, charBox->getLen().getType(), currentResultType.getLen()); + fir::CharBoxValue currentResult{convert.getValue(), currentResultLen}; + mlir::Location loc = getLoc(); + if (llvm::Optional stmtFctLen = + fir::factory::getIntIfConstant(charBox->getLen())) { + if (currentResultType.getLen() < *stmtFctLen) { + fir::CharBoxValue resultTemp = charHelper.createCharacterTemp( + charBox->getBuffer().getType(), *stmtFctLen); + charHelper.createAssign(resultTemp, + fir::ExtendedValue{currentResult}); + result = fir::ExtendedValue{resultTemp}; + } else { + mlir::Value newLen = builder.createIntegerConstant( + loc, charBox->getLen().getType(), *stmtFctLen); + result = replaceScalarCharacterLength(*charBox, newLen); + } + } else { + fir::CharBoxValue resultTemp = charHelper.createCharacterTemp( + charBox->getBuffer().getType(), charBox->getLen()); + charHelper.createAssign(resultTemp, + fir::ExtendedValue{currentResult}); + result = fir::ExtendedValue{resultTemp}; + } + } + } + } + LLVM_DEBUG(llvm::dbgs() << "stmt-function: " << result << '\n'); symMap.popScope(); return result; diff --git a/flang/test/Lower/statement-function.f90 b/flang/test/Lower/statement-function.f90 --- a/flang/test/Lower/statement-function.f90 +++ b/flang/test/Lower/statement-function.f90 @@ -87,14 +87,20 @@ end function ! Test statement function with character arguments -! CHECK-LABEL: @_QPtest_stmt_character +! CHECK-LABEL: @_QPtest_stmt_character( +! CHECK-SAME: %[[arg0:.*]]: !fir.boxchar<1> integer function test_stmt_character(c, j) integer :: i, j, func, argj character(10) :: c, argc - ! CHECK-DAG: %[[unboxed:.*]]:2 = fir.unboxchar %arg0 : + ! CHECK-DAG: %[[unboxed:.*]]:2 = fir.unboxchar %[[arg0]] ! CHECK-DAG: %[[c10:.*]] = arith.constant 10 : + ! CHECK: %[[alloca:.*]] = fir.alloca !fir.char<1,10> {bindc_name = ".chrtmp"} + ! CHECK: %[[cast_alloca:.*]] = fir.convert %[[alloca]] : (!fir.ref>) -> !fir.ref + ! CHECK: %[[cast_unboxed:.*]] = fir.convert %[[unboxed]]#0 : (!fir.ref>) -> !fir.ref + ! CHECK: fir.call @llvm.memmove.p0.p0.i64(%[[cast_alloca]], %[[cast_unboxed]], %7, %{{.*}}) : (!fir.ref, !fir.ref, i64, i1) -> () + ! CHECK: %[[cast_alloca:.*]] = fir.convert %[[alloca]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[c10_cast:.*]] = fir.convert %[[c10]] : (i32) -> index - ! CHECK: %[[c:.*]] = fir.emboxchar %[[unboxed]]#0, %[[c10_cast]] + ! CHECK: %[[c:.*]] = fir.emboxchar %[[cast_alloca]], %[[c10_cast]] func(argc, argj) = len_trim(argc, 4) + argj ! CHECK: addi %{{.*}}, %{{.*}} : i @@ -111,10 +117,15 @@ character(10) :: argc character(*) :: c ! CHECK-DAG: %[[unboxed:.*]]:2 = fir.unboxchar %[[arg0]] : - ! CHECK-DAG: %[[c10:.*]] = arith.constant 10 : - ! CHECK: %[[c10_cast:.*]] = fir.convert %[[c10]] : (i32) -> index - ! CHECK: %[[argc:.*]] = fir.emboxchar %[[unboxed]]#0, %[[c10_cast]] - ! CHECK: fir.call @_QPifoo(%[[argc]]) : (!fir.boxchar<1>) -> i32 + ! CHECK-DAG: %[[c10:.*]] = arith.constant 10 + ! CHECK: %[[alloca:.*]] = fir.alloca !fir.char<1,10> {bindc_name = ".chrtmp"} + ! CHECK: %[[cast_alloca:.*]] = fir.convert %[[alloca]] : (!fir.ref>) -> !fir.ref + ! CHECK: %[[cast_unboxed:.*]] = fir.convert %[[unboxed]]#0 : (!fir.ref>) -> !fir.ref + ! CHECK: fir.call @llvm.memmove.p0.p0.i64(%[[cast_alloca]], %[[cast_unboxed]], %{{.*}}, %{{.*}}) : (!fir.ref, !fir.ref, i64, i1) -> () + ! CHECK: %[[cast_alloca:.*]] = fir.convert %[[alloca]] : (!fir.ref>) -> !fir.ref> + ! CHECK: %[[c10_cast:.*]] = fir.convert %[[c10]] : (i32) -> index + ! CHECK: %[[argc:.*]] = fir.emboxchar %[[cast_alloca]], %[[c10_cast]] + ! CHECK: fir.call @_QPifoo(%[[argc]]) : (!fir.boxchar<1>) -> i32 func(argc) = ifoo(argc) test_stmt_character = func(c) end function @@ -130,8 +141,11 @@ ! CHECK: %[[n:.*]] = fir.load %[[arg1]] : !fir.ref ! CHECK: %[[n_is_positive:.*]] = arith.cmpi sgt, %[[n]], %c0{{.*}} : i32 ! CHECK: %[[len:.*]] = arith.select %[[n_is_positive]], %[[n]], %c0{{.*}} : i32 + ! CHECK: %[[alloca:.*]] = fir.alloca !fir.char<1,?>(%[[len]] : i32) {bindc_name = ".chrtmp"} + ! CHECK: %[[cast_alloca:.*]] = fir.convert %[[alloca]] : (!fir.ref>) -> !fir.ref + ! CHECK: %[[ucast_unboxed:.*]] = fir.convert %[[unboxed]]#0 : (!fir.ref>) -> !fir.ref ! CHECK: %[[lenCast:.*]] = fir.convert %[[len]] : (i32) -> index - ! CHECK: %[[argc:.*]] = fir.emboxchar %[[unboxed]]#0, %[[lenCast]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: %[[argc:.*]] = fir.emboxchar %[[alloca]], %[[lenCast]] : (!fir.ref>, index) -> !fir.boxchar<1> ! CHECK: fir.call @_QPifoo(%[[argc]]) : (!fir.boxchar<1>) -> i32 func(argc) = ifoo(argc) test_stmt_character = func(c) @@ -145,3 +159,30 @@ PRINT *, I(2.5) ! CHECK: fir.call {{.*}}EndIo END subroutine bug247 + +! Test that the argument is truncated to the length of the dummy argument. +subroutine truncate_arg + character(4) arg + character(10) stmt_fct + stmt_fct(arg) = arg + print *, stmt_fct('longer_arg') +end subroutine + +! CHECK-LABEL: @_QPtruncate_arg +! CHECK: %[[c4:.*]] = arith.constant 4 : i32 +! CHECK: %[[arg:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref> +! CHECK: %[[cast_arg:.*]] = fir.convert %[[arg]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[temp:.*]] = fir.alloca !fir.char<1,4> {bindc_name = ".chrtmp"} +! CHECK: %[[c1:.*]] = arith.constant 1 : i64 +! CHECK: %[[c4_i32:.*]] = fir.convert %[[c4]] : (i32) -> i64 +! CHECK: %[[length:.*]] = arith.muli %[[c1]], %[[c4_i32]] : i64 +! CHECK: %[[cast_temp_i8:.*]] = fir.convert %[[temp]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[cast_arg_i8:.*]] = fir.convert %[[cast_arg]] : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0.p0.i64(%[[cast_temp_i8]], %[[cast_arg_i8]], %[[length]], %{{.*}}) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: %[[result:.*]] = fir.alloca !fir.char<1,10> +! CHECK: %[[c10:.*]] = arith.constant 10 : index +! CHECK: fir.do_loop %arg0 = %14 to %19 step %{{.*}} { +! CHECK: %{{.*}} = fir.convert %[[result]] : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[cast_result_i8:.*]] = fir.convert %[[result]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[c10_i64:.*]] = fir.convert %[[c10]] : (index) -> i64 +! CHECK: %{{.*}} = fir.call @_FortranAioOutputAscii(%{{.*}}, %[[cast_result_i8]], %[[c10_i64]]) : (!fir.ref, !fir.ref, i64) -> i1