From 9379ca0a257780961a7e77c1a56c70d00cd85909 Mon Sep 17 00:00:00 2001 From: Valentin Clement Date: Thu, 15 Dec 2022 12:02:11 +0100 Subject: [PATCH] [flang] Fix associating entity when selector is an array, pointer or allocatable In SELECT TYPE, within the block following TYPE IS, the associating entity is not polymorphic. It has the type named in the type guard and other properties taken from the selector. Within the block following a CLASS IS type guard statement, the associating entity is polymorphic and has the declared type named in the type guard statement. This patch makes sure the associating entity matches the selector if it is an array, a pointer or an allocatable. Reviewed By: jeanPerier Differential Revision: https://reviews.llvm.org/D140017 --- flang/include/flang/Optimizer/Dialect/FIROps.td | 2 +- flang/lib/Lower/Bridge.cpp | 55 +++- flang/lib/Optimizer/Dialect/FIROps.cpp | 3 +- flang/test/Lower/select-type.f90 | 357 +++++++++++++++++++++++- 4 files changed, 404 insertions(+), 13 deletions(-) diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td index 1e29710..088294c 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROps.td +++ b/flang/include/flang/Optimizer/Dialect/FIROps.td @@ -1048,7 +1048,7 @@ def fir_BoxEleSizeOp : fir_SimpleOneResultOp<"box_elesize", [NoMemoryEffect]> { must box an array of REAL values (with dynamic rank and extent). }]; - let arguments = (ins fir_BoxType:$val); + let arguments = (ins BoxOrClassType:$val); let results = (outs AnyIntegerLike); } diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index d2f6353..c58acf8 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -2299,6 +2299,12 @@ private: } }; + mlir::Type baseTy = fir::getBase(selector).getType(); + bool isPointer = fir::isPointerType(baseTy); + bool isAllocatable = fir::isAllocatableType(baseTy); + bool isArray = + fir::dyn_cast_ptrOrBoxEleTy(baseTy).isa(); + const fir::BoxValue *selectorBox = selector.getBoxOf(); if (std::holds_alternative(guard.u)) { // CLASS DEFAULT addAssocEntitySymbol(selector); @@ -2308,15 +2314,31 @@ private: fir::ExactTypeAttr attr = typeGuardAttr.dyn_cast(); mlir::Value exactValue; + mlir::Type addrTy = attr.getType(); + if (isArray) { + auto seqTy = fir::dyn_cast_ptrOrBoxEleTy(baseTy) + .dyn_cast(); + addrTy = fir::SequenceType::get(seqTy.getShape(), attr.getType()); + } + if (isPointer) + addrTy = fir::PointerType::get(addrTy); + if (isAllocatable) + addrTy = fir::HeapType::get(addrTy); if (std::holds_alternative( typeSpec->u)) { + mlir::Type refTy = fir::ReferenceType::get(addrTy); + if (isPointer || isAllocatable) + refTy = addrTy; exactValue = builder->create( - loc, fir::ReferenceType::get(attr.getType()), - fir::getBase(selector)); + loc, refTy, fir::getBase(selector)); const Fortran::semantics::IntrinsicTypeSpec *intrinsic = typeSpec->declTypeSpec->AsIntrinsic(); - if (intrinsic->category() == - Fortran::common::TypeCategory::Character) { + if (isArray) { + mlir::Value exact = builder->create( + loc, fir::BoxType::get(addrTy), fir::getBase(selector)); + addAssocEntitySymbol(selectorBox->clone(exact)); + } else if (intrinsic->category() == + Fortran::common::TypeCategory::Character) { auto charTy = attr.getType().dyn_cast(); mlir::Value charLen = fir::factory::CharacterExprHelper(*builder, loc) @@ -2328,16 +2350,31 @@ private: } else if (std::holds_alternative( typeSpec->u)) { exactValue = builder->create( - loc, fir::BoxType::get(attr.getType()), fir::getBase(selector)); - addAssocEntitySymbol(exactValue); + loc, fir::BoxType::get(addrTy), fir::getBase(selector)); + addAssocEntitySymbol(selectorBox->clone(exactValue)); } } else if (std::holds_alternative( guard.u)) { // CLASS IS fir::SubclassAttr attr = typeGuardAttr.dyn_cast(); - mlir::Value derived = builder->create( - loc, fir::ClassType::get(attr.getType()), fir::getBase(selector)); - addAssocEntitySymbol(derived); + mlir::Type addrTy = attr.getType(); + if (isArray) { + auto seqTy = fir::dyn_cast_ptrOrBoxEleTy(baseTy) + .dyn_cast(); + addrTy = fir::SequenceType::get(seqTy.getShape(), attr.getType()); + } + if (isPointer) + addrTy = fir::PointerType::get(addrTy); + if (isAllocatable) + addrTy = fir::HeapType::get(addrTy); + mlir::Type classTy = fir::ClassType::get(addrTy); + if (classTy == baseTy) { + addAssocEntitySymbol(selector); + } else { + mlir::Value derived = builder->create( + loc, classTy, fir::getBase(selector)); + addAssocEntitySymbol(selectorBox->clone(derived)); + } } builder->restoreInsertionPoint(crtInsPt); ++typeGuardIdx; diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp index 79313b9..b2b094a 100644 --- a/flang/lib/Optimizer/Dialect/FIROps.cpp +++ b/flang/lib/Optimizer/Dialect/FIROps.cpp @@ -937,7 +937,8 @@ mlir::LogicalResult fir::ConvertOp::verify() { (inType.isa() && outType.isa()) || (fir::isa_complex(inType) && fir::isa_complex(outType)) || (fir::isBoxedRecordType(inType) && fir::isPolymorphicType(outType)) || - (fir::isPolymorphicType(inType) && fir::isPolymorphicType(outType))) + (fir::isPolymorphicType(inType) && fir::isPolymorphicType(outType)) || + (fir::isPolymorphicType(inType) && outType.isa())) return mlir::success(); return emitOpError("invalid type conversion"); } diff --git a/flang/test/Lower/select-type.f90 b/flang/test/Lower/select-type.f90 index 744e7d9..957b656 100644 --- a/flang/test/Lower/select-type.f90 +++ b/flang/test/Lower/select-type.f90 @@ -427,16 +427,321 @@ contains ! CFG: ^[[EXIT_SELECT_BLK]]: ! CFG: return + subroutine select_type8(a) + class(*) :: a(:) + + select type(a) + type is (integer) + a = 100 + type is (real) + a = 2.0 + type is (character(*)) + a(1) = 'c' + a(2) = 'h' + type is (p1) + a%a = 1 + a%b = 2 + class is(p2) + a%a = 1 + a%b = 2 + a%c = 3 + class default + stop 'error' + end select + end subroutine + +! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type8( +! CHECK-SAME: %[[ARG0:.*]]: !fir.class> {fir.bindc_name = "a"}) { +! CHECK: %[[SELECTOR:.*]] = fir.rebox %[[ARG0]] : (!fir.class>) -> !fir.class> +! CHECK: fir.select_type %[[SELECTOR]] : !fir.class> [#fir.type_is, ^{{.*}}, #fir.type_is, ^{{.*}}, #fir.type_is>, ^bb{{.*}}, unit, ^{{.*}}] +! CHECK: ^bb{{.*}}: +! CHECK: %[[BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>) -> !fir.box> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[SELECTOR_DIMS:.*]]:3 = fir.box_dims %[[BOX]], %[[C0]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[BOX]] : (!fir.box>) -> !fir.array +! CHECK: %[[C100:.*]] = arith.constant 100 : i32 +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[UB:.*]] = arith.subi %[[SELECTOR_DIMS:.*]]#1, %[[C1]] : index +! CHECK: %[[LOOP_RES:.*]] = fir.do_loop %[[IND:.*]] = %[[C0:.*]] to %[[UB]] step %[[C1]] unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %[[C100]], %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[LOOP_RES]] to %[[BOX]] : !fir.array, !fir.array, !fir.box> +! CHECK: cf.br ^{{.*}} +! CHECK: ^bb{{.*}}: +! CHECK: %[[BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>) -> !fir.box> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[SELECTOR_DIMS:.*]]:3 = fir.box_dims %[[BOX]], %[[C0]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[BOX]] : (!fir.box>) -> !fir.array +! CHECK: %[[VALUE:.*]] = arith.constant 2.000000e+00 : f32 +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[UB:.*]] = arith.subi %[[SELECTOR_DIMS]]#1, %[[C1]] : index +! CHECK: %[[LOOP_RES:.*]] = fir.do_loop %[[IND:.*]] = %[[C0]] to %[[UB]] step %[[C1]] unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %[[VALUE]], %[[IND]] : (!fir.array, f32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[LOOP_RES]] to %[[BOX]] : !fir.array, !fir.array, !fir.box> +! CHECK: cf.br ^{{.*}} +! CHECK: ^bb{{.*}}: +! CHECK: %[[BOX:.*]] = fir.convert %0 : (!fir.class>) -> !fir.box>> +! CHECK: cf.br ^bb{{.*}} +! CHECK: ^bb{{.*}}: +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>) -> !fir.box>> +! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[EXACT_BOX]], %[[C0]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_A]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[EXACT_BOX]] [%[[SLICE]]] : (!fir.box>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[EXACT_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.box>>, !fir.slice<1> +! CHECK: %[[FIELD_B:.*]] = fir.field_index b, !fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[EXACT_BOX]], %[[C0]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_B]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[EXACT_BOX]] [%[[SLICE]]] : (!fir.box>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %c{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[EXACT_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.box>>, !fir.slice<1> +! CHECK: cf.br ^{{.*}} +! CHECK: ^bb{{.*}}: +! CHECK: %[[CLASS_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>) -> !fir.class>> +! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[CLASS_BOX]], %[[C0]] : (!fir.class>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_A]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[CLASS_BOX]] [%[[SLICE]]] : (!fir.class>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[CLASS_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.class>>, !fir.slice<1> +! CHECK: %[[FIELD_B:.*]] = fir.field_index b, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[CLASS_BOX]], %[[C0]] : (!fir.class>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_B]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[CLASS_BOX]] [%[[SLICE]]] : (!fir.class>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[CLASS_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.class>>, !fir.slice<1> +! CHECK: %[[FIELD_C:.*]] = fir.field_index c, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[CLASS_BOX]], %[[C0]] : (!fir.class>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_C]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[CLASS_BOX]] [%[[SLICE]]] : (!fir.class>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[CLASS_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.class>>, !fir.slice<1> +! CHECK: cf.br ^bb{{.*}} + + subroutine select_type9(a) + class(p1) :: a(:) + + select type(a) + type is (p1) + a%a = 1 + a%b = 2 + type is(p2) + a%a = 1 + a%b = 2 + a%c = 3 + class default + stop 'error' + end select + end subroutine + +! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type9( +! CHECK-SAME: %[[ARG0:.*]]: !fir.class>> {fir.bindc_name = "a"}) { +! CHECK: %[[SELECTOR:.*]] = fir.rebox %[[ARG0]] : (!fir.class>>) -> !fir.class>> +! CHECK: fir.select_type %[[SELECTOR]] : !fir.class>> [#fir.type_is>, ^bb{{.*}}, #fir.type_is>, ^bb{{.*}}, unit, ^bb{{.*}}] +! CHECK: ^bb{{.*}}: +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>>) -> !fir.box>> +! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[EXACT_BOX]], %[[C0]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_A]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[EXACT_BOX]] [%[[SLICE]]] : (!fir.box>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[EXACT_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.box>>, !fir.slice<1> +! CHECK: %[[FIELD_B:.*]] = fir.field_index b, !fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[EXACT_BOX]], %[[C0]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_B]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[EXACT_BOX]] [%[[SLICE]]] : (!fir.box>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %c{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[EXACT_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.box>>, !fir.slice<1> +! CHECK: cf.br ^bb{{.*}} +! CHECK: ^bb{{.*}}: +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>>) -> !fir.box>> +! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[EXACT_BOX]], %[[C0]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_A]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[EXACT_BOX]] [%[[SLICE]]] : (!fir.box>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[EXACT_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.box>>, !fir.slice<1> +! CHECK: %[[FIELD_B:.*]] = fir.field_index b, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[EXACT_BOX]], %[[C0]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_B]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[EXACT_BOX]] [%[[SLICE]]] : (!fir.box>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[EXACT_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.box>>, !fir.slice<1> +! CHECK: %[[FIELD_C:.*]] = fir.field_index c, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[EXACT_BOX]], %[[C0]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD_C]] : (index, index, index, !fir.field) -> !fir.slice<1> +! CHECK: %[[ARRAY_LOAD:.*]] = fir.array_load %[[EXACT_BOX]] [%[[SLICE]]] : (!fir.box>>, !fir.slice<1>) -> !fir.array +! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[IND:.*]] = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%[[ARG:.*]] = %[[ARRAY_LOAD]]) -> (!fir.array) { +! CHECK: %[[ARR_UP:.*]] = fir.array_update %[[ARG]], %{{.*}}, %[[IND]] : (!fir.array, i32, index) -> !fir.array +! CHECK: fir.result %[[ARR_UP]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[ARRAY_LOAD]], %[[DO_RES]] to %[[EXACT_BOX]][%[[SLICE]]] : !fir.array, !fir.array, !fir.box>>, !fir.slice<1> +! CHECK: cf.br ^bb{{.*}} + + subroutine select_type10(a) + class(p1), pointer :: a + select type(a) + type is (p1) + a%a = 1 + type is (p2) + a%c = 3 + class is (p1) + a%a = 5 + end select + end subroutine + +! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type10( +! CHECK-SAME: %[[ARG0:.*]]: !fir.ref>>> {fir.bindc_name = "a"}) { +! CHECK: %[[SELECTOR:.*]] = fir.load %[[ARG0]] : !fir.ref>>> +! CHECK: fir.select_type %[[SELECTOR]] : !fir.class>> [#fir.type_is>, ^bb{{.*}}, #fir.type_is>, ^bb{{.*}}, #fir.class_is>, ^bb{{.*}}, unit, ^bb{{.*}}] +! CHECK: ^bb{{.*}}: +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>>) -> !fir.box>> +! CHECK: %[[C1:.*]] = arith.constant 1 : i32 +! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}> +! CHECK: %[[COORD_A:.*]] = fir.coordinate_of %[[EXACT_BOX]], %[[FIELD_A]] : (!fir.box>>, !fir.field) -> !fir.ref +! CHECK: fir.store %[[C1]] to %[[COORD_A]] : !fir.ref +! CHECK: cf.br ^bb{{.*}} +! CHECK: ^bb{{.*}}: +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>>) -> !fir.box>> +! CHECK: %[[C3:.*]] = arith.constant 3 : i32 +! CHECK: %[[FIELD_C:.*]] = fir.field_index c, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}> +! CHECK: %[[COORD_C:.*]] = fir.coordinate_of %[[EXACT_BOX]], %[[FIELD_C]] : (!fir.box>>, !fir.field) -> !fir.ref +! CHECK: fir.store %[[C3]] to %[[COORD_C]] : !fir.ref +! CHECK: cf.br ^bb{{.*}} +! CHECK: ^bb{{.*}} +! CHECK: %[[C5:.*]] = arith.constant 5 : i32 +! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}> +! CHECK: %[[COORD_A:.*]] = fir.coordinate_of %[[SELECTOR]], %[[FIELD_A]] : (!fir.class>>, !fir.field) -> !fir.ref +! CHECK: fir.store %[[C5]] to %[[COORD_A]] : !fir.ref +! CHECK: cf.br ^bb{{.*}} + + subroutine select_type11(a) + class(p1), allocatable :: a + select type(a) + type is (p1) + a%a = 1 + type is (p2) + a%a = 2 + a%c = 3 + end select + end subroutine + +! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type11( +! CHECK-SAME: %[[ARG0:.*]]: !fir.ref>>> {fir.bindc_name = "a"}) { +! CHECK: %[[SELECTOR:.*]] = fir.load %[[ARG0]] : !fir.ref>>> +! CHECK: fir.select_type %[[SELECTOR]] : !fir.class>> [#fir.type_is>, ^bb1, #fir.type_is>, ^bb2, unit, ^bb3] +! CHECK: ^bb{{.*}}: +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>>) -> !fir.box>> +! CHECK: %[[C1:.*]] = arith.constant 1 : i32 +! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMselect_type_lower_testTp1{a:i32,b:i32}> +! CHECK: %[[COORD_A:.*]] = fir.coordinate_of %[[EXACT_BOX]], %[[FIELD_A]] : (!fir.box>>, !fir.field) -> !fir.ref +! CHECK: fir.store %[[C1]] to %[[COORD_A]] : !fir.ref +! CHECK: cf.br ^bb{{.*}} +! CHECK: ^bb{{.*}}: +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>>) -> !fir.box>> +! CHECK: %[[C3:.*]] = arith.constant 3 : i32 +! CHECK: %[[FIELD_C:.*]] = fir.field_index c, !fir.type<_QMselect_type_lower_testTp2{a:i32,b:i32,c:i32}> +! CHECK: %[[COORD_C:.*]] = fir.coordinate_of %[[EXACT_BOX]], %[[FIELD_C]] : (!fir.box>>, !fir.field) -> !fir.ref +! CHECK: fir.store %[[C3]] to %[[COORD_C]] : !fir.ref +! CHECK: cf.br ^bb{{.*}} + + subroutine select_type12(a) + class(p1), pointer :: a(:) + select type(a) + type is (p1) + a%a = 120 + type is (p2) + a%c = 121 + class is (p1) + a%a = 122 + end select + end subroutine + +! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type12( +! CHECK-SAME: %[[ARG0:.*]]: !fir.ref>>>> {fir.bindc_name = "a"}) { +! CHECK: %[[LOAD:.*]] = fir.load %[[ARG0]] : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[LOAD]], %[[C0]] : (!fir.class>>>, index) -> (index, index, index) +! CHECK: %[[SHIFT:.*]] = fir.shift %[[BOX_DIMS]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[SELECTOR:.*]] = fir.rebox %[[LOAD]](%[[SHIFT]]) : (!fir.class>>>, !fir.shift<1>) -> !fir.class>> +! CHECK: fir.select_type %[[SELECTOR]] : !fir.class>> [#fir.type_is>, ^bb1, #fir.type_is>, ^bb2, #fir.class_is>, ^bb3, unit, ^bb4] +! CHECK: ^bb{{.*}}: +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>>) -> !fir.box>> +! CHECK: ^bb{{.*}}: // pred: ^bb0 +! CHECK: %[[EXACT_BOX:.*]] = fir.convert %[[SELECTOR]] : (!fir.class>>) -> !fir.box>> + end module program test_select_type use select_type_lower_test integer :: a + integer :: arr(2) real :: b + real :: barr(2) + character(1) :: carr(2) type(p4) :: t4 - type(p2) :: t2 - type(p1) :: t1 + type(p1), target :: t1 + type(p2), target :: t2 + type(p1), target :: t1arr(2) + type(p2) :: t2arr(2) + class(p1), pointer :: p + class(p1), allocatable :: p1alloc + class(p1), allocatable :: p2alloc + class(p1), pointer :: parr(:) call select_type7(t4) call select_type7(t2) @@ -452,4 +757,52 @@ program test_select_type call select_type6(b) print*, b + print*, '> select_type8 with type(p1), dimension(2)' + call select_type8(t1arr) + print*, t1arr(1) + print*, t1arr(2) + + print*, '> select_type8 with type(p2), dimension(2)' + call select_type8(t2arr) + print*, t2arr(1) + print*, t2arr(2) + + print*, '> select_type8 with integer, dimension(2)' + call select_type8(arr) + print*, arr(:) + + print*, '> select_type8 with real, dimension(2)' + call select_type8(barr) + print*, barr(:) + + print*, '> select_type8 with character(1), dimension(2)' + call select_type8(carr) + print*, carr(:) + + t1%a = 0 + p => t1 + print*, '> select_type10' + call select_type10(p) + print*, t1 + + t2%c = 0 + p => t2 + print*, '> select_type10' + call select_type10(p) + print*, t2 + + allocate(p1::p1alloc) + print*, '> select_type11' + call select_type11(p1alloc) + print*, p1alloc%a + + allocate(p2::p2alloc) + print*, '> select_type11' + call select_type11(p2alloc) + print*, p2alloc%a + + parr => t1arr + call select_type12(parr) + print*, t1arr(1) + print*, t1arr(2) end -- 2.7.4