[flang-commits] [flang] [flang] Missing function-vs-subroutine checks on bindings (PR #177699)

[Peter Klausler via flang-commits]

https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/177699

>From 9e1d733a1a96bce2a379bbf6639ac82df74b1fa3 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 23 Jan 2026 14:40:33 -0800
Subject: [PATCH] [flang] Missing function-vs-subroutine checks on bindings

Derived type procedure bindings aren't always subject to the
checks of the function-vs-subroutine classification flags on their
symbol table entries in name resolution, and we're missing some
cases that aren't caught later in expression semantics, which assumed
that name resolution would have already handled them.
So check function-vs-subroutine errors on bindings in expression
semantics entirely.

Fixes https://github.com/llvm/llvm-project/issues/177601.
---
 flang/lib/Semantics/expression.cpp    |  7 +++
 flang/lib/Semantics/resolve-names.cpp |  5 ++
 flang/test/Semantics/bug177601.f90    | 80 +++++++++++++++++++++++++++
 3 files changed, 92 insertions(+)
 create mode 100644 flang/test/Semantics/bug177601.f90

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index e07d2ccd4f16b..e20ce698abc65 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2651,6 +2651,13 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
                 "Base of procedure component reference must be scalar"_err_en_US);
           }
         }
+        if (IsFunction(*sym) == isSubroutine &&
+            sym->has<semantics::ProcBindingDetails>()) {
+          AttachDeclaration(
+              Say(sc.Component().source, "Binding '%s' is not a %s"_err_en_US,
+                  sym->name(), isSubroutine ? "subroutine" : "function"),
+              *sym);
+        }
         if (const Symbol *resolution{
                 GetBindingResolution(dtExpr->GetType(), *sym)}) {
           AddPassArg(arguments, std::move(*dtExpr), *sym, false);
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 057fa1db239c1..ba92eacbf0445 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -9514,6 +9514,11 @@ static bool IsLocallyImplicitGlobalSymbol(
 // Check and set the Function or Subroutine flag on symbol; false on error.
 bool ResolveNamesVisitor::SetProcFlag(
     const parser::Name &name, Symbol &symbol, Symbol::Flag flag) {
+  if (symbol.has<ProcBindingDetails>()) {
+    // Binding function-vs-subroutine errors are caught later in
+    // expression semantics and procedure compatibility checking.
+    return true;
+  }
   if (symbol.test(Symbol::Flag::Function) && flag == Symbol::Flag::Subroutine) {
     SayWithDecl(
         name, symbol, "Cannot call function '%s' like a subroutine"_err_en_US);
diff --git a/flang/test/Semantics/bug177601.f90 b/flang/test/Semantics/bug177601.f90
new file mode 100644
index 0000000000000..d811e08cd84d4
--- /dev/null
+++ b/flang/test/Semantics/bug177601.f90
@@ -0,0 +1,80 @@
+!RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+module m
+  type :: tbps
+   contains
+    procedure, nopass :: fprocf, fprocs, ffunc1, ffunc2, ffunc3, fsub
+   end type
+ contains
+  function fprocf()
+    procedure(), pointer :: fprocf
+    fprocf => func
+  end
+  function fprocs()
+    procedure(), pointer :: fprocs
+    fprocs => sub
+  end
+  function ffunc1()
+    procedure(), pointer :: ffunc1
+    real ffunc1
+    ffunc1 => func
+  end
+  function ffunc2()
+    procedure(real), pointer :: ffunc2
+    ffunc2 => func
+  end
+  function ffunc3()
+    procedure(func), pointer :: ffunc3
+    ffunc3 => func
+  end
+  function fsub()
+    procedure(sub), pointer :: fsub
+    fsub => sub
+  end
+  subroutine sub
+  end
+  function func()
+    func = 0.
+  end
+end
+
+program p
+  use m
+  type(tbps) :: x
+  procedure(), pointer :: gp
+  procedure(real), pointer :: rfp
+  procedure(sub), pointer :: sp
+  gp => x%fprocf() ! procedure() always ok to assign any procedure to
+  gp => x%fprocs()
+  gp => x%ffunc1()
+  gp => x%ffunc2()
+  gp => x%ffunc3()
+  gp => x%fsub()
+  rfp => x%fprocf() ! can be assigned a procedure() function result
+  rfp => x%fprocs() ! can be assigned a procedure() function result
+  rfp => x%ffunc1()
+  rfp => x%ffunc2()
+  rfp => x%ffunc3()
+  !ERROR: Procedure pointer 'rfp' associated with result of reference to function 'fsub' that is an incompatible procedure pointer: incompatible procedures: one is a function, the other a subroutine
+  rfp => x%fsub()
+  sp => x%fprocf() ! can be assigned a procedure() function result
+  sp => x%fprocs() ! can be assigned a procedure() function result
+  !ERROR: Procedure pointer 'sp' associated with result of reference to function 'ffunc1' that is an incompatible procedure pointer: incompatible procedures: one is a function, the other a subroutine
+  sp => x%ffunc1()
+  !ERROR: Procedure pointer 'sp' associated with result of reference to function 'ffunc2' that is an incompatible procedure pointer: incompatible procedures: one is a function, the other a subroutine
+  sp => x%ffunc2()
+  !ERROR: Procedure pointer 'sp' associated with result of reference to function 'ffunc3' that is an incompatible procedure pointer: incompatible procedures: one is a function, the other a subroutine
+  sp => x%ffunc3()
+  sp => x%fsub()
+  !ERROR: Binding 'fprocf' is not a subroutine
+  call x%fprocf()
+  !ERROR: Binding 'fprocs' is not a subroutine
+  call x%fprocs()
+  !ERROR: Binding 'ffunc1' is not a subroutine
+  call x%ffunc1()
+  !ERROR: Binding 'ffunc2' is not a subroutine
+  call x%ffunc2()
+  !ERROR: Binding 'ffunc3' is not a subroutine
+  call x%ffunc3()
+  !ERROR: Binding 'fsub' is not a subroutine
+  call x%fsub()
+end