[flang] Catch non-constant targets for procedure pointer initialization

[klausler]

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

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

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

---

Full diff: https://github.com/llvm/llvm-project/pull/86338.diff

2 Files Affected:

• (modified) flang/lib/Evaluate/check-expression.cpp (+7-3)
• (added) flang/test/Semantics/structconst09.f90 (+37)

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

[github-actions]

✅ With the latest revision this PR passed the C/C++ code formatter.

[github-actions]

✅ With the latest revision this PR passed the Python code formatter.

[jeanPerier]

Thank you