diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -87,7 +87,7 @@ static std::optional Characterize( const ActualArgument &, FoldingContext &); - // Handle Expr & Designator + // General case for Expr, ActualArgument, &c. template static std::optional Characterize( const A &x, FoldingContext &context) { @@ -110,6 +110,26 @@ return std::nullopt; } + // Specialization for character designators + template + static std::optional Characterize( + const Designator> &x, + FoldingContext &context) { + if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) { + if (auto result{Characterize(*symbol, context)}) { + return result; + } + } + if (auto type{x.GetType()}) { + TypeAndShape result{*type, GetShape(context, x)}; + if (auto length{x.LEN()}) { + result.set_LEN(std::move(*length)); + } + return std::move(result.Rewrite(context)); + } + return std::nullopt; + } + template static std::optional Characterize( const std::optional &x, FoldingContext &context) { 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 @@ -63,6 +63,11 @@ TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) { LEN_ = Fold(context, std::move(LEN_)); + if (LEN_) { + if (auto n{ToInt64(*LEN_)}) { + type_ = DynamicType{type_.kind(), *n}; + } + } shape_ = Fold(context, std::move(shape_)); return *this; } 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 @@ -602,15 +602,20 @@ std::optional Designator::GetType() const { if constexpr (IsLengthlessIntrinsicType) { return Result::GetType(); - } else if (const Symbol * symbol{GetLastSymbol()}) { - return DynamicType::From(*symbol); - } else if constexpr (Result::category == TypeCategory::Character) { - if (const Substring * substring{std::get_if(&u)}) { - const auto *parent{substring->GetParentIf()}; - CHECK(parent); - return DynamicType{TypeCategory::Character, (*parent)->itemBytes()}; + } + if constexpr (Result::category == TypeCategory::Character) { + if (std::holds_alternative(u)) { + if (auto len{LEN()}) { + if (auto n{ToInt64(*len)}) { + return DynamicType{T::kind, *n}; + } + } + return DynamicType{TypeCategory::Character, T::kind}; } } + if (const Symbol * symbol{GetLastSymbol()}) { + return DynamicType::From(*symbol); + } return std::nullopt; } diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -526,15 +526,12 @@ } } // 15.5.2.5(4) - if (const auto *derived{ - evaluate::GetDerivedTypeSpec(actualType.type())}) { - if (!DefersSameTypeParameters( - *derived, *evaluate::GetDerivedTypeSpec(dummy.type.type()))) { - messages.Say( - "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US); - } - } else if (dummy.type.type().HasDeferredTypeParameter() != - actualType.type().HasDeferredTypeParameter()) { + const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}; + if ((derived && + !DefersSameTypeParameters(*derived, + *evaluate::GetDerivedTypeSpec(dummy.type.type()))) || + dummy.type.type().HasDeferredTypeParameter() != + actualType.type().HasDeferredTypeParameter()) { messages.Say( "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US); } diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -252,7 +252,7 @@ " derived type when target is unlimited polymorphic"_err_en_US; } } else { - if (!lhsType_->type().IsTkCompatibleWith(rhsType->type())) { + if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) { msg = MessageFormattedText{ "Target type %s is not compatible with pointer type %s"_err_en_US, rhsType->type().AsFortran(), lhsType_->type().AsFortran()}; diff --git a/flang/test/Semantics/assign13.f90 b/flang/test/Semantics/assign13.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/assign13.f90 @@ -0,0 +1,16 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +program main + type t + character(4), pointer :: p + end type + character(5), target :: buff = "abcde" + type(t) x + !ERROR: Target type CHARACTER(KIND=1,LEN=5_8) is not compatible with pointer type CHARACTER(KIND=1,LEN=4_8) + x = t(buff) + !ERROR: Target type CHARACTER(KIND=1,LEN=3_8) is not compatible with pointer type CHARACTER(KIND=1,LEN=4_8) + x = t(buff(3:)) + !ERROR: Target type CHARACTER(KIND=1,LEN=5_8) is not compatible with pointer type CHARACTER(KIND=1,LEN=4_8) + x%p => buff + !ERROR: Target type CHARACTER(KIND=1,LEN=3_8) is not compatible with pointer type CHARACTER(KIND=1,LEN=4_8) + x%p => buff(1:3) +end