[flang-commits] [flang] [Flang] Preserve restricted specific intrinsic designators (PR #227359)

[via flang-commits]

https://github.com/keepyixiao created https://github.com/llvm/llvm-project/pull/227359

Restricted specific intrinsic procedures were rejected while building a procedure designator, preventing later semantic checks from diagnosing invalid procedure pointer assignments.

Preserve the procedure designator after issuing the existing diagnostic so that subsequent semantic checks can continue and report the appropriate pointer assignment error.

Add regression coverage for procedure pointer assignment to a restricted specific intrinsic.

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

>From 3f3e012d81201697e630f2482dc991dde8946067 Mon Sep 17 00:00:00 2001
From: nudt_yixiao <1272950933 at qq.com>
Date: Tue, 29 Sep 2026 22:44:07 +0800
Subject: [PATCH] [Flang] Preserve restricted specific intrinsic designators

Restricted specific intrinsic procedures were rejected while building a
procedure designator, preventing later semantic checks from diagnosing
invalid procedure pointer assignments.

Preserve the procedure designator after issuing the existing diagnostic so
that subsequent semantic checks can continue and report the appropriate
pointer assignment error.

Add regression coverage for procedure pointer assignment to a restricted
specific intrinsic.
---
 flang/lib/Semantics/expression.cpp |  9 +++++++--
 flang/test/Semantics/assign09.f90  |  3 +++
 flang/test/Semantics/resolve46.f90 | 13 +++++++++++++
 3 files changed, 23 insertions(+), 2 deletions(-)

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index f514adc0f476d..675054c38895c 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -253,10 +253,15 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
       }
     } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
                    symbol.name().ToString())};
-               interface && !interface->isRestrictedSpecific) {
+        interface) {
+      const bool isRestrictedSpecific{interface->isRestrictedSpecific};
       SpecificIntrinsic intrinsic{
           symbol.name().ToString(), std::move(*interface)};
-      intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
+      intrinsic.isRestrictedSpecific = isRestrictedSpecific;
+      if (isRestrictedSpecific) {
+        Say("'%s' is not an unrestricted specific intrinsic procedure"_err_en_US,
+            last.name());
+      }
       return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
     } else {
       Say("'%s' is not an unrestricted specific intrinsic procedure"_err_en_US,
diff --git a/flang/test/Semantics/assign09.f90 b/flang/test/Semantics/assign09.f90
index 7c95e3a64ea57..0d2da16dd72ed 100644
--- a/flang/test/Semantics/assign09.f90
+++ b/flang/test/Semantics/assign09.f90
@@ -27,7 +27,10 @@ elemental real function userElemental(a)
   intToRealProcPtr => float
   !ERROR: 'float' is not an unrestricted specific intrinsic procedure
   call sub1(float)
+  ! A restricted specific intrinsic retains its procedure interface, allowing
+  ! subsequent compatibility checks for actual procedure arguments.
   !ERROR: 'float' is not an unrestricted specific intrinsic procedure
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4)
   call sub2(float)
   !ERROR: 'float' is not an unrestricted specific intrinsic procedure
   call sub3(float)
diff --git a/flang/test/Semantics/resolve46.f90 b/flang/test/Semantics/resolve46.f90
index bfa481cd26bbc..0c7420a6ad5fb 100644
--- a/flang/test/Semantics/resolve46.f90
+++ b/flang/test/Semantics/resolve46.f90
@@ -57,6 +57,9 @@ subroutine testRestrictedSpecificWithoutIntrinsicStmt
 ! A restricted specific intrinsic used in a procedure pointer assignment
 ! must be diagnosed even without an explicit INTRINSIC statement.
 subroutine testRestrictedSpecificWithoutIntrinsicStmt1
+  !ERROR: The left-hand side of a pointer assignment is not definable
+  !ERROR: 'u' is not a pointer
+  !ERROR: In assignment to object pointer 'u', the target 'llt' is a procedure designator
   !ERROR: 'llt' is not an unrestricted specific intrinsic procedure
   u => llt
 end subroutine
@@ -88,3 +91,13 @@ subroutine testRestrictedSpecificCallWithoutIntrinsicStmt
   logical :: result
   result = llt('a', 'b')
 end subroutine
+
+! A restricted specific intrinsic with a numeric result must still form a
+! procedure designator so that subsequent pointer assignment checks are run.
+subroutine testRestrictedSpecificWithInvalidPointerAssignment
+  !ERROR: The left-hand side of a pointer assignment is not definable
+  !ERROR: 'u' is not a pointer
+  !ERROR: In assignment to object pointer 'u', the target 'amin0' is a procedure designator
+  !ERROR: 'amin0' is not an unrestricted specific intrinsic procedure
+  u => amin0
+end subroutine