[flang] Move pointer assignment checking to its own file
authorTim Keith <tkeith@nvidia.com>
Mon, 6 Jan 2020 17:16:18 +0000 (09:16 -0800)
committerTim Keith <tkeith@nvidia.com>
Tue, 14 Jan 2020 21:02:56 +0000 (13:02 -0800)
Create `pointer-assignment.{h,cc}` for pointer assignment checking.
It doesn't share with assignment checking so it should be its own file.
Move the code into semantics namespace.

Original-commit: flang-compiler/f18@1658aba81f24fe3913298e76ae8b9c938bd4d248
Reviewed-on: https://github.com/flang-compiler/f18/pull/928
Tree-same-pre-rewrite: false

flang/lib/semantics/CMakeLists.txt
flang/lib/semantics/assignment.cc
flang/lib/semantics/assignment.h
flang/lib/semantics/check-call.cc
flang/lib/semantics/expression.cc
flang/lib/semantics/pointer-assignment.cc [new file with mode: 0644]
flang/lib/semantics/pointer-assignment.h [new file with mode: 0644]

index aaea1f3..1f0fa35 100644 (file)
@@ -27,6 +27,7 @@ add_library(FortranSemantics
   check-stop.cc
   expression.cc
   mod-file.cc
+  pointer-assignment.cc
   program-tree.cc
   resolve-labels.cc
   resolve-names.cc
index a829cbc..4263f59 100644 (file)
@@ -8,11 +8,11 @@
 
 #include "assignment.h"
 #include "expression.h"
+#include "pointer-assignment.h"
 #include "symbol.h"
 #include "tools.h"
 #include "../common/idioms.h"
 #include "../common/restorer.h"
-#include "../evaluate/characteristics.h"
 #include "../evaluate/expression.h"
 #include "../evaluate/fold.h"
 #include "../evaluate/tools.h"
 
 using namespace Fortran::parser::literals;
 
-namespace Fortran::evaluate {
-
-class PointerAssignmentChecker {
-public:
-  PointerAssignmentChecker(const Symbol *pointer, parser::CharBlock source,
-      const std::string &description, const characteristics::TypeAndShape *type,
-      FoldingContext &context, const characteristics::Procedure *procedure,
-      bool isContiguous)
-    : pointer_{pointer}, source_{source},
-      description_{description}, type_{type}, context_{context},
-      procedure_{procedure}, isContiguous_{isContiguous} {}
-
-  template<typename A> void Check(const A &) {
-    // Catch-all case for really bad target expression
-    Say("Target associated with %s must be a designator or a call to a pointer-valued function"_err_en_US,
-        description_);
-  }
-
-  template<typename T> void Check(const Expr<T> &x) {
-    std::visit([&](const auto &x) { Check(x); }, x.u);
-  }
-  void Check(const Expr<SomeType> &);
-  void Check(const NullPointer &) {}  // P => NULL() without MOLD=; always OK
-
-  template<typename T> void Check(const FunctionRef<T> &f) {
-    std::string funcName;
-    const auto *symbol{f.proc().GetSymbol()};
-    if (symbol) {
-      funcName = symbol->name().ToString();
-    } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
-      funcName = intrinsic->name;
-    }
-    if (auto proc{characteristics::Procedure::Characterize(
-            f.proc(), context_.intrinsics())}) {
-      std::optional<parser::MessageFixedText> error;
-      if (const auto &funcResult{proc->functionResult}) {  // C1025
-        const auto *frProc{funcResult->IsProcedurePointer()};
-        if (procedure_) {
-          // Shouldn't be here in this function unless lhs
-          // is an object pointer.
-          error =
-              "Procedure %s is associated with the result of a reference to function '%s' that does not return a procedure pointer"_err_en_US;
-        } else if (frProc) {
-          error =
-              "Object %s is associated with the result of a reference to function '%s' that is a procedure pointer"_err_en_US;
-        } else if (!funcResult->attrs.test(
-                       characteristics::FunctionResult::Attr::Pointer)) {
-          error =
-              "%s is associated with the result of a reference to function '%s' that is a not a pointer"_err_en_US;
-        } else if (isContiguous_ &&
-            !funcResult->attrs.test(
-                characteristics::FunctionResult::Attr::Contiguous)) {
-          error =
-              "CONTIGUOUS %s is associated with the result of reference to function '%s' that is not contiguous"_err_en_US;
-        } else if (type_) {
-          const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
-          CHECK(frTypeAndShape);
-          if (!type_->IsCompatibleWith(context_.messages(), *frTypeAndShape)) {
-            error =
-                "%s is associated with the result of a reference to function '%s' whose pointer result has an incompatible type or shape"_err_en_US;
-          }
-        }
-      } else {
-        error =
-            "%s is associated with the non-existent result of reference to procedure"_err_en_US;
-      }
-      if (error) {
-        auto restorer{common::ScopedSet(pointer_, symbol)};
-        Say(*error, description_, funcName);
-      }
-    }
-  }
-
-  template<typename T> void Check(const Designator<T> &d) {
-    const Symbol *last{d.GetLastSymbol()};
-    const Symbol *base{d.GetBaseObject().symbol()};
-    if (last && base) {
-      std::optional<parser::MessageFixedText> error;
-      if (procedure_) {
-        // Shouldn't be here in this function unless lhs is an
-        // object pointer.
-        error =
-            "In assignment to procedure %s, the target is not a procedure or procedure pointer"_err_en_US;
-      } else if (!GetLastTarget(GetSymbolVector(d))) {  // C1025
-        error =
-            "In assignment to object %s, the target '%s' is not an object with POINTER or TARGET attributes"_err_en_US;
-      } else if (auto rhsTypeAndShape{
-                     characteristics::TypeAndShape::Characterize(
-                         *last, context_)}) {
-        if (!type_ ||
-            !type_->IsCompatibleWith(context_.messages(), *rhsTypeAndShape)) {
-          error =
-              "%s associated with object '%s' with incompatible type or shape"_err_en_US;
-        }
-      }
-      if (error) {
-        auto restorer{common::ScopedSet(pointer_, last)};
-        Say(*error, description_, last->name());
-      }
-    } else {
-      // P => "character literal"(1:3)
-      context_.messages().Say("Pointer target is not a named entity"_err_en_US);
-    }
-  }
-
-  void Check(const ProcedureDesignator &);
-  void Check(const ProcedureRef &);
-
-private:
-  // Target is a procedure
-  void Check(parser::CharBlock rhsName, bool isCall,
-      const characteristics::Procedure * = nullptr);
-
-  template<typename... A> parser::Message *Say(A &&... x) {
-    auto *msg{context_.messages().Say(std::forward<A>(x)...)};
-    if (pointer_) {
-      return AttachDeclaration(msg, *pointer_);
-    } else if (!source_.empty()) {
-      msg->Attach(source_, "Declaration of %s"_en_US, description_);
-    }
-    return msg;
-  }
-
-  const Symbol *pointer_{nullptr};
-  const parser::CharBlock source_;
-  const std::string &description_;
-  const characteristics::TypeAndShape *type_{nullptr};
-  FoldingContext &context_;
-  const characteristics::Procedure *procedure_{nullptr};
-  bool isContiguous_{false};
-};
-
-void PointerAssignmentChecker::Check(const Expr<SomeType> &rhs) {
-  if (HasVectorSubscript(rhs)) {  // C1025
-    Say("An array section with a vector subscript may not be a pointer target"_err_en_US);
-  } else if (ExtractCoarrayRef(rhs)) {  // C1026
-    Say("A coindexed object may not be a pointer target"_err_en_US);
-  } else {
-    std::visit([&](const auto &x) { Check(x); }, rhs.u);
-  }
-}
-
-// Common handling for procedure pointer right-hand sides
-void PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
-    const characteristics::Procedure *targetChars) {
-  if (procedure_) {
-    if (targetChars) {
-      if (*procedure_ != *targetChars) {
-        if (isCall) {
-          Say("Procedure %s associated with result of reference to function '%s' that is an incompatible procedure pointer"_err_en_US,
-              description_, rhsName);
-        } else {
-          Say("Procedure %s associated with incompatible procedure designator '%s'"_err_en_US,
-              description_, rhsName);
-        }
-      }
-    } else {
-      Say("In assignment to procedure %s, the characteristics of the target procedure '%s' could not be determined"_err_en_US,
-          description_, rhsName);
-    }
-  } else {
-    Say("In assignment to object %s, the target '%s' is a procedure designator"_err_en_US,
-        description_, rhsName);
-  }
-}
-
-void PointerAssignmentChecker::Check(const ProcedureDesignator &d) {
-  if (auto chars{
-          characteristics::Procedure::Characterize(d, context_.intrinsics())}) {
-    Check(d.GetName(), false, &*chars);
-  } else {
-    Check(d.GetName(), false);
-  }
-}
-
-void PointerAssignmentChecker::Check(const ProcedureRef &ref) {
-  const characteristics::Procedure *procedure{nullptr};
-  auto chars{
-      characteristics::Procedure::Characterize(ref, context_.intrinsics())};
-  if (chars) {
-    procedure = &*chars;
-    if (chars->functionResult) {
-      if (const auto *proc{chars->functionResult->IsProcedurePointer()}) {
-        procedure = proc;
-      }
-    }
-  }
-  Check(ref.proc().GetName(), true, procedure);
-}
-
-void CheckPointerAssignment(
-    FoldingContext &context, const Symbol &lhs, const Expr<SomeType> &rhs) {
-  // TODO: Acquire values of deferred type parameters &/or array bounds
-  // from the RHS.
-  if (!IsPointer(lhs)) {
-    SayWithDeclaration(
-        context.messages(), lhs, "'%s' is not a pointer"_err_en_US, lhs.name());
-  } else {
-    auto type{characteristics::TypeAndShape::Characterize(lhs, context)};
-    auto proc{
-        characteristics::Procedure::Characterize(lhs, context.intrinsics())};
-    std::string description{"pointer '"s + lhs.name().ToString() + '\''};
-    PointerAssignmentChecker{&lhs, lhs.name(), description,
-        type ? &*type : nullptr, context, proc ? &*proc : nullptr,
-        lhs.attrs().test(semantics::Attr::CONTIGUOUS)}
-        .Check(rhs);
-  }
-}
-
-void CheckPointerAssignment(FoldingContext &context, parser::CharBlock source,
-    const std::string &description, const characteristics::DummyDataObject &lhs,
-    const Expr<SomeType> &rhs) {
-  PointerAssignmentChecker{nullptr, source, description, &lhs.type, context,
-      nullptr /* proc */,
-      lhs.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}
-      .Check(rhs);
-}
-
-}
-
 namespace Fortran::semantics {
 
 using ControlExpr = evaluate::Expr<evaluate::SubscriptInteger>;
index bc8a16a..d963b6a 100644 (file)
@@ -10,6 +10,7 @@
 #define FORTRAN_SEMANTICS_ASSIGNMENT_H_
 
 #include "semantics.h"
+#include "tools.h"
 #include "../common/indirection.h"
 #include "../evaluate/expression.h"
 #include <string>
@@ -23,31 +24,13 @@ struct PointerAssignmentStmt;
 struct Program;
 struct WhereStmt;
 struct WhereConstruct;
-struct ForallStmt;
 struct ForallConstruct;
 }
 
