diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -2710,22 +2710,6 @@ [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { if (Fortran::evaluate::IsProcedure(assign.rhs)) TODO(loc, "procedure pointer assignment"); - std::optional lhsType = - assign.lhs.GetType(); - std::optional rhsType = - assign.rhs.GetType(); - // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. - // If the pointer object is not polymorphic (7.3.2.3) and the - // pointer target is polymorphic with dynamic type that differs - // from its declared type, the assignment target is the ancestor - // component of the pointer target that has the type of the - // pointer object. Otherwise, the assignment target is the pointer - // target. - if ((lhsType && !lhsType->IsPolymorphic()) && - (rhsType && rhsType->IsPolymorphic())) - TODO(loc, "non-polymorphic pointer assignment with polymorphic " - "entity on rhs"); - llvm::SmallVector lbounds; for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs) lbounds.push_back( diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90 --- a/flang/test/Lower/polymorphic.f90 +++ b/flang/test/Lower/polymorphic.f90 @@ -219,4 +219,38 @@ ! CHECK: %[[EMBOX:.*]] = fir.embox %[[TEMP]] tdesc %[[TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class> ! CHECK: fir.call @_QMpolymorphic_testPtakes_p1(%[[EMBOX]]) {{.*}} : (!fir.class>) -> () +! Test pointer assignment with non polymorphic lhs and polymorphic rhs + + subroutine pointer_assign_parent(p) + type(p2), target :: p + type(p1), pointer :: tp + tp => p%p1 + end subroutine + +! First test is here to have a reference with non polymorphic on both sides. +! CHECK-LABEL: func.func @_QMpolymorphic_testPpointer_assign_parent( +! CHECK-SAME: %[[ARG0:.*]]: !fir.ref> {fir.bindc_name = "p", fir.target}) { +! CHECK: %[[TP:.*]] = fir.alloca !fir.box>> {bindc_name = "tp", uniq_name = "_QMpolymorphic_testFpointer_assign_parentEtp"} +! CHECK: %[[PTR:.*]] = fir.alloca !fir.ptr> {uniq_name = "_QMpolymorphic_testFpointer_assign_parentEtp.addr"} +! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.ptr> +! CHECK: fir.store %[[ZERO]] to %[[PTR]] : !fir.ref>> +! CHECK: %[[CONVERT:.*]] = fir.convert %[[ARG0]] : (!fir.ref>) -> !fir.ptr> +! CHECK: fir.store %[[CONVERT]] to %[[PTR]] : !fir.ref>> + + subroutine pointer_assign_non_poly(p) + class(p1), target :: p + type(p1), pointer :: tp + tp => p + end subroutine + +! CHECK-LABEL: func.func @_QMpolymorphic_testPpointer_assign_non_poly( +! CHECK-SAME: %arg0: !fir.class> {fir.bindc_name = "p", fir.target}) { +! CHECK: %[[TP:.*]] = fir.alloca !fir.box>> {bindc_name = "tp", uniq_name = "_QMpolymorphic_testFpointer_assign_non_polyEtp"} +! CHECK: %[[PTR:.*]] = fir.alloca !fir.ptr> {uniq_name = "_QMpolymorphic_testFpointer_assign_non_polyEtp.addr"} +! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.ptr> +! CHECK: fir.store %[[ZERO]] to %[[PTR]] : !fir.ref>> +! CHECK: %[[BOX_ADDR:.*]] = fir.box_addr %[[ARG0]] : (!fir.class>) -> !fir.ref> +! CHECK: %[[CONVERT:.*]] = fir.convert %3 : (!fir.ref>) -> !fir.ptr> +! CHECK: fir.store %[[CONVERT]] to %[[PTR]] : !fir.ref>> + end module