[flang-commits] [flang] 452269a - [Flang] Fix IsProcedure() for procedure-valued function references (#216322)

[via flang-commits]

Author: nudt_yixiao
Date: 2026-08-28T08:42:28-04:00
New Revision: 452269a0980ecd26d12bc88bd88a8ec6bfca63af

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

LOG: [Flang] Fix IsProcedure() for procedure-valued function references (#216322)

IsProcedure() does not recognize function references whose results are
procedures. This can cause an assertion failure in intrinsic argument
checking when such an expression is passed as an actual argument.

Update IsProcedure() to inspect the result symbol of a ProcedureRef and
determine whether the function result is a procedure.

Add a regression test for procedure-valued function references.

Fixes #209978

Co-authored-by: yixiao <yixiao at hygon.cn>

Added: 
    flang/test/Semantics/func-proc-result-intrinsics.f90

Modified: 
    flang/lib/Evaluate/tools.cpp
    flang/test/Semantics/func-proc-result.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 23a2f42ca66cd..6c8ee3da0046f 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1004,7 +1004,21 @@ bool IsProcedurePointer(const Expr<SomeType> &expr) {
 }
 
 bool IsProcedure(const Expr<SomeType> &expr) {
-  return IsProcedureDesignator(expr) || IsProcedurePointer(expr);
+  if (IsProcedureDesignator(expr) || IsProcedurePointer(expr)) {
+    return true;
+  }
+  // Also look through a reference to a function whose result is a
+  // procedure, mirroring the function-reference handling in
+  // IsProcedurePointer() above. (Matters for expressions produced
+  // during error recovery.)
+  if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
+    if (const Symbol *proc{funcRef->proc().GetSymbol()}) {
+      if (const Symbol *result{FindFunctionResult(*proc)}) {
+        return IsProcedure(*result);
+      }
+    }
+  }
+  return false;
 }
 
 bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {

diff  --git a/flang/test/Semantics/func-proc-result-intrinsics.f90 b/flang/test/Semantics/func-proc-result-intrinsics.f90
new file mode 100644
index 0000000000000..3453e33df0c43
--- /dev/null
+++ b/flang/test/Semantics/func-proc-result-intrinsics.f90
@@ -0,0 +1,47 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! A reference to a function whose result is a plain procedure (invalid:
+! a function result is either a variable or a procedure pointer, F2023
+! 19.3.3), passed to various intrinsics: each must produce an accurate
+! argument error instead of an assertion failure.
+
+function s1(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Actual argument for 'a=' may not be a procedure
+  print *, rank(s1(dd))
+end
+
+function s2(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Actual argument for 'source=' may not be a procedure
+  print *, shape(s2(dd))
+end
+
+function s3(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Actual argument for 'array=' may not be a procedure
+  print *, size(s3(dd), 1)
+end
+
+function s4(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Actual argument for 'a=' may not be a procedure
+  print *, storage_size(s4(dd))
+end
+
+function s5(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Actual argument for 'source=' may not be a procedure
+  print *, transfer(s5(dd), 0)
+end
+
+function s6(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Actual argument for 'array=' may not be a procedure
+  print *, lbound(s6(dd), 1)
+end

diff  --git a/flang/test/Semantics/func-proc-result.f90 b/flang/test/Semantics/func-proc-result.f90
index 5bf8ac9c4ddea..eb887e42471af 100644
--- a/flang/test/Semantics/func-proc-result.f90
+++ b/flang/test/Semantics/func-proc-result.f90
@@ -16,3 +16,33 @@ function bad2() result(res2)
   !ERROR: EXTERNAL attribute not allowed on 'res2'
   external res2
 end
+
+function s(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Actual argument for 'array=' may not be a procedure
+  print *, size(S(dd))
+end
+
+! A procedure POINTER result is valid, but a reference to such a function
+! is still not acceptable as an intrinsic array argument.
+function s1(x) result(i)
+  procedure(), pointer :: i
+  !ERROR: Actual argument for 'array=' may not be a procedure
+  print *, size(S1(dd))
+end
+
+function s2(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Output item must not be a procedure
+  print *, s2(dd)
+end
+
+function s3(x) result(i)
+  !ERROR: A function result may not be a procedure unless it is a procedure pointer
+  procedure() :: i
+  !ERROR: Selector may not be a procedure
+  select type (y => s3(dd))
+  end select
+end