[flang-commits] [flang] [flang] Whether a procedure's interface is explicit or not is not a d… (PR #82796)

[Peter Klausler via flang-commits]

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

>From 9c48cf5879d14a3d0989fa3a7239fc0613c747f1 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 23 Feb 2024 09:16:27 -0800
Subject: [PATCH] [flang] Whether a procedure's interface is explicit or not is
 not a distinguishing characteristic

We note whether a procedure's interface is explicit or implicit as an
attribute of its characteristics, so that other semantics can be
checked appropriately, but this internal attribute should not be
used as a distinguishing characteristic in itself.

Fixes https://github.com/llvm/llvm-project/issues/81876.
---
 flang/lib/Evaluate/characteristics.cpp |  1 +
 flang/lib/Semantics/resolve-names.cpp  | 23 ++++++++++++++++-------
 flang/test/Semantics/call35.f90        |  2 +-
 flang/test/Semantics/null-init.f90     |  2 +-
 4 files changed, 19 insertions(+), 9 deletions(-)

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 80b0f346c32d38..cf8b16c0ead6cd 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -1265,6 +1265,7 @@ bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
   }
   Attrs differences{attrs ^ actualAttrs};
   differences.reset(Attr::Subroutine); // dealt with specifically later
+  differences.reset(Attr::ImplicitInterface);
   if (!differences.empty()) {
     if (whyNot) {
       auto sep{": "s};
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 0cbe0b492fa44a..aca833a3a4ae8b 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -8362,18 +8362,27 @@ bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) {
   const auto &bounds{std::get<parser::PointerAssignmentStmt::Bounds>(x.t)};
   const auto &expr{std::get<parser::Expr>(x.t)};
   ResolveDataRef(dataRef);
+  Symbol *ptrSymbol{parser::GetLastName(dataRef).symbol};
   Walk(bounds);
   // Resolve unrestricted specific intrinsic procedures as in "p => cos".
   if (const parser::Name * name{parser::Unwrap<parser::Name>(expr)}) {
     if (NameIsKnownOrIntrinsic(*name)) {
-      // If the name is known because it is an object entity from a host
-      // procedure, create a host associated symbol.
-      if (Symbol * symbol{name->symbol}; symbol &&
-          symbol->GetUltimate().has<ObjectEntityDetails>() &&
-          IsUplevelReference(*symbol)) {
-        MakeHostAssocSymbol(*name, *symbol);
+      if (Symbol * symbol{name->symbol}) {
+        if (IsProcedurePointer(ptrSymbol) &&
+            !ptrSymbol->test(Symbol::Flag::Function) &&
+            !ptrSymbol->test(Symbol::Flag::Subroutine)) {
+          if (symbol->test(Symbol::Flag::Function)) {
+            ApplyImplicitRules(*ptrSymbol);
+          }
+        }
+        // If the name is known because it is an object entity from a host
+        // procedure, create a host associated symbol.
+        if (symbol->GetUltimate().has<ObjectEntityDetails>() &&
+            IsUplevelReference(*symbol)) {
+          MakeHostAssocSymbol(*name, *symbol);
+        }
+        return false;
       }
-      return false;
     }
     // Can also reference a global external procedure here
     if (auto it{context().globalScope().find(name->source)};
diff --git a/flang/test/Semantics/call35.f90 b/flang/test/Semantics/call35.f90
index ff819481226d62..81a0ecb04da536 100644
--- a/flang/test/Semantics/call35.f90
+++ b/flang/test/Semantics/call35.f90
@@ -12,7 +12,7 @@ subroutine s2
 
 subroutine s3
   interface
-    !WARNING: The global subprogram 'ext' is not compatible with its local procedure declaration (incompatible procedure attributes: ImplicitInterface)
+    !WARNING: The global subprogram 'ext' is not compatible with its local procedure declaration (distinct numbers of dummy arguments)
     subroutine ext(n)
       integer n
     end
diff --git a/flang/test/Semantics/null-init.f90 b/flang/test/Semantics/null-init.f90
index ad3f91679a4272..ad2fa511f9ff3f 100644
--- a/flang/test/Semantics/null-init.f90
+++ b/flang/test/Semantics/null-init.f90
@@ -37,7 +37,7 @@ module m6
 
 module m7
   interface
-    !WARNING: The external interface 'null' is not compatible with an earlier definition (incompatible procedure attributes: ImplicitInterface)
+    !WARNING: The external interface 'null' is not compatible with an earlier definition (function results have incompatible attributes)
     function null() result(p)
       integer, pointer :: p
     end function