[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

diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 7d305e5..29bf0e9 100644 (file)
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -87,7 +87,7 @@ public:
   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 @@ public:
     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 6831cfe..ada7b18 100644 (file)
--- 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 b68772e..083b6ba 100644 (file)
--- 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 fc02b91..697dbc7 100644 (file)
--- 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 a2e3497..86c6d9f 100644 (file)
--- 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 (file)
index 0000000..ed02899
--- /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