diff --git a/flang/include/flang/Evaluate/fold.h b/flang/include/flang/Evaluate/fold.h --- a/flang/include/flang/Evaluate/fold.h +++ b/flang/include/flang/Evaluate/fold.h @@ -69,7 +69,8 @@ // GetScalarConstantValue() extracts the known scalar constant value of // an expression, if it has one. The value can be parenthesized. template -auto GetScalarConstantValue(const EXPR &expr) -> std::optional> { +constexpr auto GetScalarConstantValue(const EXPR &expr) + -> std::optional> { if (const Constant *constant{UnwrapConstantValue(expr)}) { return constant->GetScalarValue(); } else { @@ -81,7 +82,7 @@ // Ensure that the expression has been folded beforehand when folding might // be required. template -std::optional ToInt64( +constexpr std::optional ToInt64( const Expr> &expr) { if (auto scalar{ GetScalarConstantValue>(expr)}) { diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -81,15 +81,16 @@ // directly hold anything requiring a destructor, such as an arbitrary // CHARACTER length type parameter expression. Those must be derived // via LEN() member functions, packaged elsewhere (e.g. as in -// ArrayConstructor), or copied from a parameter spec in the symbol table -// if one is supplied. +// ArrayConstructor), copied from a parameter spec in the symbol table +// if one is supplied, or a known integer value. class DynamicType { public: constexpr DynamicType(TypeCategory cat, int k) : category_{cat}, kind_{k} { CHECK(IsValidKindOfIntrinsicType(category_, kind_)); } - constexpr DynamicType(int k, const semantics::ParamValue &pv) - : category_{TypeCategory::Character}, kind_{k}, charLength_{&pv} { + DynamicType(int charKind, const semantics::ParamValue &len); + constexpr DynamicType(int k, std::int64_t len) + : category_{TypeCategory::Character}, kind_{k}, knownLength_{len} { CHECK(IsValidKindOfIntrinsicType(category_, kind_)); } explicit constexpr DynamicType( @@ -137,8 +138,11 @@ CHECK(kind_ > 0); return kind_; } - constexpr const semantics::ParamValue *charLength() const { - return charLength_; + constexpr const semantics::ParamValue *charLengthParamValue() const { + return charLengthParamValue_; + } + constexpr std::optional knownLength() const { + return knownLength_; } std::optional> GetCharLength() const; @@ -212,7 +216,8 @@ TypeCategory category_{TypeCategory::Derived}; // overridable default int kind_{0}; - const semantics::ParamValue *charLength_{nullptr}; + const semantics::ParamValue *charLengthParamValue_{nullptr}; + std::optional knownLength_; const semantics::DerivedTypeSpec *derived_{nullptr}; // TYPE(T), CLASS(T) }; diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -216,12 +216,8 @@ } void TypeAndShape::AcquireLEN() { - if (type_.category() == TypeCategory::Character) { - if (const auto *param{type_.charLength()}) { - if (const auto &intExpr{param->GetExplicit()}) { - LEN_ = ConvertToType(common::Clone(*intExpr)); - } - } + if (auto len{type_.GetCharLength()}) { + LEN_ = std::move(len); } } @@ -694,7 +690,9 @@ const DynamicType &type{typeAndShape->type()}; switch (type.category()) { case TypeCategory::Character: - if (const auto *param{type.charLength()}) { + if (type.knownLength()) { + return true; + } else if (const auto *param{type.charLengthParamValue()}) { if (const auto &expr{param->GetExplicit()}) { return IsConstantExpr(*expr); // 15.4.2.2(4)(c) } else if (param->isAssumed()) { diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp --- a/flang/lib/Evaluate/formatting.cpp +++ b/flang/lib/Evaluate/formatting.cpp @@ -475,13 +475,15 @@ if (derived_) { CHECK(category_ == TypeCategory::Derived); return DerivedTypeSpecAsFortran(*derived_); - } else if (charLength_) { + } else if (charLengthParamValue_ || knownLength_) { std::string result{"CHARACTER(KIND="s + std::to_string(kind_) + ",LEN="}; - if (charLength_->isAssumed()) { + if (knownLength_) { + result += std::to_string(*knownLength_) + "_8"; + } else if (charLengthParamValue_->isAssumed()) { result += '*'; - } else if (charLength_->isDeferred()) { + } else if (charLengthParamValue_->isDeferred()) { result += ':'; - } else if (const auto &length{charLength_->GetExplicit()}) { + } else if (const auto &length{charLengthParamValue_->GetExplicit()}) { result += length->AsFortran(); } return result + ')'; diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1481,12 +1481,6 @@ CHECK(FloatingType.test(*category)); resultType = DynamicType{*category, defaults.doublePrecisionKind()}; break; - case KindCode::defaultCharKind: - CHECK(result.categorySet == CharType); - CHECK(*category == TypeCategory::Character); - resultType = DynamicType{TypeCategory::Character, - defaults.GetDefaultKind(TypeCategory::Character)}; - break; case KindCode::defaultLogicalKind: CHECK(result.categorySet == LogicalType); CHECK(*category == TypeCategory::Logical); @@ -1516,7 +1510,11 @@ CHECK(expr->Rank() == 0); if (auto code{ToInt64(*expr)}) { if (IsValidKindOfIntrinsicType(*category, *code)) { - resultType = DynamicType{*category, static_cast(*code)}; + if (*category == TypeCategory::Character) { // ACHAR & CHAR + resultType = DynamicType{static_cast(*code), 1}; + } else { + resultType = DynamicType{*category, static_cast(*code)}; + } break; } } @@ -1535,7 +1533,12 @@ } else { CHECK(kindDummyArg->optionality == Optionality::defaultsToDefaultForResult); - resultType = DynamicType{*category, defaults.GetDefaultKind(*category)}; + int kind{defaults.GetDefaultKind(*category)}; + if (*category == TypeCategory::Character) { // ACHAR & CHAR + resultType = DynamicType{kind, 1}; + } else { + resultType = DynamicType{*category, kind}; + } } break; case KindCode::likeMultiply: @@ -1557,6 +1560,7 @@ resultType = DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()}; break; + case KindCode::defaultCharKind: case KindCode::typeless: case KindCode::teamType: case KindCode::any: diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -615,20 +615,16 @@ if (auto *cx{UnwrapExpr>(x)}) { auto converted{ ConvertToKind(type.kind(), std::move(*cx))}; - if (type.charLength()) { - if (const auto &len{type.charLength()->GetExplicit()}) { - Expr lenParam{*len}; - Expr length{Convert{lenParam}}; - converted = std::visit( - [&](auto &&x) { - using Ty = std::decay_t; - using CharacterType = typename Ty::Result; - return Expr{ - Expr{SetLength{ - std::move(x), std::move(length)}}}; - }, - std::move(converted.u)); - } + if (auto length{type.GetCharLength()}) { + converted = std::visit( + [&](auto &&x) { + using Ty = std::decay_t; + using CharacterType = typename Ty::Result; + return Expr{ + Expr{SetLength{ + std::move(x), std::move(*length)}}}; + }, + std::move(converted.u)); } return Expr{std::move(converted)}; } diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -92,20 +92,36 @@ namespace Fortran::evaluate { +DynamicType::DynamicType(int k, const semantics::ParamValue &pv) + : category_{TypeCategory::Character}, kind_{k} { + CHECK(IsValidKindOfIntrinsicType(category_, kind_)); + if (auto n{ToInt64(pv.GetExplicit())}) { + knownLength_ = *n; + } else { + charLengthParamValue_ = &pv; + } +} + template inline bool PointeeComparison(const A *x, const A *y) { return x == y || (x && y && *x == *y); } bool DynamicType::operator==(const DynamicType &that) const { return category_ == that.category_ && kind_ == that.kind_ && - PointeeComparison(charLength_, that.charLength_) && + PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) && + knownLength_.has_value() == that.knownLength_.has_value() && + (!knownLength_ || *knownLength_ == *that.knownLength_) && PointeeComparison(derived_, that.derived_); } std::optional> DynamicType::GetCharLength() const { - if (category_ == TypeCategory::Character && charLength_) { - if (auto length{charLength_->GetExplicit()}) { - return ConvertToType(std::move(*length)); + if (category_ == TypeCategory::Character) { + if (knownLength_) { + return AsExpr(Constant(*knownLength_)); + } else if (charLengthParamValue_) { + if (auto length{charLengthParamValue_->GetExplicit()}) { + return ConvertToType(std::move(*length)); + } } } return std::nullopt; @@ -171,16 +187,18 @@ } bool DynamicType::IsAssumedLengthCharacter() const { - return category_ == TypeCategory::Character && charLength_ && - charLength_->isAssumed(); + return category_ == TypeCategory::Character && charLengthParamValue_ && + charLengthParamValue_->isAssumed(); } bool DynamicType::IsNonConstantLengthCharacter() const { if (category_ != TypeCategory::Character) { return false; - } else if (!charLength_) { + } else if (knownLength_) { + return false; + } else if (!charLengthParamValue_) { return true; - } else if (const auto &expr{charLength_->GetExplicit()}) { + } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) { return !IsConstantExpr(*expr); } else { return true; @@ -427,7 +445,7 @@ } } } - return charLength_ && charLength_->isDeferred(); + return charLengthParamValue_ && charLengthParamValue_->isDeferred(); } bool SomeKind::operator==( diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp --- a/flang/lib/Evaluate/variable.cpp +++ b/flang/lib/Evaluate/variable.cpp @@ -265,18 +265,11 @@ return chExpr->LEN(); } } else if (auto dyType{DynamicType::From(ultimate)}) { - if (const semantics::ParamValue * len{dyType->charLength()}) { - if (len->isExplicit()) { - if (auto intExpr{len->GetExplicit()}) { - if (IsConstantExpr(*intExpr)) { - return ConvertToType(*std::move(intExpr)); - } - } - } - if (IsDescriptor(ultimate) && !ultimate.owner().IsDerivedType()) { - return Expr{DescriptorInquiry{ - NamedEntity{ultimate}, DescriptorInquiry::Field::Len}}; - } + if (auto len{dyType->GetCharLength()}) { + return len; + } else if (IsDescriptor(ultimate) && !ultimate.owner().IsDerivedType()) { + return Expr{DescriptorInquiry{ + NamedEntity{ultimate}, DescriptorInquiry::Field::Len}}; } } return std::nullopt; @@ -351,12 +344,16 @@ return c.value().LEN(); }, [](const SpecificIntrinsic &i) -> T { - if (i.name == "char") { - return Expr{1}; - } - // Some other cases whose results' lengths can be determined + // Some cases whose results' lengths can be determined // from the lengths of their arguments are handled in - // ProcedureRef::LEN(). + // ProcedureRef::LEN() before coming here. + if (const auto &result{i.characteristics.value().functionResult}) { + if (const auto *type{result->GetTypeAndShape()}) { + if (auto length{type->type().GetCharLength()}) { + return std::move(*length); + } + } + } return std::nullopt; }, }, diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -55,13 +55,9 @@ std::optional> DynamicTypeWithLength::LEN() const { if (length) { return length; + } else { + return GetCharLength(); } - if (auto *lengthParam{charLength()}) { - if (const auto &len{lengthParam->GetExplicit()}) { - return ConvertToType(common::Clone(*len)); - } - } - return std::nullopt; // assumed or deferred length } static std::optional AnalyzeTypeSpec( @@ -1171,9 +1167,7 @@ template Result Test() { if (type_ && type_->category() == T::category) { if constexpr (T::category == TypeCategory::Derived) { - if (type_->IsUnlimitedPolymorphic()) { - return std::nullopt; - } else { + if (!type_->IsUnlimitedPolymorphic()) { return AsMaybeExpr(ArrayConstructor{type_->GetDerivedTypeSpec(), MakeSpecific(std::move(values_))}); } @@ -1262,8 +1256,8 @@ constantLength_ = ToInt64(type_->length); values_.Push(std::move(*x)); } else if (!explicitType_) { - if (static_cast(*type_) == - static_cast(xType)) { + if (type_->IsTkCompatibleWith(xType) && + xType.IsTkCompatibleWith(*type_)) { values_.Push(std::move(*x)); if (auto thisLen{ToInt64(xType.LEN())}) { if (constantLength_) { diff --git a/flang/lib/Semantics/scope.cpp b/flang/lib/Semantics/scope.cpp --- a/flang/lib/Semantics/scope.cpp +++ b/flang/lib/Semantics/scope.cpp @@ -215,7 +215,7 @@ case TypeCategory::Complex: return &MakeNumericType(dyType->category(), KindExpr{dyType->kind()}); case TypeCategory::Character: - if (const ParamValue * lenParam{dyType->charLength()}) { + if (const ParamValue * lenParam{dyType->charLengthParamValue()}) { return &MakeCharacterType( ParamValue{*lenParam}, KindExpr{dyType->kind()}); } else { diff --git a/flang/test/Semantics/array-constr-values.f90 b/flang/test/Semantics/array-constr-values.f90 --- a/flang/test/Semantics/array-constr-values.f90 +++ b/flang/test/Semantics/array-constr-values.f90 @@ -83,3 +83,9 @@ (0.0, iDuplicate = j,3 ), & j = 1,5 ) ] end subroutine +subroutine charLengths(c, array) + character(3) :: c + character(3) :: array(2) + !No error should ensue for distinct but compatible DynamicTypes + array = ["abc", c] +end subroutine diff --git a/flang/test/Semantics/data02.f90 b/flang/test/Semantics/data02.f90 --- a/flang/test/Semantics/data02.f90 +++ b/flang/test/Semantics/data02.f90 @@ -6,7 +6,7 @@ character(1) :: c end type type(t) :: x - !ERROR: Value in structure constructor of type INTEGER(4) is incompatible with component 'c' of type CHARACTER(KIND=1,LEN=1_4) + !ERROR: Value in structure constructor of type INTEGER(4) is incompatible with component 'c' of type CHARACTER(KIND=1,LEN=1_8) data x /t(1)/ end diff --git a/flang/test/Semantics/separate-mp02.f90 b/flang/test/Semantics/separate-mp02.f90 --- a/flang/test/Semantics/separate-mp02.f90 +++ b/flang/test/Semantics/separate-mp02.f90 @@ -72,10 +72,10 @@ end module subroutine s9(x, y, z, w) character(len=4) :: x - !ERROR: Dummy argument 'y' has type CHARACTER(KIND=1,LEN=5_4); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=4_4) + !ERROR: Dummy argument 'y' has type CHARACTER(KIND=1,LEN=5_8); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=4_8) character(len=5) :: y character(len=*) :: z - !ERROR: Dummy argument 'w' has type CHARACTER(KIND=1,LEN=4_4); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=*) + !ERROR: Dummy argument 'w' has type CHARACTER(KIND=1,LEN=4_8); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=*) character(len=4) :: w end end