-namespace Fortran::evaluate::characteristics {
-struct DummyDataObject;
-}
-
-namespace Fortran::evaluate {
-class FoldingContext;
-void CheckPointerAssignment(
-    FoldingContext &, const Symbol &lhs, const Expr<SomeType> &rhs);
-void CheckPointerAssignment(FoldingContext &, parser::CharBlock source,
-    const std::string &description, const characteristics::DummyDataObject &,
-    const Expr<SomeType> &rhs);
-}
-
 namespace Fortran::semantics {
-class AssignmentContext;
-}
 
-extern template class Fortran::common::Indirection<
-    Fortran::semantics::AssignmentContext>;
+class AssignmentContext;
 
-namespace Fortran::semantics {
 // Applies checks from C1594(1-2) on definitions in pure subprograms
 void CheckDefinabilityInPureScope(parser::ContextualMessages &, const Symbol &,
     const Scope &context, const Scope &pure);
@@ -70,19 +53,13 @@ private:
   common::Indirection<AssignmentContext> context_;
 };
 
-// Semantic analysis of an assignment statement or WHERE/FORALL construct.
-void AnalyzeAssignment(
-    SemanticsContext &, const parser::Statement<parser::AssignmentStmt> &);
-void AnalyzeAssignment(SemanticsContext &,
-    const parser::Statement<parser::PointerAssignmentStmt> &);
-void AnalyzeAssignment(
-    SemanticsContext &, const parser::Statement<parser::WhereStmt> &);
-void AnalyzeAssignment(
-    SemanticsContext &, const parser::Statement<parser::ForallStmt> &);
-
 // R1125 concurrent-header is used in FORALL statements & constructs as
 // well as in DO CONCURRENT loops.
 void AnalyzeConcurrentHeader(
     SemanticsContext &, const parser::ConcurrentHeader &);
