[flang-commits] [flang] [flang] Catch coindexed procedure pointer/binding references (PR #129931)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/129931

A procedure designator cannot be coindexed, except for cases in which the coindexing doesn't matter (i.e. a binding that can't be overridden).

>From 13dd403c3f7eff8d4a20b523038c7967aafb2cf1 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 5 Mar 2025 12:20:58 -0800
Subject: [PATCH] [flang] Catch coindexed procedure pointer/binding references

A procedure designator cannot be coindexed, except for cases in
which the coindexing doesn't matter (i.e. a binding that can't be
overridden).
---
 flang/include/flang/Evaluate/tools.h |  6 +++-
 flang/lib/Semantics/expression.cpp   |  9 ++++++
 flang/test/Semantics/bindings01.f90  | 42 ++++++++++++++++++++++++++++
 3 files changed, 56 insertions(+), 1 deletion(-)

diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 050990d1cd7ed..1414eaf14f7d6 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -464,9 +464,13 @@ struct ExtractCoindexedObjectHelper {
   }
 };
 
+static inline std::optional<CoarrayRef> ExtractCoarrayRef(const DataRef &x) {
+  return ExtractCoindexedObjectHelper{}(x);
+}
+
 template <typename A> std::optional<CoarrayRef> ExtractCoarrayRef(const A &x) {
   if (auto dataRef{ExtractDataRef(x, true)}) {
-    return ExtractCoindexedObjectHelper{}(*dataRef);
+    return ExtractCoarrayRef(*dataRef);
   } else {
     return ExtractCoindexedObjectHelper{}(x);
   }
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 827defd605f7f..8f2a55acaaf12 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2487,6 +2487,15 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
           return CalleeAndArguments{
               ProcedureDesignator{*resolution}, std::move(arguments)};
         } else if (dataRef.has_value()) {
+          if (ExtractCoarrayRef(*dataRef)) {
+            if (IsProcedurePointer(*sym)) {
+              Say(sc.component.source,
+                  "Base of procedure component reference may not be coindexed"_err_en_US);
+            } else {
+              Say(sc.component.source,
+                  "A procedure binding may not be coindexed unless it can be resolved at compilation time"_err_en_US);
+            }
+          }
           if (sym->attrs().test(semantics::Attr::NOPASS)) {
             const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
             if (dtSpec && dtSpec->scope()) {
diff --git a/flang/test/Semantics/bindings01.f90 b/flang/test/Semantics/bindings01.f90
index 7c2dc6448bb3f..dc44db09c4a6f 100644
--- a/flang/test/Semantics/bindings01.f90
+++ b/flang/test/Semantics/bindings01.f90
@@ -293,6 +293,48 @@ subroutine t2p
   end
 end
 
+module m12
+  type t
+    procedure(sub), pointer, nopass :: pp
+   contains
+    procedure, non_overridable, nopass :: tbp1 => sub
+    procedure, nopass :: tbp2 => sub
+    generic :: gen1 => tbp1
+    generic :: gen2 => tbp2
+  end type
+ contains
+  subroutine sub
+  end
+  subroutine test(x, y)
+    class(t) :: x[*]
+    type(t) :: y[*]
+    call x%pp ! ok
+    call y%pp ! ok
+    !ERROR: Base of procedure component reference may not be coindexed
+    call x[1]%pp
+    !ERROR: Base of procedure component reference may not be coindexed
+    call y[1]%pp
+    call x%tbp1 ! ok
+    call y%tbp1 ! ok
+    call x[1]%tbp1 ! ok
+    call y[1]%tbp1 ! ok
+    call x%tbp2 ! ok
+    call y%tbp2 ! ok
+    !ERROR: A procedure binding may not be coindexed unless it can be resolved at compilation time
+    call x[1]%tbp2
+    call y[1]%tbp2 ! ok
+    call x%gen1 ! ok
+    call y%gen1 ! ok
+    call x[1]%gen1 ! ok
+    call y[1]%gen1 ! ok
+    call x%gen2 ! ok
+    call y%gen2 ! ok
+    !ERROR: A procedure binding may not be coindexed unless it can be resolved at compilation time
+    call x[1]%gen2
+    call y[1]%gen2 ! ok
+  end
+end
+
 program test
   use m1
   type,extends(t) :: t2