[flang] Consolidate and enhance pointer assignment checks

[klausler]

Summary

Consolidate aspects of pointer assignment & structure constructor pointer component
checking from Semantics/assignment.cpp and /expression.cpp into /pointer-assignment.cpp,
and add a warning about data targets that are not definable objects
but not hard errors. Specifically, a structure component pointer component data
target is not allowed to be a USE-associated object in a pure context by a numbered
constraint, but the right-hand side data target of a pointer assignment statement
has no such constraint, and that's the new warning.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Semantics/assignment.cpp

public:
 
   template <typename A> void PushWhereContext(const A &);
   void PopWhereContext();
   void Analyze(const parser::AssignmentStmt &);
   void Analyze(const parser::PointerAssignmentStmt &);
   void Analyze(const parser::ConcurrentControl &);
 
 private:
-  bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource,
-      bool isPointerAssignment, bool isDefinedAssignment);
+  bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource);
   void CheckShape(parser::CharBlock, const SomeExpr *);
   template <typename... A>
   parser::Message *Say(parser::CharBlock at, A &&...args) {
     return &context_.Say(at, std::forward<A>(args)...);
   }
   evaluate::FoldingContext &foldingContext() {
     return context_.foldingContext();
   }
if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
     if (auto whyNot{WhyNotDefinable(lhsLoc, scope,
             DefinabilityFlags{DefinabilityFlag::VectorSubscriptIsOk}, lhs)}) {
       if (auto *msg{Say(lhsLoc,
               "Left-hand side of assignment is not definable"_err_en_US)}) {
         msg->Attach(std::move(*whyNot));
       }
     }
     auto rhsLoc{std::get<parser::Expr>(stmt.t).source};
-    CheckForPureContext(rhs, rhsLoc, false /*not a pointer assignment*/,
-        std::holds_alternative<evaluate::ProcedureRef>(assignment->u));
+    if (std::holds_alternative<evaluate::ProcedureRef>(assignment->u)) {
+      // it's a defined ASSIGNMENT(=)
+    } else {
+      CheckForPureContext(rhs, rhsLoc);
+    }
     if (whereDepth_ > 0) {
       CheckShape(lhsLoc, &lhs);
     }
   }
 }
 
 void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
   CHECK(whereDepth_ == 0);
   if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
-    const SomeExpr &rhs{assignment->rhs};
-    CheckForPureContext(rhs, std::get<parser::Expr>(stmt.t).source,
-        true /*this is a pointer assignment*/,
-        false /*not a defined assignment*/);
     parser::CharBlock at{context_.location().value()};
     auto restorer{foldingContext().messages().SetLocation(at)};
-    const Scope &scope{context_.FindScope(at)};
-    CheckPointerAssignment(foldingContext(), *assignment, scope);
+    CheckPointerAssignment(
+        foldingContext(), *assignment, context_.FindScope(at));
   }
 }
 
 static std::optional<std::string> GetPointerComponentDesignatorName(
     const SomeExpr &expr) {
   if (const auto *derived{
           evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(expr))}) {
     PotentialAndPointerComponentIterator potentials{*derived};
if (const char *why{
             base->name(), why, *pointer);
         return false;
       }
     }
   }
   return true;
 }
 