+
 }
+
+extern template class Fortran::common::Indirection<
+    Fortran::semantics::AssignmentContext>;
 #endif  // FORTRAN_SEMANTICS_ASSIGNMENT_H_
index 856b476..1888249 100644 (file)
@@ -7,7 +7,7 @@
 //===----------------------------------------------------------------------===//
 
 #include "check-call.h"
-#include "assignment.h"
+#include "pointer-assignment.h"
 #include "scope.h"
 #include "tools.h"
 #include "../evaluate/characteristics.h"
@@ -405,7 +405,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     }
     if (!actualIsPointer) {
       if (dummy.intent == common::Intent::In) {
-        CheckPointerAssignment(
+        semantics::CheckPointerAssignment(
             context, parser::CharBlock{}, dummyName, dummy, actual);
       } else {
         messages.Say(
index fa5d531..373f0f3 100644 (file)
@@ -7,8 +7,8 @@
 //===----------------------------------------------------------------------===//
 
 #include "expression.h"
-#include "assignment.h"
 #include "check-call.h"
+#include "pointer-assignment.h"
 #include "scope.h"
 #include "semantics.h"
 #include "symbol.h"
@@ -1462,7 +1462,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(
           continue;
         }
         if (IsPointer(*symbol)) {
-          CheckPointerAssignment(
+          semantics::CheckPointerAssignment(
               GetFoldingContext(), *symbol, *value);  // C7104, C7105
           result.Add(*symbol, Fold(std::move(*value)));
         } else if (MaybeExpr converted{
diff --git a/flang/lib/semantics/pointer-assignment.cc b/flang/lib/semantics/pointer-assignment.cc
new file mode 100644 (file)
index 0000000..06ebc50
--- /dev/null
@@ -0,0 +1,279 @@
+//===-- lib/semantics/pointer-assignment.cc -------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "pointer-assignment.h"
+#include "expression.h"
+#include "symbol.h"
+#include "tools.h"
+#include "../common/idioms.h"
+#include "../common/restorer.h"
+#include "../evaluate/characteristics.h"
+#include "../evaluate/expression.h"
+#include "../evaluate/fold.h"
+#include "../evaluate/tools.h"
+#include "../parser/message.h"
+#include "../parser/parse-tree-visitor.h"
+#include "../parser/parse-tree.h"
+#include <optional>
+#include <set>
+#include <string>
+#include <type_traits>
+
+// Semantic checks for pointer assignment.
+
+namespace Fortran::semantics {
+
+using namespace parser::literals;
+using evaluate::characteristics::DummyDataObject;
+using evaluate::characteristics::FunctionResult;
+using evaluate::characteristics::Procedure;
+using evaluate::characteristics::TypeAndShape;
+
+class PointerAssignmentChecker {
+public:
+  PointerAssignmentChecker(parser::CharBlock source,
+      const std::string &description, evaluate::FoldingContext &context)
+    : source_{source}, description_{description}, context_{context} {}
+  PointerAssignmentChecker &set_lhs(const Symbol &);
+  PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
+  PointerAssignmentChecker &set_procedure(std::optional<Procedure> &&);
+  PointerAssignmentChecker &set_isContiguous(bool);
+  void Check(const SomeExpr &);
+
+private:
+  template<typename A> void Check(const A &);
+  template<typename T> void Check(const evaluate::Expr<T> &);
+  template<typename T> void Check(const evaluate::FunctionRef<T> &);
+  template<typename T> void Check(const evaluate::Designator<T> &);
+  void Check(const evaluate::NullPointer &);
+  void Check(const evaluate::ProcedureDesignator &);
+  void Check(const evaluate::ProcedureRef &);
+  // Target is a procedure
+  void Check(
+      parser::CharBlock rhsName, bool isCall, const Procedure * = nullptr);
+
+  template<typename... A> parser::Message *Say(A &&...);
+
+  const parser::CharBlock source_;
+  const std::string &description_;
+  evaluate::FoldingContext &context_;
+  const Symbol *lhs_{nullptr};
+  std::optional<TypeAndShape> lhsType_;
+  std::optional<Procedure> procedure_;
+  bool isContiguous_{false};
+};
+
+PointerAssignmentChecker &PointerAssignmentChecker::set_lhs(const Symbol &lhs) {
+  lhs_ = &lhs;
+  return *this;
+}
+
+PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType(
+    std::optional<TypeAndShape> &&lhsType) {
+  lhsType_ = std::move(lhsType);
+  return *this;
+}
+
+PointerAssignmentChecker &PointerAssignmentChecker::set_procedure(
+    std::optional<Procedure> &&procedure) {
+  procedure_ = std::move(procedure);
+  return *this;
+}
+
+PointerAssignmentChecker &PointerAssignmentChecker::set_isContiguous(
+    bool isContiguous) {
+  isContiguous_ = isContiguous;
+  return *this;
+}
+
+template<typename A> void PointerAssignmentChecker::Check(const A &) {
+  // Catch-all case for really bad target expression
+  Say("Target associated with %s must be a designator or a call to a"
+      " pointer-valued function"_err_en_US,
+      description_);
+}
+
+template<typename T>
+void PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
+  std::visit([&](const auto &x) { Check(x); }, x.u);
+}
+
+void 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);
+  } else if (ExtractCoarrayRef(rhs)) {  // C1026
+    Say("A coindexed object may not be a pointer target"_err_en_US);
+  } else {
+    std::visit([&](const auto &x) { Check(x); }, rhs.u);
+  }
+}
+
+void PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
+  // P => NULL() without MOLD=; always OK
+}
+
+template<typename T>
+void PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
+  std::string funcName;
+  const auto *symbol{f.proc().GetSymbol()};
+  if (symbol) {
+    funcName = symbol->name().ToString();
+  } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
+    funcName = intrinsic->name;
+  }
+  auto proc{Procedure::Characterize(f.proc(), context_.intrinsics())};
+  if (!proc) {
+    return;
+  }
+  std::optional<parser::MessageFixedText> msg;
+  const auto &funcResult{proc->functionResult};  // C1025
+  if (!funcResult) {
+    msg = "%s is associated with the non-existent result of reference to"
+          " procedure"_err_en_US;
+  } else if (procedure_) {
+    // Shouldn't be here in this function unless lhs is an object pointer.
+    msg = "Procedure %s is associated with the result of a reference to"
+          " function '%s' that does not return a procedure pointer"_err_en_US;
+  } else if (funcResult->IsProcedurePointer()) {
+    msg = "Object %s is associated with the result of a reference to"
+          " function '%s' that is a procedure pointer"_err_en_US;
+  } else if (!funcResult->attrs.test(FunctionResult::Attr::Pointer)) {
+    msg = "%s is associated with the result of a reference to function '%s'"
+          " that is a not a pointer"_err_en_US;
+  } else if (isContiguous_ &&
+      !funcResult->attrs.test(FunctionResult::Attr::Contiguous)) {
+    msg = "CONTIGUOUS %s is associated with the result of reference to"
+          " function '%s' that is not contiguous"_err_en_US;
+  } else if (lhsType_) {
+    const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
+    CHECK(frTypeAndShape);
+    if (!lhsType_->IsCompatibleWith(context_.messages(), *frTypeAndShape)) {
+      msg = "%s is associated with the result of a reference to function '%s'"
+            " whose pointer result has an incompatible type or shape"_err_en_US;
+    }
+  }
+  if (msg) {
+    auto restorer{common::ScopedSet(lhs_, symbol)};
+    Say(*msg, description_, funcName);
+  }
+}
+
+template<typename T>
+void 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);
+    return;
+  }
+  std::optional<parser::MessageFixedText> msg;
+  if (procedure_) {
+    // 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
+    msg = "In assignment to object %s, the target '%s' is not an object with"
+          " POINTER or TARGET attributes"_err_en_US;
+  } else if (auto rhsTypeAndShape{
+                 TypeAndShape::Characterize(*last, context_)}) {
+    if (!lhsType_ ||
+        !lhsType_->IsCompatibleWith(context_.messages(), *rhsTypeAndShape)) {
+      msg = "%s associated with object '%s' with incompatible type or"
+            " shape"_err_en_US;
+    }
+  }
+  if (msg) {
+    auto restorer{common::ScopedSet(lhs_, last)};
+    Say(*msg, description_, last->name());
+  }
+}
+
+// Common handling for procedure pointer right-hand sides
+void PointerAssignmentChecker::Check(
+    parser::CharBlock rhsName, bool isCall, const Procedure *targetChars) {
+  if (!procedure_) {
+    Say("In assignment to object %s, the target '%s' is a procedure designator"_err_en_US,
+        description_, rhsName);
+  } else if (!targetChars) {
+    Say("In assignment to procedure %s, the characteristics of the target"
+        " procedure '%s' could not be determined"_err_en_US,
+        description_, rhsName);
+  } else if (*procedure_ == *targetChars) {
+    // OK
+  } else if (isCall) {
+    Say("Procedure %s associated with result of reference to function '%s' that"
+        " is an incompatible procedure pointer"_err_en_US,
+        description_, rhsName);
+  } else {
+    Say("Procedure %s associated with incompatible procedure designator '%s'"_err_en_US,
+        description_, rhsName);
+  }
+}
+
+void PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
+  if (auto chars{Procedure::Characterize(d, context_.intrinsics())}) {
+    Check(d.GetName(), false, &*chars);
+  } else {
+    Check(d.GetName(), false);
+  }
+}
+
+void PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
+  const Procedure *procedure{nullptr};
+  auto chars{Procedure::Characterize(ref, context_.intrinsics())};
+  if (chars) {
+    procedure = &*chars;
+    if (chars->functionResult) {
+      if (const auto *proc{chars->functionResult->IsProcedurePointer()}) {
+        procedure = proc;
+      }
+    }
+  }
+  Check(ref.proc().GetName(), true, procedure);
+}
+
+template<typename... A>
+parser::Message *PointerAssignmentChecker::Say(A &&... x) {
+  auto *msg{context_.messages().Say(std::forward<A>(x)...)};
+  if (lhs_) {
+    return evaluate::AttachDeclaration(msg, *lhs_);
+  } else if (!source_.empty()) {
+    msg->Attach(source_, "Declaration of %s"_en_US, description_);
+  }
+  return msg;
+}
+
+void CheckPointerAssignment(
+    evaluate::FoldingContext &context, const Symbol &lhs, const SomeExpr &rhs) {
+  // TODO: Acquire values of deferred type parameters &/or array bounds
+  // from the RHS.
+  if (!IsPointer(lhs)) {
+    evaluate::SayWithDeclaration(
+        context.messages(), lhs, "'%s' is not a pointer"_err_en_US, lhs.name());
+  } else {
+    std::string description{"pointer '"s + lhs.name().ToString() + '\''};
+    PointerAssignmentChecker{lhs.name(), description, context}
+        .set_lhsType(TypeAndShape::Characterize(lhs, context))
+        .set_procedure(Procedure::Characterize(lhs, context.intrinsics()))
+        .set_lhs(lhs)
+        .set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS))
+        .Check(rhs);
+  }
+}
+
+void CheckPointerAssignment(evaluate::FoldingContext &context,
+    parser::CharBlock source, const std::string &description,
+    const DummyDataObject &lhs, const SomeExpr &rhs) {
+  PointerAssignmentChecker{source, description, context}
+      .set_lhsType(common::Clone(lhs.type))
+      .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
+      .Check(rhs);
+}
+
+}
diff --git a/flang/lib/semantics/pointer-assignment.h b/flang/lib/semantics/pointer-assignment.h
new file mode 100644 (file)
index 0000000..268a559
--- /dev/null
@@ -0,0 +1,36 @@
+//===-- lib/semantics/pointer-assignment.h --------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_SEMANTICS_POINTER_ASSIGNMENT_H_
+#define FORTRAN_SEMANTICS_POINTER_ASSIGNMENT_H_
+
+#include "type.h"
+#include "../parser/char-block.h"
+#include <string>
+
+namespace Fortran::evaluate::characteristics {
+struct DummyDataObject;
+}
+
+namespace Fortran::evaluate {
+class FoldingContext;
+}
+
+namespace Fortran::semantics {
+
+class Symbol;
+
+void CheckPointerAssignment(
+    evaluate::FoldingContext &, const Symbol &lhs, const SomeExpr &rhs);
+void CheckPointerAssignment(evaluate::FoldingContext &,
+    parser::CharBlock source, const std::string &description,
+    const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs);
+
+}
+
+#endif  // FORTRAN_SEMANTICS_POINTER_ASSIGNMENT_H_