diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index 8931cbe485ac2..b35fff70cabaf 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -1493,32 +1493,21 @@ class CopyInOutExplicitInterface { return !actualTreatAsContiguous && dummyNeedsContiguity; } - // Returns true, if actual and dummy have polymorphic differences bool HavePolymorphicDifferences() const { - bool dummyIsAssumedRank{dummyObj_.type.attrs().test( - characteristics::TypeAndShape::Attr::AssumedRank)}; - bool actualIsAssumedRank{semantics::IsAssumedRank(actual_)}; - bool dummyIsAssumedShape{dummyObj_.type.attrs().test( - characteristics::TypeAndShape::Attr::AssumedShape)}; - bool actualIsAssumedShape{semantics::IsAssumedShape(actual_)}; - if ((actualIsAssumedRank && dummyIsAssumedRank) || - (actualIsAssumedShape && dummyIsAssumedShape)) { - // Assumed-rank and assumed-shape arrays are represented by descriptors, - // so don't need to do polymorphic check. - } else if (!dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) { - // flang supports limited cases of passing polymorphic to non-polimorphic. - // These cases require temporary of non-polymorphic type. (For example, - // the actual argument could be polymorphic array of child type, - // while the dummy argument could be non-polymorphic array of parent - // type.) - bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()}; - auto actualType{ - characteristics::TypeAndShape::Characterize(actual_, fc_)}; - bool actualIsPolymorphic{ - actualType && actualType->type().IsPolymorphic()}; - if (actualIsPolymorphic && !dummyIsPolymorphic) { - return true; - } + // These cases require temporary of non-polymorphic type. (For example, + // the actual argument could be polymorphic array of child type, + // while the dummy argument could be non-polymorphic array of parent + // type.) + if (dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) { + return false; + } + auto actualType{characteristics::TypeAndShape::Characterize(actual_, fc_)}; + if (actualType && actualType->type().IsPolymorphic() && + !actualType->type().IsAssumedType() && + !dummyObj_.IsPassedByDescriptor(/*isBindC*/ false)) { + // Not passing a descriptor, so will need to make a copy of the data + // with a proper type. + return true; } return false; } diff --git a/flang/test/Lower/force-temp.f90 b/flang/test/Lower/force-temp.f90 index d9ba543d46313..e02463f700b45 100644 --- a/flang/test/Lower/force-temp.f90 +++ b/flang/test/Lower/force-temp.f90 @@ -27,6 +27,14 @@ subroutine pass_intent_out(buf) integer, intent(out) :: buf(5) end subroutine end interface + + ! Used by call_s6() and others below + type base + integer :: i = -1 + end type + type, extends (base) :: child + real :: r = -2.0 + end type contains subroutine s1(buf) !CHECK-LABEL: func.func @_QMtestPs1 @@ -79,4 +87,39 @@ subroutine s5() p => x(::2) ! pointer to non-contiguous array section call pass_intent_out(p) end subroutine + subroutine call_s6() + interface + subroutine s6(b) + import :: base + type(base), intent(inout) :: b(:) + end subroutine s6 + end interface + class(base), pointer :: pb(:) + type(child), target :: c(2) +!CHECK-LABEL: func.func @_QMtestPcall_s6 +!CHECK-NOT: hlfir.copy_in +!CHECK: fir.call @_QPs6 +!CHECK-NOT: hlfir.copy_out + pb => c + call s6(pb) + end subroutine call_s6 + subroutine call_s7() + interface + subroutine s7(b1, b2, n) + import :: base + integer :: n + type(base), intent(inout) :: b1(n) + type(base), intent(inout) :: b2(*) + end subroutine + end interface + integer, parameter :: n = 7 + class(base), allocatable :: c1(:), c2(:) +!CHECK-LABEL: func.func @_QMtestPcall_s7 +!CHECK: hlfir.copy_in +!CHECK: hlfir.copy_in +!CHECK: fir.call @_QPs7 +!CHECK: hlfir.copy_out +!CHECK: hlfir.copy_out + call s7(c1, c2, n) + end subroutine call_s7 end module