Index: flang/include/flang/Optimizer/Builder/FIRBuilder.h =================================================================== --- flang/include/flang/Optimizer/Builder/FIRBuilder.h +++ flang/include/flang/Optimizer/Builder/FIRBuilder.h @@ -520,6 +520,11 @@ const fir::ExtendedValue &lhs, const fir::ExtendedValue &rhs); +/// Assign \p parent to \p rec. Both of them must be scalar derived types. +void genParentCompAssigment(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &rec, + const fir::ExtendedValue &parent); + /// Builds and returns the type of a ragged array header used to cache mask /// evaluations. RaggedArrayHeader is defined in /// flang/include/flang/Runtime/ragged.h. Index: flang/lib/Lower/ConvertExpr.cpp =================================================================== --- flang/lib/Lower/ConvertExpr.cpp +++ flang/lib/Lower/ConvertExpr.cpp @@ -1063,10 +1063,12 @@ for (const auto &value : ctor.values()) { const Fortran::semantics::Symbol &sym = *value.first; const Fortran::lower::SomeExpr &expr = value.second.value(); - // Parent components need more work because they do not appear in the - // fir.rec type. - if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp)) - TODO(loc, "parent component in structure constructor"); + + if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp)) { + ExtValue from = gen(expr); + fir::factory::genParentCompAssigment(builder, loc, res, from); + continue; + } if (isDerivedTypeWithLenParameters(sym)) TODO(loc, "component with length parameters in structure constructor"); @@ -1077,8 +1079,7 @@ loc, fieldTy, name, ty, /*typeParams=*/mlir::ValueRange{} /*TODO*/); mlir::Type coorTy = builder.getRefType(recTy.getType(name)); - auto coor = builder.create(loc, coorTy, - fir::getBase(res), field); + auto coor = builder.create(loc, coorTy, res, field); ExtValue to = fir::factory::componentToExtendedValue(builder, loc, coor); to.match( [&](const fir::UnboxedValue &toPtr) { Index: flang/lib/Optimizer/Builder/FIRBuilder.cpp =================================================================== --- flang/lib/Optimizer/Builder/FIRBuilder.cpp +++ flang/lib/Optimizer/Builder/FIRBuilder.cpp @@ -1050,10 +1050,11 @@ auto rhsType = rbaseType.dyn_cast(); assert(rhsType && "rhs must be a scalar record type"); auto fieldIndexType = fir::FieldType::get(lhsType.getContext()); - for (auto [lhsPair, rhsPair] : - llvm::zip(lhsType.getTypeList(), rhsType.getTypeList())) { - auto &[lFieldName, lFieldTy] = lhsPair; - auto &[rFieldName, rFieldTy] = rhsPair; + for (std::size_t i = 0; i < rhsType.getTypeList().size(); ++i) { + auto rFieldName = rhsType.getTypeList()[i].first; + auto rFieldTy = rhsType.getTypeList()[i].second; + auto lFieldName = lhsType.getTypeList()[i].first; + auto lFieldTy = lhsType.getTypeList()[i].second; assert(!fir::hasDynamicSize(lFieldTy) && !fir::hasDynamicSize(rFieldTy)); mlir::Value rField = builder.create( loc, fieldIndexType, rFieldName, rhsType, fir::getTypeParams(rhs)); @@ -1169,6 +1170,28 @@ genComponentByComponentAssignment(builder, loc, lhs, rhs); } +void fir::factory::genParentCompAssigment(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::ExtendedValue &rec, + const fir::ExtendedValue &parent) { + fir::ExtendedValue parentVal = parent; + if (fir::getTypeParams(parent).size() > 0) + TODO(loc, "parent component with type parameters in structure constructor"); + // Assign to one temporary storage if the component data source is mutable. + if (fir::getBase(parent).getType().isa()) { + mlir::Type baseTy = + fir::unwrapPassByRefType(fir::getBase(parent).getType()); + parentVal = builder.createTemporary(loc, baseTy); + auto to = fir::getBase(builder.createBox(loc, parentVal)); + auto toMutableBox = builder.createTemporary(loc, to.getType()); + builder.create(loc, to, toMutableBox); + auto parentBox = fir::getBase(builder.createBox(loc, parent)); + fir::runtime::genAssign(builder, loc, toMutableBox, parentBox); + } + // Assign the parent component one-by-one to target record. + genComponentByComponentAssignment(builder, loc, rec, parentVal); +} + mlir::TupleType fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) { mlir::IntegerType i64Ty = builder.getIntegerType(64); Index: flang/test/Lower/structure-constructors.f90 =================================================================== --- flang/test/Lower/structure-constructors.f90 +++ flang/test/Lower/structure-constructors.f90 @@ -234,3 +234,154 @@ call test_ptr(42., i) call test_nested(42., t_array(x=43., i=[5,6,7,8,9])) end + +! CHECK-LABEL: func.func @_QPtest_parent_component1() { +! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.type<_QFtest_parent_component1Tbase{x:i32,y:!fir.array<2xi32>}> +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.type<_QFtest_parent_component1Tmid{x:i32,y:!fir.array<2xi32>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_14:.*]] = fir.field_index x, !fir.type<_QFtest_parent_component1Tbase{x:i32,y:!fir.array<2xi32>}> +! CHECK: %[[VAL_15:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_14]] : (!fir.ref}>>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_16:.*]] = arith.constant 1 : i32 +! CHECK: fir.store %[[VAL_16]] to %[[VAL_15]] : !fir.ref +! CHECK: %[[VAL_17:.*]] = fir.field_index y, !fir.type<_QFtest_parent_component1Tbase{x:i32,y:!fir.array<2xi32>}> +! CHECK: %[[VAL_18:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_17]] : (!fir.ref}>>, !fir.field) -> !fir.ref> +! CHECK: %[[VAL_19:.*]] = arith.constant 2 : index +! CHECK: %[[VAL_20:.*]] = fir.shape %[[VAL_19]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_21:.*]] = fir.array_load %[[VAL_18]](%[[VAL_20]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<2xi32> +! CHECK: %[[VAL_22:.*]] = fir.address_of(@_QQro.2xi4.a785b5f6447097efe271cc07e822fff0) : !fir.ref> +! CHECK: %[[VAL_23:.*]] = arith.constant 2 : index +! CHECK: %[[VAL_24:.*]] = fir.shape %[[VAL_23]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_25:.*]] = fir.array_load %[[VAL_22]](%[[VAL_24]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<2xi32> +! CHECK: %[[VAL_26:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_27:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_28:.*]] = arith.subi %[[VAL_19]], %[[VAL_26]] : index +! CHECK: %[[VAL_29:.*]] = fir.do_loop %[[VAL_30:.*]] = %[[VAL_27]] to %[[VAL_28]] step %[[VAL_26]] unordered iter_args(%[[VAL_31:.*]] = %[[VAL_21]]) -> (!fir.array<2xi32>) { +! CHECK: %[[VAL_32:.*]] = fir.array_fetch %[[VAL_25]], %[[VAL_30]] : (!fir.array<2xi32>, index) -> i32 +! CHECK: %[[VAL_33:.*]] = fir.array_update %[[VAL_31]], %[[VAL_32]], %[[VAL_30]] : (!fir.array<2xi32>, i32, index) -> !fir.array<2xi32> +! CHECK: fir.result %[[VAL_33]] : !fir.array<2xi32> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_21]], %[[VAL_34:.*]] to %[[VAL_18]] : !fir.array<2xi32>, !fir.array<2xi32>, !fir.ref> +! CHECK: %[[VAL_35:.*]] = fir.field_index x, !fir.type<_QFtest_parent_component1Tbase{x:i32,y:!fir.array<2xi32>}> +! CHECK: %[[VAL_36:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_35]] : (!fir.ref}>>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_37:.*]] = fir.field_index x, !fir.type<_QFtest_parent_component1Tmid{x:i32,y:!fir.array<2xi32>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_38:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_37]] : (!fir.ref,mask:!fir.logical<4>}>>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_39:.*]] = fir.load %[[VAL_36]] : !fir.ref +! CHECK: fir.store %[[VAL_39]] to %[[VAL_38]] : !fir.ref +! CHECK: %[[VAL_40:.*]] = fir.field_index y, !fir.type<_QFtest_parent_component1Tbase{x:i32,y:!fir.array<2xi32>}> +! CHECK: %[[VAL_41:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_40]] : (!fir.ref}>>, !fir.field) -> !fir.ref> +! CHECK: %[[VAL_42:.*]] = fir.field_index y, !fir.type<_QFtest_parent_component1Tmid{x:i32,y:!fir.array<2xi32>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_43:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_42]] : (!fir.ref,mask:!fir.logical<4>}>>, !fir.field) -> !fir.ref> +! CHECK: %[[VAL_44:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_45:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_46:.*]] = arith.constant 1 : index +! CHECK: fir.do_loop %[[VAL_47:.*]] = %[[VAL_44]] to %[[VAL_46]] step %[[VAL_45]] { +! CHECK: %[[VAL_48:.*]] = fir.coordinate_of %[[VAL_43]], %[[VAL_47]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_49:.*]] = fir.coordinate_of %[[VAL_41]], %[[VAL_47]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_50:.*]] = fir.load %[[VAL_49]] : !fir.ref +! CHECK: fir.store %[[VAL_50]] to %[[VAL_48]] : !fir.ref +! CHECK: } +! CHECK: %[[VAL_51:.*]] = fir.field_index mask, !fir.type<_QFtest_parent_component1Tmid{x:i32,y:!fir.array<2xi32>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_52:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_51]] : (!fir.ref,mask:!fir.logical<4>}>>, !fir.field) -> !fir.ref> +! CHECK: %[[VAL_53:.*]] = arith.constant true +! CHECK: %[[VAL_54:.*]] = fir.convert %[[VAL_53]] : (i1) -> !fir.logical<4> +! CHECK: fir.store %[[VAL_54]] to %[[VAL_52]] : !fir.ref> +! CHECK: fir.call @_QPprint_parent_component1(%[[VAL_1]]) : (!fir.ref,mask:!fir.logical<4>}>>) -> () +! CHECK: return +! CHECK: } + +subroutine test_parent_component1() + type base + integer :: x, y(2) + end type base + type, extends(base) :: mid + logical :: mask + end type mid + + call print_parent_component1(mid(base = base(1, [2, 3]), mask = .true.)) +end + +! CHECK-LABEL: func.func @_QPtest_parent_component2() { +! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.type<_QFtest_parent_component2Tmid{z:!fir.char<1,5>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QFtest_parent_component2Epv) : !fir.ref}>> +! CHECK: %[[VAL_8:.*]] = fir.field_index z, !fir.type<_QFtest_parent_component2Tbase{z:!fir.char<1,5>}> +! CHECK: %[[VAL_9:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_8]] : (!fir.ref}>>, !fir.field) -> !fir.ref> +! CHECK: %[[VAL_10:.*]] = fir.field_index z, !fir.type<_QFtest_parent_component2Tmid{z:!fir.char<1,5>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_11:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_10]] : (!fir.ref,mask:!fir.logical<4>}>>, !fir.field) -> !fir.ref> +! CHECK: %[[VAL_12:.*]] = arith.constant 5 : index +! CHECK: %[[VAL_13:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_12]] : (index) -> i64 +! CHECK: %[[VAL_15:.*]] = arith.muli %[[VAL_13]], %[[VAL_14]] : i64 +! CHECK: %[[VAL_16:.*]] = arith.constant false +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_11]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_9]] : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0.p0.i64(%[[VAL_17]], %[[VAL_18]], %[[VAL_15]], %[[VAL_16]]) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: %[[VAL_19:.*]] = fir.field_index mask, !fir.type<_QFtest_parent_component2Tmid{z:!fir.char<1,5>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_20:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_19]] : (!fir.ref,mask:!fir.logical<4>}>>, !fir.field) -> !fir.ref> +! CHECK: %[[VAL_21:.*]] = arith.constant true +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (i1) -> !fir.logical<4> +! CHECK: fir.store %[[VAL_22]] to %[[VAL_20]] : !fir.ref> +! CHECK: fir.call @_QPprint_parent_component2(%[[VAL_0]]) : (!fir.ref,mask:!fir.logical<4>}>>) -> () +! CHECK: return +! CHECK: } + +subroutine test_parent_component2() + type base + character(5) :: z + end type base + type, extends(base) :: mid + logical :: mask + end type mid + type(base) :: pv = base("aaa") + + call print_parent_component2(mid(base = pv, mask = .true.)) +end + +! CHECK-LABEL: func.func @_QPtest_parent_component3( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>}>>>> {fir.bindc_name = "pp"}) { +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box>}>> +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.type<_QFtest_parent_component3Tbase{m:!fir.array<2x!fir.char<1,5>>}> +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.type<_QFtest_parent_component3Tmid{m:!fir.array<2x!fir.char<1,5>>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_0]] : !fir.ref>}>>>> +! CHECK: %[[VAL_11:.*]] = fir.embox %[[VAL_2]] : (!fir.ref>}>>) -> !fir.box>}>> +! CHECK: fir.store %[[VAL_11]] to %[[VAL_1]] : !fir.ref>}>>> +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>}>>>) -> !fir.ref> +! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_10]] : (!fir.box>}>>>) -> !fir.box +! CHECK: %[[VAL_17:.*]] = fir.call @_FortranAAssign(%[[VAL_14]], %[[VAL_15]], %{{.*}}, %{{.*}}) : (!fir.ref>, !fir.box, !fir.ref, i32) -> none +! CHECK: %[[VAL_18:.*]] = fir.field_index m, !fir.type<_QFtest_parent_component3Tbase{m:!fir.array<2x!fir.char<1,5>>}> +! CHECK: %[[VAL_19:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_18]] : (!fir.ref>}>>, !fir.field) -> !fir.ref>> +! CHECK: %[[VAL_20:.*]] = fir.field_index m, !fir.type<_QFtest_parent_component3Tmid{m:!fir.array<2x!fir.char<1,5>>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_21:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_20]] : (!fir.ref>,mask:!fir.logical<4>}>>, !fir.field) -> !fir.ref>> +! CHECK: %[[VAL_22:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_23:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_24:.*]] = arith.constant 1 : index +! CHECK: fir.do_loop %[[VAL_25:.*]] = %[[VAL_22]] to %[[VAL_24]] step %[[VAL_23]] { +! CHECK: %[[VAL_26:.*]] = fir.coordinate_of %[[VAL_21]], %[[VAL_25]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: %[[VAL_27:.*]] = fir.coordinate_of %[[VAL_19]], %[[VAL_25]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: %[[VAL_28:.*]] = arith.constant 5 : index +! CHECK: %[[VAL_29:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_30:.*]] = fir.convert %[[VAL_28]] : (index) -> i64 +! CHECK: %[[VAL_31:.*]] = arith.muli %[[VAL_29]], %[[VAL_30]] : i64 +! CHECK: %[[VAL_32:.*]] = arith.constant false +! CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_26]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_27]] : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0.p0.i64(%[[VAL_33]], %[[VAL_34]], %[[VAL_31]], %[[VAL_32]]) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: } +! CHECK: %[[VAL_35:.*]] = fir.field_index mask, !fir.type<_QFtest_parent_component3Tmid{m:!fir.array<2x!fir.char<1,5>>,mask:!fir.logical<4>}> +! CHECK: %[[VAL_36:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_35]] : (!fir.ref>,mask:!fir.logical<4>}>>, !fir.field) -> !fir.ref> +! CHECK: %[[VAL_37:.*]] = arith.constant true +! CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_37]] : (i1) -> !fir.logical<4> +! CHECK: fir.store %[[VAL_38]] to %[[VAL_36]] : !fir.ref> +! CHECK: fir.call @_QPprint_parent_component3(%[[VAL_3]]) : (!fir.ref>,mask:!fir.logical<4>}>>) -> () +! CHECK: return +! CHECK: } + +subroutine test_parent_component3(pp) + type base + character(5) :: m(2) + end type base + type, extends(base) :: mid + logical :: mask + end type mid + type(base), pointer :: pp + + call print_parent_component3(mid(base = pp, mask = .true.)) +end