[flang-commits] [flang] [flang] Fix bogus error message about invalid polymorphic entity (PR #83733)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/83733

The check for declarations of polymorphic entities was emitting a bogus error for one (or more) layers of pointers to procedures returning pointers to polymorphic types.

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

>From 67f9688cdd76854d7bb8cf729398fba9e0f29591 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Sun, 3 Mar 2024 09:50:53 -0800
Subject: [PATCH] [flang] Fix bogus error message about invalid polymorphic
 entity

The check for declarations of polymorphic entities was emitting a
bogus error for one (or more) layers of pointers to procedures
returning pointers to polymorphic types.

Fixes https://github.com/llvm/llvm-project/issues/83292.
---
 flang/lib/Semantics/check-declarations.cpp | 2 ++
 flang/test/Semantics/declarations06.f90    | 9 +++++++++
 2 files changed, 11 insertions(+)

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 719bea34406aa0..729321d3bf1701 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -3236,6 +3236,8 @@ void CheckHelper::CheckSymbolType(const Symbol &symbol) {
   const Symbol *result{FindFunctionResult(symbol)};
   const Symbol &relevant{result ? *result : symbol};
   if (IsAllocatable(relevant)) { // always ok
+  } else if (IsProcedurePointer(symbol) && result && IsPointer(*result)) {
+    // procedure pointer returning allocatable or pointer: ok
   } else if (IsPointer(relevant) && !IsProcedure(relevant)) {
     // object pointers are always ok
   } else if (auto dyType{evaluate::DynamicType::From(relevant)}) {
diff --git a/flang/test/Semantics/declarations06.f90 b/flang/test/Semantics/declarations06.f90
index 532b0461d391e6..ae9ef6acd75423 100644
--- a/flang/test/Semantics/declarations06.f90
+++ b/flang/test/Semantics/declarations06.f90
@@ -16,6 +16,7 @@ module m
   procedure(cf1), pointer :: pp1
   procedure(cf2), pointer :: pp2
   procedure(cf3), pointer :: pp3
+  procedure(cf5), pointer :: pp4 ! ok
  contains
   !ERROR: CLASS entity 'cf1' must be a dummy argument, allocatable, or object pointer
   class(t) function cf1()
@@ -33,4 +34,12 @@ subroutine test(d1,d2,d3)
     !ERROR: CLASS entity 'd3' must be a dummy argument, allocatable, or object pointer
     class(t), external, pointer :: d3
   end
+  function cf4()
+    class(t), pointer :: cf4
+    cf4 => v3
+  end
+  function cf5
+    procedure(cf4), pointer :: cf5
+    cf5 => cf4
+  end
 end