[flang-commits] [flang] [flang] Catch non-constant targets for procedure pointer initialization (PR #86338)

[Peter Klausler via flang-commits]

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

Detect attempts to use non-constant targets, including internal procedures, as initializers for procedure pointers, including components of structure components being used as initializers.

>From c8c7c56776ecc2a437c5657d241d8bb39df80c48 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 22 Mar 2024 13:50:29 -0700
Subject: [PATCH] [flang] Catch non-constant targets for procedure pointer
 initialization

Detect attempts to use non-constant targets, including internal
procedures, as initializers for procedure pointers, including
components of structure components being used as initializers.
---
 flang/lib/Evaluate/check-expression.cpp | 10 +++++--
 flang/test/Semantics/structconst09.f90  | 37 +++++++++++++++++++++++++
 2 files changed, 44 insertions(+), 3 deletions(-)
 create mode 100644 flang/test/Semantics/structconst09.f90

diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 0e7d97900328bb..7d721399072cae 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -358,10 +358,14 @@ bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
   const auto &ultimate{symbol.GetUltimate()};
   return common::visit(
       common::visitors{
-          [](const semantics::SubprogramDetails &subp) {
-            return !subp.isDummy();
+          [&](const semantics::SubprogramDetails &subp) {
+            return !subp.isDummy() && !subp.stmtFunction() &&
+                symbol.owner().kind() != semantics::Scope::Kind::MainProgram &&
+                symbol.owner().kind() != semantics::Scope::Kind::Subprogram;
+          },
+          [](const semantics::SubprogramNameDetails &x) {
+            return x.kind() != semantics::SubprogramKind::Internal;
           },
-          [](const semantics::SubprogramNameDetails &) { return true; },
           [&](const semantics::ProcEntityDetails &proc) {
             return !semantics::IsPointer(ultimate) && !proc.isDummy();
           },
diff --git a/flang/test/Semantics/structconst09.f90 b/flang/test/Semantics/structconst09.f90
new file mode 100644
index 00000000000000..c129f11606857e
--- /dev/null
+++ b/flang/test/Semantics/structconst09.f90
@@ -0,0 +1,37 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+! Structure constructors with bad pointer targets
+module m
+  real, target, save :: x
+  type t
+    real, pointer :: rp => x
+    procedure(f), pointer, nopass :: pp => f
+  end type
+ contains
+  real function f()
+    f = 0.
+  end
+  subroutine test(da, dp)
+    real, target :: y, da
+    procedure(f) dp
+    procedure(f), pointer :: lpp
+    external ext
+    type(t) :: a1 = t() ! ok
+    type(t) :: a2 = t(rp=x) ! ok
+    type(t) :: a3 = t(pp=f) ! ok
+    type(t) :: a4 = t(pp=ext) ! ok
+    !ERROR: Must be a constant value
+    type(t) :: a5 = t(rp=y)
+    !ERROR: Must be a constant value
+    type(t) :: a6 = t(rp=da)
+    !ERROR: Must be a constant value
+    type(t) :: a7 = t(pp=lpp)
+    !ERROR: Must be a constant value
+    type(t) :: a8 = t(pp=internal)
+    !ERROR: Must be a constant value
+    type(t) :: a9 = t(pp=dp)
+   contains
+    real function internal()
+      internal = 666.
+    end
+  end
+end