From cfedf1dac9810483e3797b938b1c291f021865da Mon Sep 17 00:00:00 2001
From: Tim Keith <tkeith@nvidia.com>
Date: Mon, 13 Jan 2020 15:41:23 -0800
Subject: [PATCH] [flang] C1027: procedure pointer may not be coindexed object

Original-commit: flang-compiler/f18@4261daf352edefabee5c97f0ed0da09280240a86
Reviewed-on: https://github.com/flang-compiler/f18/pull/928
Tree-same-pre-rewrite: false
---
 flang/lib/evaluate/tools.h          | 14 +++++++++++++-
 flang/lib/semantics/assignment.cc   |  6 ++++++
 flang/test/semantics/CMakeLists.txt |  1 +
 flang/test/semantics/assign03.f90   | 19 +++++++++++++++++++
 4 files changed, 39 insertions(+), 1 deletion(-)
 create mode 100644 flang/test/semantics/assign03.f90

diff --git a/flang/lib/evaluate/tools.h b/flang/lib/evaluate/tools.h
index de6e6c5..5b2824a 100644
--- a/flang/lib/evaluate/tools.h
+++ b/flang/lib/evaluate/tools.h
@@ -274,6 +274,10 @@ struct ExtractCoindexedObjectHelper {
     return std::nullopt;
   }
   std::optional<CoarrayRef> operator()(const CoarrayRef &x) const { return x; }
+  template<typename A>
+  std::optional<CoarrayRef> operator()(const Expr<A> &expr) const {
+    return std::visit(*this, expr.u);
+  }
   std::optional<CoarrayRef> operator()(const DataRef &dataRef) const {
     return std::visit(*this, dataRef.u);
   }
@@ -284,6 +288,14 @@ struct ExtractCoindexedObjectHelper {
       return std::nullopt;
     }
   }
+  std::optional<CoarrayRef> operator()(const ProcedureDesignator &des) const {
+    if (const auto *component{
+            std::get_if<common::CopyableIndirection<Component>>(&des.u)}) {
+      return (*this)(component->value());
+    } else {
+      return std::nullopt;
+    }
+  }
   std::optional<CoarrayRef> operator()(const Component &component) const {
     return (*this)(component.base());
   }
@@ -296,7 +308,7 @@ template<typename A> std::optional<CoarrayRef> ExtractCoarrayRef(const A &x) {
   if (auto dataRef{ExtractDataRef(x)}) {
     return ExtractCoindexedObjectHelper{}(*dataRef);
   } else {
-    return std::nullopt;
+    return ExtractCoindexedObjectHelper{}(x);
   }
 }
 
diff --git a/flang/lib/semantics/assignment.cc b/flang/lib/semantics/assignment.cc
index 4263f59..880f439 100644
--- a/flang/lib/semantics/assignment.cc
+++ b/flang/lib/semantics/assignment.cc
@@ -200,6 +200,12 @@ void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
     if (lhs && rhs) {
       CheckForPureContext(
           *lhs, *rhs, std::get<parser::Expr>(stmt.t).source, true /* => */);
+      const Symbol *pointer{GetLastSymbol(lhs)};
+      if (pointer && pointer->has<ProcEntityDetails>() &&
+          evaluate::ExtractCoarrayRef(*lhs)) {
+        context_.Say(  // C1027
+            "Procedure pointer may not be a coindexed object"_err_en_US);
+      }
     }
     // TODO continue here, using CheckPointerAssignment()
   }
diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt
index 2c8d636..f7dd741 100644
--- a/flang/test/semantics/CMakeLists.txt
+++ b/flang/test/semantics/CMakeLists.txt
@@ -105,6 +105,7 @@ set(ERROR_TESTS
   structconst03.f90
   structconst04.f90
   assign01.f90
+  assign03.f90
   if_arith02.f90
   if_arith03.f90
   if_arith04.f90
diff --git a/flang/test/semantics/assign03.f90 b/flang/test/semantics/assign03.f90
new file mode 100644
index 0000000..b3d94a6
--- /dev/null
+++ b/flang/test/semantics/assign03.f90
@@ -0,0 +1,19 @@
+module m
+  interface
+    subroutine s(i)
+      integer i
+    end
+  end interface
+  type :: t
+    procedure(s), pointer, nopass :: p
+  end type
+contains
+  ! C1027
+  subroutine s1
+    type(t), allocatable :: a(:)
+    type(t), allocatable :: b[:]
+    a(1)%p => s
+    !ERROR: Procedure pointer may not be a coindexed object
+    b[1]%p => s
+  end
+end
-- 
2.7.4