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 @@ -2223,11 +2223,6 @@ int kind = Fortran::evaluate::ToInt64(intrinsic->kind()).value_or(kind); llvm::SmallVector params; - if (intrinsic->category() == - Fortran::common::TypeCategory::Character || - intrinsic->category() == - Fortran::common::TypeCategory::Derived) - TODO(loc, "typeSpec with length parameters"); ty = genType(intrinsic->category(), kind, params); } else { const Fortran::semantics::DerivedTypeSpec *derived = @@ -2291,12 +2286,23 @@ exactValue = builder->create( loc, fir::ReferenceType::get(attr.getType()), fir::getBase(selector)); + const Fortran::semantics::IntrinsicTypeSpec *intrinsic = + typeSpec->declTypeSpec->AsIntrinsic(); + if (intrinsic->category() == + Fortran::common::TypeCategory::Character) { + mlir::Value unknownLen = builder->createIntegerConstant( + loc, builder->getIndexType(), + fir::CharacterType::unknownLen()); + addAssocEntitySymbol(fir::CharBoxValue(exactValue, unknownLen)); + } else { + addAssocEntitySymbol(exactValue); + } } else if (std::holds_alternative( typeSpec->u)) { exactValue = builder->create( loc, fir::BoxType::get(attr.getType()), fir::getBase(selector)); + addAssocEntitySymbol(exactValue); } - addAssocEntitySymbol(exactValue); } else if (std::holds_alternative( guard.u)) { // CLASS IS diff --git a/flang/lib/Optimizer/Transforms/ControlFlowConverter.cpp b/flang/lib/Optimizer/Transforms/ControlFlowConverter.cpp --- a/flang/lib/Optimizer/Transforms/ControlFlowConverter.cpp +++ b/flang/lib/Optimizer/Transforms/ControlFlowConverter.cpp @@ -464,7 +464,10 @@ return fir::complexBitsToTypeCode( kindMap.getRealBitsize(cmplxTy.getFKind())); } - return 0; // TODO more types. + if (auto charTy = ty.dyn_cast()) + return fir::characterBitsToTypeCode( + kindMap.getCharacterBitsize(charTy.getFKind())); + return 0; } mlir::LogicalResult @@ -476,13 +479,14 @@ mlir::Value cmp; // TYPE IS type guard comparison are all done inlined. if (auto a = attr.dyn_cast()) { - if (fir::isa_trivial(a.getType())) { + if (fir::isa_trivial(a.getType()) || + a.getType().isa()) { // For type guard statement with Intrinsic type spec the type code of // the descriptor is compared. int code = getTypeCode(a.getType(), kindMap); if (code == 0) return mlir::emitError(loc) - << "type code not done for " << a.getType(); + << "type code unavailable for " << a.getType(); mlir::Value typeCode = rewriter.create( loc, rewriter.getI8IntegerAttr(code)); mlir::Value selectorTypeCode = rewriter.create( diff --git a/flang/test/Lower/select-type.f90 b/flang/test/Lower/select-type.f90 --- a/flang/test/Lower/select-type.f90 +++ b/flang/test/Lower/select-type.f90 @@ -253,6 +253,8 @@ print*, 'type is real' type is (logical) print*, 'type is logical' + type is (character(*)) + print*, 'type is character' class default print*,'default' end select @@ -261,14 +263,57 @@ ! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type5( ! CHECK-SAME: %[[ARG0:.*]]: !fir.class {fir.bindc_name = "a"}) ! CHECK: fir.select_type %[[ARG0]] : !fir.class -! CHECK-SAME: [#fir.type_is, ^[[I8_BLK:.*]], #fir.type_is, ^[[I32_BLK:.*]], #fir.type_is, ^[[F32_BLK:.*]], #fir.type_is>, ^[[LOG_BLK:.*]], unit, ^[[DEFAULT:.*]]] +! CHECK-SAME: [#fir.type_is, ^[[I8_BLK:.*]], #fir.type_is, ^[[I32_BLK:.*]], #fir.type_is, ^[[F32_BLK:.*]], #fir.type_is>, ^[[LOG_BLK:.*]], #fir.type_is>, ^[[CHAR_BLK:.*]], unit, ^[[DEFAULT:.*]]] ! CHECK: ^[[I8_BLK]] ! CHECK: ^[[I32_BLK]] ! CHECK: ^[[F32_BLK]] ! CHECK: ^[[LOG_BLK]] +! CHECK: ^[[CHAR_BLK]] ! CHECK: ^[[DEFAULT_BLOCK]] ! CFG-LABEL: func.func @_QMselect_type_lower_testPselect_type5( +! CFG-SAME: %[[SELECTOR:.*]]: !fir.class {fir.bindc_name = "a"}) { + +! CFG: %[[INT8_TC:.*]] = arith.constant 7 : i8 +! CFG: %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class) -> i8 +! CFG: %[[IS_INT8:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[INT8_TC]] : i8 +! CFG: cf.cond_br %[[IS_INT8]], ^[[INT8_BLK:.*]], ^[[NOT_INT8:.*]] +! CFG: ^[[NOT_INT8]]: +! CFG: %[[INT32_TC:.*]] = arith.constant 9 : i8 +! CFG: %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class) -> i8 +! CFG: %[[IS_INT32:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[INT32_TC]] : i8 +! CFG: cf.cond_br %[[IS_INT32]], ^[[INT32_BLK:.*]], ^[[NOT_INT32_BLK:.*]] +! CFG: ^[[INT8_BLK]]: +! CFG: cf.br ^[[EXIT_BLK:.*]] +! CFG: ^[[NOT_INT32_BLK]]: +! CFG: %[[FLOAT_TC:.*]] = arith.constant 27 : i8 +! CFG: %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class) -> i8 +! CFG: %[[IS_FLOAT:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[FLOAT_TC]] : i8 +! CFG: cf.cond_br %[[IS_FLOAT]], ^[[FLOAT_BLK:.*]], ^[[NOT_FLOAT_BLK:.*]] +! CFG: ^[[INT32_BLK]]: +! CFG: cf.br ^[[EXIT_BLK]] +! CFG: ^[[NOT_FLOAT_BLK]]: +! CFG: %[[LOGICAL_TC:.*]] = arith.constant 14 : i8 +! CFG: %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class) -> i8 +! CFG: %[[IS_LOGICAL:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[LOGICAL_TC]] : i8 +! CFG: cf.cond_br %[[IS_LOGICAL]], ^[[LOGICAL_BLK:.*]], ^[[NOT_LOGICAL_BLK:.*]] +! CFG: ^[[FLOAT_BLK]]: +! CFG: cf.br ^[[EXIT_BLK]] +! CFG: ^[[NOT_LOGICAL_BLK]]: +! CFG: %[[CHAR_TC:.*]] = arith.constant 40 : i8 +! CFG: %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class) -> i8 +! CFG: %[[IS_CHAR:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[CHAR_TC]] : i8 +! CFG: cf.cond_br %[[IS_CHAR]], ^[[CHAR_BLK:.*]], ^[[NOT_CHAR_BLK:.*]] +! CFG: ^[[LOGICAL_BLK]]: +! CFG: cf.br ^[[EXIT_BLK]] +! CFG: ^[[NOT_CHAR_BLK]]: +! CFG: cf.br ^[[DEFAULT_BLK:.*]] +! CFG: ^[[CHAR_BLK]]: +! CFG: cf.br ^[[EXIT_BLK]] +! CFG: ^[[DEFAULT_BLK]]: +! CFG: cf.br ^[[EXIT_BLK]] +! CFG: ^bb12: +! CFG: return subroutine select_type6(a) class(*) :: a