[flang-commits] [flang] d20f55f - [flang] Silence bogus error on local proc pointer initializer (#116663)

[via flang-commits]

Author: Peter Klausler
Date: 2024-11-19T16:20:08-08:00
New Revision: d20f55fbd5786f056ff8417bddc7c47df6c7f90b

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

LOG: [flang] Silence bogus error on local proc pointer initializer (#116663)

A procedure pointer is allowed to be initialized with the subprogram in
which it is local, assuming that other requirements are satisfied.

Add a good test for local procedure pointer initialization, as no test
existed for the error message in question.

Fixes https://github.com/llvm/llvm-project/issues/116566.

Added: 
    flang/test/Semantics/pointer02.f90

Modified: 
    flang/lib/Semantics/check-declarations.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 354594f3339df9..c9656d031b2e17 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1110,7 +1110,8 @@ void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
       if (proc->init() && *proc->init()) {
         // C1519 - must be nonelemental external or module procedure,
         // or an unrestricted specific intrinsic function.
-        const Symbol &ultimate{(*proc->init())->GetUltimate()};
+        const Symbol &local{DEREF(*proc->init())};
+        const Symbol &ultimate{local.GetUltimate()};
         bool checkTarget{true};
         if (ultimate.attrs().test(Attr::INTRINSIC)) {
           if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
@@ -1123,11 +1124,12 @@ void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
                 ultimate.name(), symbol.name());
             checkTarget = false;
           }
-        } else if ((!ultimate.attrs().test(Attr::EXTERNAL) &&
-                       ultimate.owner().kind() != Scope::Kind::Module) ||
+        } else if (!(ultimate.attrs().test(Attr::EXTERNAL) ||
+                       ultimate.owner().kind() == Scope::Kind::Module ||
+                       ultimate.owner().IsTopLevel()) ||
             IsDummy(ultimate) || IsPointer(ultimate)) {
-          context_.Say("Procedure pointer '%s' initializer '%s' is neither "
-                       "an external nor a module procedure"_err_en_US,
+          context_.Say(
+              "Procedure pointer '%s' initializer '%s' is neither an external nor a module procedure"_err_en_US,
               symbol.name(), ultimate.name());
           checkTarget = false;
         } else if (IsElementalProcedure(ultimate)) {

diff  --git a/flang/test/Semantics/pointer02.f90 b/flang/test/Semantics/pointer02.f90
new file mode 100644
index 00000000000000..90bb4358559395
--- /dev/null
+++ b/flang/test/Semantics/pointer02.f90
@@ -0,0 +1,53 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+recursive subroutine sub(dp, dpp)
+  procedure(inner) dp
+  procedure(inner), pointer :: dpp
+  procedure(inner) ext
+  procedure(sub), pointer :: p1 => sub ! ok
+  procedure(inner), pointer :: p2 => ext ! ok
+  !ERROR: Procedure pointer 'p3' initializer 'inner' is neither an external nor a module procedure
+  procedure(inner), pointer :: p3 => inner
+  !ERROR: Procedure pointer 'p4' initializer 'dp' is neither an external nor a module procedure
+  procedure(inner), pointer :: p4 => dp
+  !ERROR: Procedure pointer 'p5' initializer 'dpp' is neither an external nor a module procedure
+  procedure(inner), pointer :: p5 => dpp
+  generic :: generic => ext
+  !ERROR: 'generic' must be an abstract interface or a procedure with an explicit interface
+  procedure(generic), pointer :: p6 ! => generic
+ contains
+  subroutine inner
+  end
+end
+recursive function fun() result(res)
+  procedure(fun), pointer :: p1 => fun ! ok
+  !ERROR: Procedure pointer 'p2' initializer 'inner' is neither an external nor a module procedure
+  procedure(inner), pointer :: p2 => inner
+  res = 0.
+ contains
+  function inner()
+    inner = 0.
+  end
+end
+module m
+  procedure(msub), pointer :: ps1 => msub ! ok
+  procedure(mfun), pointer :: pf1 => mfun ! ok
+ contains
+  recursive subroutine msub
+    procedure(msub), pointer :: ps2 => msub ! ok
+    !ERROR: Procedure pointer 'ps3' initializer 'inner' is neither an external nor a module procedure
+    procedure(inner), pointer :: ps3 => inner
+   contains
+    subroutine inner
+    end
+  end
+  recursive function mfun() result(res)
+    procedure(mfun), pointer :: pf2 => mfun ! ok
+    !ERROR: Procedure pointer 'pf3' initializer 'inner' is neither an external nor a module procedure
+    procedure(inner), pointer :: pf3 => inner
+    res = 0.
+   contains
+    function inner()
+      inner = 0.
+    end
+  end
+end