-bool AssignmentContext::CheckForPureContext(const SomeExpr &rhs,
-    parser::CharBlock rhsSource, bool isPointerAssignment,
-    bool isDefinedAssignment) {
+bool AssignmentContext::CheckForPureContext(
+    const SomeExpr &rhs, parser::CharBlock rhsSource) {
   const Scope &scope{context_.FindScope(rhsSource)};
-  if (!FindPureProcedureContaining(scope)) {
-    return true;
-  }
+  if (FindPureProcedureContaining(scope)) {
     parser::ContextualMessages messages{
         context_.location().value(), &context_.messages()};
-  if (isPointerAssignment) {
-    if (const Symbol * base{GetFirstSymbol(rhs)}) {
-      if (const char *why{WhyBaseObjectIsSuspicious(
-              base->GetUltimate(), scope)}) { // C1594(3)
-        evaluate::SayWithDeclaration(messages, *base,
-            "A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
-            base->name(), why);
-        return false;
-      }
-    }
-  } else if (!isDefinedAssignment) {
     return CheckCopyabilityInPureScope(messages, rhs, scope);
-  }
+  } else {
     return true;
   }
+}
 
 // 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape
 void AssignmentContext::CheckShape(parser::CharBlock at, const SomeExpr *expr) {
   if (auto shape{evaluate::GetShape(foldingContext(), expr)}) {
     std::size_t size{shape->size()};
     if (size == 0) {
       Say(at, "The mask or variable must not be scalar"_err_en_US);
     }

flang/lib/Semantics/check-call.cpp

if (!actualIsCoindexed && actualLastSymbol &&
       messages.Say(
           "ALLOCATABLE %s has corank %d but actual argument has corank %d"_err_en_US,
           dummyName, dummy.type.corank(), actualLastSymbol->Corank());
     }
   }
 
   // 15.5.2.7 -- dummy is POINTER
   if (dummyIsPointer) {
-    if (dummyIsContiguous && !actualIsContiguous) {
-      messages.Say(
-          "Actual argument associated with CONTIGUOUS POINTER %s must be simply contiguous"_err_en_US,
-          dummyName);
-    }
-    if (!actualIsPointer) {
-      if (dummy.intent == common::Intent::In) {
-        if (scope) {
-          semantics::CheckPointerAssignment(
-              context, messages.at(), dummyName, dummy, actual, *scope);
-        }
-      } else {
-        messages.Say(
-            "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
-            dummyName);
-      }
-    }
-  }
+    if (actualIsPointer || dummy.intent == common::Intent::In) {
+    } else if (!actualIsPointer) {
 
   // 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE
   if ((actualIsPointer && dummyIsPointer) ||
       (actualIsAllocatable && dummyIsAllocatable)) {
     bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()};
     bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()};
     if (actualIsUnlimited != dummyIsUnlimited) {
       if (typesCompatible) {

flang/lib/Semantics/expression.cpp

MaybeExpr ExpressionAnalyzer::Analyze(
   if (!parsedType.derivedTypeSpec) {
     return std::nullopt;
   }
   const auto &spec{*parsedType.derivedTypeSpec};
   const Symbol &typeSymbol{spec.typeSymbol()};
   if (!spec.scope() || !typeSymbol.has<semantics::DerivedTypeDetails>()) {
     return std::nullopt; // error recovery
   }
+  const semantics::Scope &scope{context_.FindScope(typeName)};
+  const semantics::Scope *pureContext{FindPureProcedureContaining(scope)};
   const auto &typeDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
   const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};
 
   if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796
     AttachDeclaration(Say(typeName,
                           "ABSTRACT derived type '%s' may not be used in a "
                           "structure constructor"_err_en_US,
                           typeName),
if (symbol) {
             if (it->test(Symbol::Flag::ParentComp)) {
               unavailable.insert(it->name());
             }
           }
         }
       }
       unavailable.insert(symbol->name());
       if (value) {
-        if (symbol->has<semantics::ProcEntityDetails>()) {
-          CHECK(IsPointer(*symbol));
-        } else if (symbol->has<semantics::ObjectEntityDetails>()) {
-          // C1594(4)
-          if (const auto *pureProc{FindPureProcedureContaining(innermost)}) {
-            if (const Symbol *pointer{FindPointerComponent(*symbol)}) {
-              if (const Symbol *object{
-                      FindExternallyVisibleObject(*value, *pureProc)}) {
-                if (auto *msg{Say(expr.source,
-                        "Externally visible object '%s' may not be "
-                        "associated with pointer component '%s' in a "
-                        "pure procedure"_err_en_US,
-                        object->name(), pointer->name())}) {
-                  msg->Attach(object->name(), "Object declaration"_en_US)
-                      .Attach(pointer->name(), "Pointer declaration"_en_US);
-                }
-              }
-            }
-          }
-        } else if (symbol->has<semantics::TypeParamDetails>()) {
-          Say(expr.source,
-              "Type parameter '%s' may not appear as a component "
-              "of a structure constructor"_err_en_US,
-              symbol->name());
-          continue;
-        } else {
+        if (symbol->has<semantics::TypeParamDetails>()) {
           Say(expr.source,
-              "Component '%s' is neither a procedure pointer "
-              "nor a data object"_err_en_US,
+              "Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US,
               symbol->name());
-          continue;
         }
-        if (IsPointer(*symbol)) {
+        if (!(symbol->has<semantics::ProcEntityDetails>() ||
+                symbol->has<semantics::ObjectEntityDetails>())) {
+          continue; // recovery
+        }
+        if (IsPointer(*symbol)) { // C7104, C7105, C1594(4)
           semantics::CheckStructConstructorPointerComponent(
-              GetFoldingContext(), *symbol, *value, innermost); // C7104, C7105
+              GetFoldingContext(), *symbol, *value, innermost);
           result.Add(*symbol, Fold(std::move(*value)));
           continue;
         }
         if (IsNullPointer(*value)) {
           if (IsAllocatable(*symbol)) {
             if (IsBareNullPointer(&*value)) {
               // NULL() with no arguments allowed by 7.5.10 para 6 for
               // ALLOCATABLE.
if (symbol) {
           } else {
             AttachDeclaration(
                 Say(expr.source,
                     "A NULL pointer may not be used as the value for component '%s'"_err_en_US,
                     symbol->name()),
                 *symbol);
             continue;
           }
+        } else if (const Symbol * pointer{FindPointerComponent(*symbol)};
+                   pointer && pureContext) { // C1594(4)
+          if (const Symbol *
+              visible{semantics::FindExternallyVisibleObject(
+                  *value, *pureContext)}) {
+            Say(expr.source,
+                "The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
+                visible->name(), symbol->name(), pointer->name());
+          }
         }
         if (MaybeExpr converted{ConvertToType(*symbol, std::move(*value))}) {
           if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
             if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
               if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
                 AttachDeclaration(
                     Say(expr.source,
                         "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,

flang/lib/Semantics/pointer-assignment.cpp

PointerAssignmentChecker(
     set_lhsType(TypeAndShape::Characterize(lhs, context));
     set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
     set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
   }
   PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
   PointerAssignmentChecker &set_isContiguous(bool);
   PointerAssignmentChecker &set_isVolatile(bool);
   PointerAssignmentChecker &set_isBoundsRemapping(bool);
+  PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
   bool CheckLeftHandSide(const SomeExpr &);
   bool Check(const SomeExpr &);
 
 private:
   bool CharacterizeProcedure();
   template <typename T> bool Check(const T &);
   template <typename T> bool Check(const evaluate::Expr<T> &);
   template <typename T> bool Check(const evaluate::FunctionRef<T> &);
private:
   const std::string description_;
   const Symbol *lhs_{nullptr};
   std::optional<TypeAndShape> lhsType_;
   std::optional<Procedure> procedure_;
   bool characterizedProcedure_{false};
   bool isContiguous_{false};
   bool isVolatile_{false};
   bool isBoundsRemapping_{false};
+  const Symbol *pointerComponentLHS_{nullptr};
 };
 
 PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType(
     std::optional<TypeAndShape> &&lhsType) {
   lhsType_ = std::move(lhsType);
   return *this;
 }
 

 }
 
 PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
     bool isBoundsRemapping) {
   isBoundsRemapping_ = isBoundsRemapping;
   return *this;
 }
 
+PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS(
+    const Symbol *symbol) {
+  pointerComponentLHS_ = symbol;
+  return *this;
+}
+
 bool PointerAssignmentChecker::CharacterizeProcedure() {
   if (!characterizedProcedure_) {
     characterizedProcedure_ = true;
     if (lhs_ && IsProcedure(*lhs_)) {
       procedure_ = Procedure::Characterize(*lhs_, context_);
     }
   }
   return procedure_.has_value();
 }
 
 bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) {
   if (auto whyNot{WhyNotDefinable(context_.messages().at(), scope_,
           DefinabilityFlags{DefinabilityFlag::PointerDefinition}, lhs)}) {
-    if (auto *msg{context_.messages().Say(
+    if (auto *msg{Say(
             "The left-hand side of a pointer assignment is not definable"_err_en_US)}) {
       msg->Attach(std::move(*whyNot));
     }
     return false;
   } else {
     return true;
   }
 }

 bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
   return common::visit([&](const auto &x) { return Check(x); }, x.u);
 }
 
 bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
   if (HasVectorSubscript(rhs)) { // C1025
     Say("An array section with a vector subscript may not be a pointer target"_err_en_US);
     return false;
-  } else if (ExtractCoarrayRef(rhs)) { // C1026
+  }
+  if (ExtractCoarrayRef(rhs)) { // C1026
     Say("A coindexed object may not be a pointer target"_err_en_US);
     return false;
+  }
+  if (!common::visit([&](const auto &x) { return Check(x); }, rhs.u)) {
+    return false;
+  }
+  if (IsNullPointer(rhs)) {
+    return true;
+  }
+  if (lhs_ && IsProcedure(*lhs_)) {
+    return true;
+  }
+  if (const auto *pureProc{FindPureProcedureContaining(scope_)}) {
+    if (pointerComponentLHS_) { // C1594(4) is a hard error
+      if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) {
+        if (auto *msg{Say(
+                "Externally visible object '%s' may not be associated with pointer component '%s' in a pure procedure"_err_en_US,
+                object->name(), pointerComponentLHS_->name())}) {
+          msg->Attach(object->name(), "Object declaration"_en_US)
+              .Attach(
+                  pointerComponentLHS_->name(), "Pointer declaration"_en_US);
+        }
+        return false;
+      }
+    } else if (const Symbol * base{GetFirstSymbol(rhs)}) {
+      if (const char *why{WhyBaseObjectIsSuspicious(
+              base->GetUltimate(), scope_)}) { // C1594(3)
+        evaluate::SayWithDeclaration(context_.messages(), *base,
+            "A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
+            base->name(), why);
+        return false;
+      }
+    }
+  }
+  if (isContiguous_) {
+    if (auto contiguous{evaluate::IsContiguous(rhs, context_)}) {
+      if (!*contiguous) {
+        Say("CONTIGUOUS pointer may not be associated with a discontiguous target"_err_en_US);
+        return false;
+      }
     } else {
-    return common::visit([&](const auto &x) { return Check(x); }, rhs.u);
+      Say("Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
     }
   }
+  // Warn about undefinable data targets
+  if (auto because{
+          WhyNotDefinable(context_.messages().at(), scope_, {}, rhs)}) {
+    if (auto *msg{
+            Say("Pointer target is not a definable variable"_warn_en_US)}) {
+      msg->Attach(std::move(*because));
+    }
+    return false;
+  }
+  return true;
+}
 
 bool PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
   return true; // P => NULL() without MOLD=; always OK
 }
 
 template <typename T>
 bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
   std::string funcName;

 }
 
 template <typename T>
 bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
   const Symbol *last{d.GetLastSymbol()};
   const Symbol *base{d.GetBaseObject().symbol()};
   if (!last || !base) {
     // P => "character literal"(1:3)
-    context_.messages().Say("Pointer target is not a named entity"_err_en_US);
+    Say("Pointer target is not a named entity"_err_en_US);
     return false;
   }
   std::optional<std::variant<MessageFixedText, MessageFormattedText>> msg;
   if (CharacterizeProcedure()) {
     // Shouldn't be here in this function unless lhs is an object pointer.
     msg = "In assignment to procedure %s, the target is not a procedure or"
           " procedure pointer"_err_en_US;
   } else if (!evaluate::GetLastTarget(GetSymbolVector(d))) { // C1025
bool CheckPointerAssignment(evaluate::FoldingContext &context,
   checker.set_isBoundsRemapping(isBoundsRemapping);
   bool lhsOk{checker.CheckLeftHandSide(lhs)};
   bool rhsOk{checker.Check(rhs)};
   return lhsOk && rhsOk; // don't short-circuit
 }
 
 bool CheckStructConstructorPointerComponent(evaluate::FoldingContext &context,
     const Symbol &lhs, const SomeExpr &rhs, const Scope &scope) {
-  CHECK(IsPointer(lhs));
-  return PointerAssignmentChecker{context, scope, lhs}.Check(rhs);
+  return PointerAssignmentChecker{context, scope, lhs}
+      .set_pointerComponentLHS(&lhs)
+      .Check(rhs);
 }
 
 bool CheckPointerAssignment(evaluate::FoldingContext &context,
     parser::CharBlock source, const std::string &description,
     const DummyDataObject &lhs, const SomeExpr &rhs, const Scope &scope) {
   return PointerAssignmentChecker{context, scope, source, description}
       .set_lhsType(common::Clone(lhs.type))
       .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))

flang/test/Semantics/assign14.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Can't associate a pointer with a substring of a character literal
+program main
+  character(:), pointer :: cp
+  !ERROR: Target associated with pointer 'cp' must be a designator or a call to a pointer-valued function
+  cp => "abcd"(1:4)
+end

flang/test/Semantics/associate01.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Tests of selectors whose defining expressions are pointer-valued functions;
 ! they must be valid targets, but not pointers.
 ! (F'2018 11.1.3.3 p1) "The associating entity does not have the ALLOCATABLE or
 ! POINTER attributes; it has the TARGET attribute if and only if the selector
 ! is a variable and has either the TARGET or POINTER attribute."
 module m1
   type t
    contains
     procedure, nopass :: iptr
   end type
  contains
   function iptr(n)
     integer, intent(in), target :: n
     integer, pointer :: iptr
+    !WARNING: Pointer target is not a definable variable
+    !BECAUSE: 'n' is an INTENT(IN) dummy argument
     iptr => n
   end function
   subroutine test
     type(t) tv
     integer, target :: itarget
     integer, pointer :: ip
     associate (sel => iptr(itarget))
       ip => sel

flang/test/Semantics/c_f_pointer.f90

program test
   call c_f_pointer(arrayC, scalarIntF)
   !ERROR: SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array
   call c_f_pointer(scalarC, arrayIntF)
   !ERROR: SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar
   call c_f_pointer(scalarC, scalarIntF, [1_8])
   !ERROR: FPTR= argument to C_F_POINTER() may not have a deferred type parameter
   call c_f_pointer(scalarC, charDeferredF)
   !ERROR: FPTR= argument to C_F_POINTER() may not be a coindexed object
+  !ERROR: A coindexed object may not be a pointer target
   call c_f_pointer(scalarC, coindexed[0]%p)
   !ERROR: FPTR= argument to C_F_POINTER() must have a type
   call c_f_pointer(scalarC, null())
   !ERROR: SHAPE= argument to C_F_POINTER() must have size equal to the rank of FPTR=
   call c_f_pointer(scalarC, multiDimIntF, shape=[1_8])
   !ERROR: SHAPE= argument to C_F_POINTER() must be a rank-one array.
   call c_f_pointer(scalarC, multiDimIntF, shape=rankTwoArray)
 end program

flang/test/Semantics/call05.f90

subroutine test
     call spp(mp)
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so
     call spa(ma)
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
     call sup(pp)
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
     call sua(pa)
     !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 'CLASS(t)'
+    !ERROR: Pointer type must be unlimited polymorphic or non-extensible derived type when target is unlimited polymorphic
     call spp(up)
     !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 'CLASS(t)'
     call spa(ua)
     !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
     call spp(pp2)
     !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
     call spa(pa2)
     !ERROR: Rank of dummy argument is 1, but actual argument has rank 2
+    !ERROR: Pointer has rank 1 but target has rank 2
     call smp(mpmat)
     !ERROR: Rank of dummy argument is 1, but actual argument has rank 2
     call sma(mamat)
     call sdmp(dmp) ! ok
     call sdma(dma) ! ok
     call snmp(nmp) ! ok
     call snma(nma) ! ok
     call samp(nmp) ! ok

flang/test/Semantics/call07.f90

contains
 
   subroutine test
     !ERROR: CONTIGUOUS POINTER must be an array
     real, pointer, contiguous :: a01 ! C830
     real, pointer :: a02(:)
     real, target :: a03(10)
     real :: a04(10) ! not TARGET
     call s01(a03) ! ok
-    !ERROR: Actual argument associated with CONTIGUOUS POINTER dummy argument 'p=' must be simply contiguous
+    !WARNING: Target of CONTIGUOUS pointer association is not known to be contiguous
     call s01(a02)
-    !ERROR: Actual argument associated with CONTIGUOUS POINTER dummy argument 'p=' must be simply contiguous
+    !ERROR: CONTIGUOUS pointer may not be associated with a discontiguous target
     call s01(a03(::2))
     call s02(a02) ! ok
     call s03(a03) ! ok
     !ERROR: Actual argument associated with POINTER dummy argument 'p=' must also be POINTER unless INTENT(IN)
     call s02(a03)
     !ERROR: Actual argument associated with POINTER dummy argument 'p=' must also be POINTER unless INTENT(IN)
     call s04(a02(1))
     !ERROR: An array section with a vector subscript may not be a pointer target

flang/test/Semantics/call33.f90

program test
   call s2(shortarr)
   !ERROR: Actual argument variable length '2' does not match the expected length '3'
   call s3(shortarr)
   !ERROR: Actual argument variable length '2' does not match the expected length '3'
   call s4(shortarr)
   !ERROR: Actual argument variable length '2' does not match the expected length '3'
   call s5(shortalloc)
   !ERROR: Actual argument variable length '2' does not match the expected length '3'
+  !ERROR: Target type CHARACTER(KIND=1,LEN=2_8) is not compatible with pointer type CHARACTER(KIND=1,LEN=3_8)
   call s6(shortptr)
   call s1(long) ! ok
   call s2(longarr) ! ok
   !ERROR: Actual argument variable length '4' does not match the expected length '3'
   call s3(longarr)
   !ERROR: Actual argument variable length '4' does not match the expected length '3'
   call s4(longarr)
   !ERROR: Actual argument variable length '4' does not match the expected length '3'
   call s5(longalloc)
   !ERROR: Actual argument variable length '4' does not match the expected length '3'
+  !ERROR: Target type CHARACTER(KIND=1,LEN=4_8) is not compatible with pointer type CHARACTER(KIND=1,LEN=3_8)
   call s6(longptr)
 end

flang/test/Semantics/structconst03.f90

type :: t3(k)
     type(has_pointer2) :: hp2
     type(t3(k)), allocatable :: link
   end type t3
   type :: t4(k)
     integer, kind :: k
     type(has_pointer3) :: hp3
     type(t4(k)), allocatable :: link
   end type t4
-  real, target :: modulevar1
-  type(has_pointer1) :: modulevar2
-  type(has_pointer2) :: modulevar3
-  type(has_pointer3) :: modulevar4
+  real, target :: modulevar1 = 0.
+  type(has_pointer1) :: modulevar2 = has_pointer1(modulevar1)
+  type(has_pointer2) :: modulevar3 = has_pointer2(has_pointer1(modulevar1))
+  type(has_pointer3) :: modulevar4 = has_pointer3(has_pointer1(modulevar1))
 
  contains
 
   pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     real, target :: local1
     type(t1(0)) :: x1
     type(t2(0)) :: x2
     type(t3(0)) :: x3
pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     !ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(0)(dummy1)
     x1 = t1(0)(dummy2)
     x1 = t1(0)(dummy3)
 ! TODO when semantics handles coindexing:
 ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
 ! TODO x1 = t1(0)(dummy4[0])
     x1 = t1(0)(dummy4)
-    !ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
+    !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+    x2 = t2(0)(has_pointer1(modulevar1))
+    !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+    x3 = t3(0)(has_pointer2(has_pointer1(modulevar1)))
+    !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+    x4 = t4(0)(has_pointer3(has_pointer1(modulevar1)))
+    !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
     x2 = t2(0)(modulevar2)
-    !ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
+    !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
     x3 = t3(0)(modulevar3)
-    !ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
+    !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
     x4 = t4(0)(modulevar4)
    contains
     pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       real, target :: local1a
       type(t1(0)) :: x1a
       type(t2(0)) :: x2a
       type(t3(0)) :: x3a
       type(t4(0)) :: x4a
pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       x1a = t1(0)(dummy1a)
       x1a = t1(0)(dummy2a)
       x1a = t1(0)(dummy3)
       x1a = t1(0)(dummy3a)
 ! TODO when semantics handles coindexing:
 ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
 ! TODO x1a = t1(0)(dummy4a[0])
       x1a = t1(0)(dummy4a)
-      !ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
+      !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+      x2a = t2(0)(has_pointer1(modulevar1))
+      !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+      x3a = t3(0)(has_pointer2(has_pointer1(modulevar1)))
+      !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+      x4a = t4(0)(has_pointer3(has_pointer1(modulevar1)))
+      !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
       x2a = t2(0)(modulevar2)
-      !ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
+      !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
       x3a = t3(0)(modulevar3)
-      !ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
+      !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
       x4a = t4(0)(modulevar4)
     end subroutine subr
   end subroutine
 
   pure integer function pf1(dummy3)
     real, pointer :: dummy3
     type(t1(0)) :: x1
     pf1 = 0
impure real function ipf1(dummy1, dummy2, dummy3, dummy4)
     real, intent(inout), target :: dummy4[*]
     real, target :: commonvar1
     common /cblock/ commonvar1
     ipf1 = 0.
     x1 = t1(0)(local1)
     x1 = t1(0)(usedfrom1)
     x1 = t1(0)(modulevar1)
     x1 = t1(0)(commonvar1)
+    !WARNING: Pointer target is not a definable variable
+    !BECAUSE: 'dummy1' is an INTENT(IN) dummy argument
     x1 = t1(0)(dummy1)
     x1 = t1(0)(dummy2)
     x1 = t1(0)(dummy3)
 ! TODO when semantics handles coindexing:
 ! TODO x1 = t1(0)(dummy4[0])
     x1 = t1(0)(dummy4)
+    x2 = t2(0)(has_pointer1(modulevar1))
+    x3 = t3(0)(has_pointer2(has_pointer1(modulevar1)))
+    x4 = t4(0)(has_pointer3(has_pointer1(modulevar1)))
     x2 = t2(0)(modulevar2)
     x3 = t3(0)(modulevar3)
     x4 = t4(0)(modulevar4)
   end function ipf1
 end module module1

flang/test/Semantics/structconst04.f90

module module1
   type :: t3
     type(has_pointer2) :: hp2
     type(t3), allocatable :: link
   end type t3
   type :: t4
     type(has_pointer3) :: hp3
     type(t4), allocatable :: link
   end type t4
-  real, target :: modulevar1
-  type(has_pointer1) :: modulevar2
-  type(has_pointer2) :: modulevar3
-  type(has_pointer3) :: modulevar4
+  real, target :: modulevar1 = 0.
+  type(has_pointer1) :: modulevar2 = has_pointer1(modulevar1)
+  type(has_pointer2) :: modulevar3 = has_pointer2(has_pointer1(modulevar1))
+  type(has_pointer3) :: modulevar4 = has_pointer3(has_pointer1(modulevar1))
 
  contains
 
   pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     real, target :: local1
     type(t1) :: x1
     type(t2) :: x2
     type(t3) :: x3
pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     !ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(dummy1)
     x1 = t1(dummy2)
     x1 = t1(dummy3)
 ! TODO when semantics handles coindexing:
 ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
 ! TODO x1 = t1(dummy4[0])
     x1 = t1(dummy4)
-    !ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
+    !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+    x2 = t2(has_pointer1(modulevar1))
+    !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+    x3 = t3(has_pointer2(has_pointer1(modulevar1)))
+    !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+    x4 = t4(has_pointer3(has_pointer1(modulevar1)))
+    !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
     x2 = t2(modulevar2)
-    !ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
+    !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
     x3 = t3(modulevar3)
-    !ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
+    !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
     x4 = t4(modulevar4)
    contains
     pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       real, target :: local1a
       type(t1) :: x1a
       type(t2) :: x2a
       type(t3) :: x3a
       type(t4) :: x4a
pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       x1a = t1(dummy1a)
       x1a = t1(dummy2a)
       x1a = t1(dummy3)
       x1a = t1(dummy3a)
 ! TODO when semantics handles coindexing:
 ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
 ! TODO x1a = t1(dummy4a[0])
       x1a = t1(dummy4a)
-      !ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
+      !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+      x2a = t2(has_pointer1(modulevar1))
+      !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+      x3a = t3(has_pointer2(has_pointer1(modulevar1)))
+      !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
+      x4a = t4(has_pointer3(has_pointer1(modulevar1)))
+      !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
       x2a = t2(modulevar2)
-      !ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
+      !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
       x3a = t3(modulevar3)
-      !ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
+      !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
       x4a = t4(modulevar4)
     end subroutine subr
   end subroutine
 
   pure integer function pf1(dummy3)
     real, pointer :: dummy3
     type(t1) :: x1
     !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
impure real function ipf1(dummy1, dummy2, dummy3, dummy4)
     real, intent(inout), target :: dummy4[*]
     real, target :: commonvar1
     common /cblock/ commonvar1
     ipf1 = 0.
     x1 = t1(local1)
     x1 = t1(usedfrom1)
     x1 = t1(modulevar1)
     x1 = t1(commonvar1)
+    !WARNING: Pointer target is not a definable variable
+    !BECAUSE: 'dummy1' is an INTENT(IN) dummy argument
     x1 = t1(dummy1)
     x1 = t1(dummy2)
     x1 = t1(dummy3)
 ! TODO when semantics handles coindexing:
 ! TODO x1 = t1(dummy4[0])
     x1 = t1(dummy4)
+    x2 = t2(has_pointer1(modulevar1))
+    x3 = t3(has_pointer2(has_pointer1(modulevar1)))
+    x4 = t4(has_pointer3(has_pointer1(modulevar1)))
     x2 = t2(modulevar2)
     x3 = t3(modulevar3)
     x4 = t4(modulevar4)
   end function ipf1
 end module module1

flang/test/Semantics/structconst07.f90#

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! C1594(4)
+module m
+  type t1
+