[flang-commits] [flang] 50960e9 - [flang] Catch character length errors in pointer associations
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Feb 1 12:12:55 PST 2023
Author: Peter Klausler
Date: 2023-02-01T12:12:43-08:00
New Revision: 50960e93833c821598044db131cf820edf6c6b3f
URL: https://github.com/llvm/llvm-project/commit/50960e93833c821598044db131cf820edf6c6b3f
DIFF: https://github.com/llvm/llvm-project/commit/50960e93833c821598044db131cf820edf6c6b3f.diff
LOG: [flang] Catch character length errors in pointer associations
When character lengths are known at compilation time, report an error
when a data target with a known length does not match the explicit length
of a pointer that is being associated with it; see 10.2.2.3 paragraph 5.
Differential Revision: https://reviews.llvm.org/D142755
Added:
flang/test/Semantics/assign13.f90
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/variable.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/pointer-assignment.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 7d305e563b646..29bf0e92dc407 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -87,7 +87,7 @@ class TypeAndShape {
static std::optional<TypeAndShape> Characterize(
const ActualArgument &, FoldingContext &);
- // Handle Expr<T> & Designator<T>
+ // General case for Expr<T>, ActualArgument, &c.
template <typename A>
static std::optional<TypeAndShape> Characterize(
const A &x, FoldingContext &context) {
@@ -110,6 +110,26 @@ class TypeAndShape {
return std::nullopt;
}
+ // Specialization for character designators
+ template <int KIND>
+ static std::optional<TypeAndShape> Characterize(
+ const Designator<Type<TypeCategory::Character, KIND>> &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 <typename A>
static std::optional<TypeAndShape> Characterize(
const std::optional<A> &x, FoldingContext &context) {
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 6831cfead727a..ada7b18b6afd3 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -63,6 +63,11 @@ bool TypeAndShape::operator==(const TypeAndShape &that) const {
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
index b68772e8304c5..083b6bae57589 100644
--- a/flang/lib/Evaluate/variable.cpp
+++ b/flang/lib/Evaluate/variable.cpp
@@ -602,15 +602,20 @@ template <typename T>
std::optional<DynamicType> Designator<T>::GetType() const {
if constexpr (IsLengthlessIntrinsicType<Result>) {
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<Substring>(&u)}) {
- const auto *parent{substring->GetParentIf<StaticDataObject::Pointer>()};
- CHECK(parent);
- return DynamicType{TypeCategory::Character, (*parent)->itemBytes()};
+ }
+ if constexpr (Result::category == TypeCategory::Character) {
+ if (std::holds_alternative<Substring>(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
index fc02b9127712e..697dbc7d34eae 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -526,15 +526,12 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
}
}
// 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
index a2e34970c1963..86c6d9fa41e2e 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -252,7 +252,7 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
" 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
index 0000000000000..ed02899e98973
--- /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
More information about the flang-commits
mailing list