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

[via flang-commits]

Author: Peter Klausler
Date: 2024-03-26T09:40:48-07:00
New Revision: 5a0382ce7ab3577630bdbb396e9ddaed8749101e

URL: https://github.com/llvm/llvm-project/commit/5a0382ce7ab3577630bdbb396e9ddaed8749101e
DIFF: https://github.com/llvm/llvm-project/commit/5a0382ce7ab3577630bdbb396e9ddaed8749101e.diff

LOG: [flang] Catch non-constant targets for procedure pointer initialization (#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.

Added: 
    flang/test/Semantics/structconst09.f90

Modified: 
    flang/lib/Evaluate/check-expression.cpp

Removed: 
    


################################################################################
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