[flang] Catch character length errors in pointer associations

[klausler]

Summary

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.

[jeanPerier]

LGTM

flang/include/flang/Evaluate/characteristics.h

public:
 
   static std::optional<TypeAndShape> Characterize(
       const semantics::Symbol &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::DeclTypeSpec &, FoldingContext &);
   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) {
     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 (type->category() == TypeCategory::Character) {
         if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
           if (auto length{chExpr->LEN()}) {
             result.set_LEN(std::move(*length));
           }
         }
       }
       return std::move(result.Rewrite(context));
     }
     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) {
     if (x) {
       return Characterize(*x, context);
     } else {
       return std::nullopt;
     }

flang/lib/Evaluate/characteristics.cpp

 
 bool TypeAndShape::operator==(const TypeAndShape &that) const {
   return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) &&
       attrs_ == that.attrs_ && corank_ == that.corank_;
 }
 
 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;
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const semantics::Symbol &symbol, FoldingContext &context) {
   const auto &ultimate{symbol.GetUltimate()};
   return common::visit(

flang/lib/Evaluate/variable.cpp

#endif
       },
       u);
 }
 
 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;
 }
 
 static NamedEntity AsNamedEntity(const SymbolVector &x) {
   CHECK(!x.empty());
   NamedEntity result{x.front()};
   int j{0};

flang/lib/Semantics/check-call.cpp

if (actualIsUnlimited != dummyIsUnlimited) {
           messages.Say(
               "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US);
         } else {
           messages.Say(
               "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US);
         }
       }
       // 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() !=
+      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);
       }
     }
   }
 
   // 15.5.2.8 -- coarray dummy arguments
   if (dummy.type.corank() > 0) {

flang/lib/Semantics/pointer-assignment.cpp

if (!lhsType_) {
               " VOLATILE coarray"_err_en_US;
       }
     } else if (rhsType->type().IsUnlimitedPolymorphic()) {
       if (!LhsOkForUnlimitedPoly()) {
         msg = "Pointer type must be unlimited polymorphic or non-extensible"
               " 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()};
 
       } else if (!isBoundsRemapping_) {
         int lhsRank{evaluate::GetRank(lhsType_->shape())};
         int rhsRank{evaluate::GetRank(rhsType->shape())};
         if (lhsRank != rhsRank) {

flang/test/Semantics/assign13.f90

+! 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