diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h index f2c231647390b..d8241c08e3b25 100644 --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -268,7 +268,17 @@ template class FunctionRef : public ProcedureRef { FunctionRef(ProcedureDesignator &&p, ActualArguments &&a) : ProcedureRef{std::move(p), std::move(a)} {} - std::optional GetType() const { return proc_.GetType(); } + std::optional GetType() const { + if (auto type{proc_.GetType()}) { + // TODO: Non constant explicit length parameters of PDTs result should + // likely be dropped too. This is not as easy as for characters since some + // long lived DerivedTypeSpec pointer would need to be created here. It is + // not clear if this is causing any issue so far since the storage size of + // PDTs is independent of length parameters. + return type->DropNonConstantCharacterLength(); + } + return std::nullopt; + } }; } // namespace Fortran::evaluate #endif // FORTRAN_EVALUATE_CALL_H_ diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h index eb4050970c138..13060e42e47ad 100644 --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -231,6 +231,12 @@ class DynamicType { } } + // Get a copy of this dynamic type where charLengthParamValue_ is reset if it + // is not a constant expression. This avoids propagating symbol references in + // scopes where they do not belong. Returns the type unmodified if it is not + // a character or if the length is not explicit. + DynamicType DropNonConstantCharacterLength() const; + private: // Special kind codes are used to distinguish the following Fortran types. enum SpecialKind { diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp index 1497c037d9cc6..e5d9851e2496a 100644 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -836,4 +836,15 @@ bool IsCUDAIntrinsicType(const DynamicType &type) { } } +DynamicType DynamicType::DropNonConstantCharacterLength() const { + if (charLengthParamValue_ && charLengthParamValue_->isExplicit()) { + if (std::optional len{knownLength()}) { + return DynamicType(kind_, *len); + } else { + return DynamicType(category_, kind_); + } + } + return *this; +} + } // namespace Fortran::evaluate diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 1ae8f08dc116e..0a023bc6b21ea 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -5284,11 +5284,8 @@ IntrinsicLibrary::genStorageSize(mlir::Type resultType, builder.getKindMap().getIntegerBitsize(fir::toInt(constOp))); } - if (args[0].getBoxOf()) { - box = builder.createBox(loc, args[0], /*isPolymorphic=*/true); - } else if (box.getType().isa()) { - box = builder.create(loc, box); - } + box = builder.createBox(loc, args[0], + /*isPolymorphic=*/args[0].isPolymorphic()); mlir::Value eleSize = builder.create(loc, kindTy, box); mlir::Value c8 = builder.createIntegerConstant(loc, kindTy, 8); return builder.create(loc, eleSize, c8); diff --git a/flang/test/Evaluate/rewrite06.f90 b/flang/test/Evaluate/rewrite06.f90 new file mode 100644 index 0000000000000..03eb463fe9bd5 --- /dev/null +++ b/flang/test/Evaluate/rewrite06.f90 @@ -0,0 +1,33 @@ +! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s +subroutine test_storage_size(n) + interface + function return_char(l) + integer :: l + character(l) :: return_char + end function + end interface + integer n + !CHECK: PRINT *, storage_size(return_char(n)) + print*, storage_size(return_char(n)) + !CHECK: PRINT *, sizeof(return_char(n)) + print*, sizeof(return_char(n)) +end subroutine + +module pdts + type t(l) + integer, len :: l + character(l) :: c + end type +contains + function return_pdt(n) + type(t(n)) :: return_pdt + end function + subroutine test(k) + ! NOTE: flang design for length parametrized derived type + ! is to use allocatables for the automatic components. Hence, + ! their size is independent from the length parameters and is + ! a compile time constant. + !CHECK: PRINT *, 192_4 + print *, storage_size(return_pdt(k)) + end subroutine +end module diff --git a/flang/test/Lower/Intrinsics/storage_size-2.f90 b/flang/test/Lower/Intrinsics/storage_size-2.f90 new file mode 100644 index 0000000000000..e784063c76c35 --- /dev/null +++ b/flang/test/Lower/Intrinsics/storage_size-2.f90 @@ -0,0 +1,30 @@ +! Test storage_size with characters +! RUN: bbc -emit-hlfir %s -o - | FileCheck %s + +! check-label: func.func @_QPtest_storage_size +subroutine test_storage_size(n) + interface + function return_char(l) + integer :: l + character(l) :: return_char + end function + end interface + integer n + print*, storage_size(return_char(n)) +! CHECK: %[[val_16:.*]] = fir.call @_QPreturn_char(%[[res_addr:[^,]*]], %[[res_len:[^,]*]], {{.*}}) +! CHECK: %[[res:.*]]:2 = hlfir.declare %[[res_addr]] typeparams %[[res_len]] +! CHECK: %[[val_18:.*]] = fir.embox %[[res]]#1 typeparams %[[res_len]] : (!fir.ref>, index) -> !fir.box> +! CHECK: %[[val_19:.*]] = fir.box_elesize %[[val_18]] : (!fir.box>) -> i32 +! CHECK: %[[val_20:.*]] = arith.constant 8 : i32 +! CHECK: %[[val_21:.*]] = arith.muli %[[val_19]], %[[val_20]] : i32 +! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[val_21]]) +end subroutine + +function return_char(l) + integer :: l + character(l) :: return_char +end function + + call test_storage_size(42) + print *, 42*8 +end diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90 index 269a0a3034a9f..66d0a375fa56d 100644 --- a/flang/test/Semantics/call05.f90 +++ b/flang/test/Semantics/call05.f90 @@ -155,6 +155,15 @@ subroutine smb(b) integer, allocatable, intent(in) :: b(:) end + function return_deferred_length_ptr() + character(len=:), pointer :: return_deferred_length_ptr + end function + + function return_explicit_length_ptr(n) + integer :: n + character(len=n), pointer :: return_explicit_length_ptr + end function + subroutine test() !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE @@ -167,6 +176,16 @@ subroutine test() call smp2(p1) ! ok + call smp(return_deferred_length_ptr()) ! ok + + !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE + call smp2(return_deferred_length_ptr()) + + !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE + call smp(return_explicit_length_ptr(10)) + + call smp2(return_explicit_length_ptr(10)) ! ok + !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument call sma(t2(:))