[flang] Fix shape analysis of RHS designators of pointer assignments

Original-commit: flang-compiler/f18@bf26a36ef4255188b294a73bdc138dfba52cf5d3
Reviewed-on: https://github.com/flang-compiler/f18/pull/938

diff --git a/flang/lib/evaluate/characteristics.cc b/flang/lib/evaluate/characteristics.cc
index 18ab90d..de03d7d 100644 (file)
--- a/flang/lib/evaluate/characteristics.cc
+++ b/flang/lib/evaluate/characteristics.cc
@@ -121,6 +121,7 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
   }
 }
 
+#if 0  // pmk
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const Expr<SomeType> &expr, FoldingContext &context) {
   if (const auto *symbol{UnwrapWholeSymbolDataRef(expr)}) {
@@ -147,6 +148,7 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
   }
   return std::nullopt;
 }
+#endif  // pmk
 
 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
     const TypeAndShape &that, const char *thisIs, const char *thatIs,

diff --git a/flang/lib/evaluate/characteristics.h b/flang/lib/evaluate/characteristics.h
index 049740a..3da4d63 100644 (file)
--- a/flang/lib/evaluate/characteristics.h
+++ b/flang/lib/evaluate/characteristics.h
@@ -82,8 +82,30 @@ public:
       const semantics::ProcInterface &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::DeclTypeSpec &);
+
+  template<typename A>
   static std::optional<TypeAndShape> Characterize(
-      const Expr<SomeType> &, FoldingContext &);
+      const A &x, FoldingContext &context) {
+    if (const auto *symbol{UnwrapWholeSymbolDataRef(x)}) {
+      if (auto result{Characterize(*symbol, context)}) {
+        return result;
+      }
+    }
+    if (auto type{x.GetType()}) {
+      if (auto shape{GetShape(context, x)}) {
+        TypeAndShape result{*type, std::move(*shape)};
+        if (type->category() == TypeCategory::Character) {
+          if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
+            if (auto length{chExpr->LEN()}) {
+              result.set_LEN(Expr<SomeInteger>{std::move(*length)});
+            }
+          }
+        }
+        return result;
+      }
+    }
+    return std::nullopt;
+  }
 
   DynamicType type() const { return type_; }
   TypeAndShape &set_type(DynamicType t) {

diff --git a/flang/lib/semantics/pointer-assignment.cc b/flang/lib/semantics/pointer-assignment.cc
index ab51f09..57b7d8c 100644 (file)
--- a/flang/lib/semantics/pointer-assignment.cc
+++ b/flang/lib/semantics/pointer-assignment.cc
@@ -188,12 +188,13 @@ void PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
   } else if (!evaluate::GetLastTarget(GetSymbolVector(d))) {  // C1025
     msg = "In assignment to object %s, the target '%s' is not an object with"
           " POINTER or TARGET attributes"_err_en_US;
-  } else if (auto rhsType{TypeAndShape::Characterize(*last, context_)}) {
+  } else if (auto rhsType{TypeAndShape::Characterize(d, context_)}) {
     if (!lhsType_) {
       msg = "%s associated with object '%s' with incompatible type or"
             " shape"_err_en_US;
     } else if (rhsType->corank() > 0 &&
         (isVolatile_ != last->attrs().test(Attr::VOLATILE))) {  // C1020
+      // TODO: what if A is VOLATILE in A%B%C?  need a better test here
       if (isVolatile_) {
         msg = "Pointer may not be VOLATILE when target is a"
               " non-VOLATILE coarray"_err_en_US;