From: Peter Klausler <pklausler@nvidia.com>
Date: Tue, 11 Oct 2022 23:31:47 +0000 (-0700)
Subject: [flang] Catch inconsistent function/subroutine usage of procedure pointer components
X-Git-Tag: upstream/17.0.6~29080
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=874fc5339e7c59fa624ef7bf492ac53bb4f8962b;p=platform%2Fupstream%2Fllvm.git

[flang] Catch inconsistent function/subroutine usage of procedure pointer components

When a derived type has a procedure pointer component with no interface,
we can't do a lot of checking on its call sites, but we can at least require
that the same procedure pointer component be used consistently as either
a function or as a subroutine, but not both.

Differential Revision: https://reviews.llvm.org/D136905
---

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 7cbe2715..6b68074 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6951,7 +6951,15 @@ void ResolveNamesVisitor::HandleCall(
   common::visit(
       common::visitors{
           [&](const parser::Name &x) { HandleProcedureName(procFlag, x); },
-          [&](const parser::ProcComponentRef &x) { Walk(x); },
+          [&](const parser::ProcComponentRef &x) {
+            Walk(x);
+            const parser::Name &name{x.v.thing.component};
+            if (Symbol * symbol{name.symbol}) {
+              if (IsProcedure(*symbol)) {
+                SetProcFlag(name, *symbol, procFlag);
+              }
+            }
+          },
       },
       std::get<parser::ProcedureDesignator>(call.t).u);
   Walk(std::get<std::list<parser::ActualArgSpec>>(call.t));
diff --git a/flang/test/Semantics/resolve09.f90 b/flang/test/Semantics/resolve09.f90
index 2954b14..6335de1 100644
--- a/flang/test/Semantics/resolve09.f90
+++ b/flang/test/Semantics/resolve09.f90
@@ -113,3 +113,16 @@ end
 function b8()
   b8 = 0.0
 end
+
+subroutine s9
+  type t
+    procedure(), nopass, pointer :: p1, p2
+  end type
+  type(t) x
+  print *, x%p1()
+  call x%p2
+  !ERROR: Cannot call function 'p1' like a subroutine
+  call x%p1
+  !ERROR: Cannot call subroutine 'p2' like a function
+  print *, x%p2()
+end subroutine