[flang] Consolidate and enhance pointer assignment checks

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.

Differential Revision: https://reviews.llvm.org/D146581

Author: klausler

flang/lib/Semantics/assignment.cpp

@@ -44,8 +44,7 @@ class AssignmentContext {
   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) {
@@ -75,8 +74,11 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
       }
     }
     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);
     }
@@ -86,14 +88,10 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
 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));
   }
 }
 
@@ -128,29 +126,16 @@ bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
   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;
-  }
-  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) {
+  if (FindPureProcedureContaining(scope)) {
+    parser::ContextualMessages messages{
+        context_.location().value(), &context_.messages()};
     return CheckCopyabilityInPureScope(messages, rhs, scope);
+  } else {
+    return true;
   }
-  return true;
 }
 
 // 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape

flang/lib/Semantics/check-call.cpp

@@ -494,23 +494,16 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
 
   // 15.5.2.7 -- dummy is POINTER
   if (dummyIsPointer) {
-    if (dummyIsContiguous && !actualIsContiguous) {
+    if (actualIsPointer || dummy.intent == common::Intent::In) {
+      if (scope) {
+        semantics::CheckPointerAssignment(
+            context, messages.at(), dummyName, dummy, actual, *scope);
+      }
+    } else if (!actualIsPointer) {
       messages.Say(
-          "Actual argument associated with CONTIGUOUS POINTER %s must be simply contiguous"_err_en_US,
+          "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_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);
-      }
-    }
   }
 
   // 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE

flang/lib/Semantics/expression.cpp

@@ -1814,6 +1814,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(
   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())};
 
@@ -1939,41 +1941,18 @@ MaybeExpr ExpressionAnalyzer::Analyze(
       }
       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>()) {
+        if (symbol->has<semantics::TypeParamDetails>()) {
           Say(expr.source,
-              "Type parameter '%s' may not appear as a component "
-              "of a structure constructor"_err_en_US,
+              "Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US,
               symbol->name());
-          continue;
-        } else {
-          Say(expr.source,
-              "Component '%s' is neither a procedure pointer "
-              "nor a data object"_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;
         }
@@ -2008,6 +1987,15 @@ MaybeExpr ExpressionAnalyzer::Analyze(
                 *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)}) {

flang/lib/Semantics/pointer-assignment.cpp

@@ -57,6 +57,7 @@ class PointerAssignmentChecker {
   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 &);
 
@@ -87,6 +88,7 @@ class PointerAssignmentChecker {
   bool isContiguous_{false};
   bool isVolatile_{false};
   bool isBoundsRemapping_{false};
+  const Symbol *pointerComponentLHS_{nullptr};
 };
 
 PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType(
@@ -113,6 +115,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
   return *this;
 }
 
+PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS(
+    const Symbol *symbol) {
+  pointerComponentLHS_ = symbol;
+  return *this;
+}
+
 bool PointerAssignmentChecker::CharacterizeProcedure() {
   if (!characterizedProcedure_) {
     characterizedProcedure_ = true;
@@ -126,7 +134,7 @@ bool PointerAssignmentChecker::CharacterizeProcedure() {
 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));
     }
@@ -153,12 +161,62 @@ 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;
-  } else {
-    return common::visit([&](const auto &x) { return Check(x); }, rhs.u);
   }
+  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 {
+      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 &) {
@@ -221,7 +279,7 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
   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;
@@ -440,8 +498,9 @@ bool CheckPointerAssignment(evaluate::FoldingContext &context,
 
 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,

flang/test/Semantics/assign14.f90

@@ -0,0 +1,7 @@
+! 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

@@ -13,6 +13,8 @@ module m1
   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

flang/test/Semantics/c_f_pointer.f90

@@ -30,6 +30,7 @@ program test
   !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())

flang/test/Semantics/call05.f90

@@ -86,6 +86,7 @@ subroutine test
     !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)
@@ -94,6 +95,7 @@ subroutine test
     !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)

flang/test/Semantics/call07.f90

@@ -25,9 +25,9 @@ subroutine test
     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

flang/test/Semantics/call33.f90

@@ -40,6 +40,7 @@ program test
   !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
@@ -50,5 +51,6 @@ program test
   !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