[flang-commits] [flang] 66fdfff - [flang] Require explicit interface for some dummy procedures

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-10-30T17:11:25-07:00
New Revision: 66fdfff7bcc3da851a0aeaf261a9a5a46fe8bbf9

URL: https://github.com/llvm/llvm-project/commit/66fdfff7bcc3da851a0aeaf261a9a5a46fe8bbf9
DIFF: https://github.com/llvm/llvm-project/commit/66fdfff7bcc3da851a0aeaf261a9a5a46fe8bbf9.diff

LOG: [flang] Require explicit interface for some dummy procedures

Some of the circumstances that require that a procedure have an
explicit interface at a point of call due to a characteristic of
a dummy argument apply to dummy procedures, too.

Differential Revision: https://reviews.llvm.org/D136994

Added: 
    

Modified: 
    flang/include/flang/Evaluate/characteristics.h
    flang/lib/Evaluate/characteristics.cpp
    flang/lib/Semantics/check-call.cpp
    flang/test/Semantics/call24.f90
    flang/test/Semantics/call25.f90

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 0e055641f719f..aebb210582e70 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -213,6 +213,7 @@ struct DummyProcedure {
   bool operator!=(const DummyProcedure &that) const { return !(*this == that); }
   bool IsCompatibleWith(
       const DummyProcedure &, std::string *whyNot = nullptr) const;
+  bool CanBePassedViaImplicitInterface() const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
   CopyableIndirection<Procedure> procedure;

diff  --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index ee6b6ca8f2894..cf43bab6a5eb7 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -404,6 +404,13 @@ bool DummyProcedure::IsCompatibleWith(
   return true;
 }
 
+bool DummyProcedure::CanBePassedViaImplicitInterface() const {
+  if ((attrs & Attrs{Attr::Optional, Attr::Pointer}).any()) {
+    return false; // 15.4.2.2(3)(a)
+  }
+  return true;
+}
+
 static std::string GetSeenProcs(
     const semantics::UnorderedSymbolSet &seenProcs) {
   // Sort the symbols so that they appear in the same order on all platforms
@@ -766,6 +773,8 @@ common::Intent DummyArgument::GetIntent() const {
 bool DummyArgument::CanBePassedViaImplicitInterface() const {
   if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
     return object->CanBePassedViaImplicitInterface();
+  } else if (const auto *proc{std::get_if<DummyProcedure>(&u)}) {
+    return proc->CanBePassedViaImplicitInterface();
   } else {
     return true;
   }

diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 832dd0d34a3fb..418d66d3d5db0 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -964,7 +964,7 @@ void CheckArguments(const characteristics::Procedure &proc,
         CheckExplicitInterface(proc, actuals, context, scope, intrinsic)};
     if (treatingExternalAsImplicit && !buffer.empty()) {
       if (auto *msg{messages.Say(
-              "If the procedure's interface were explicit, this reference would be in error:"_warn_en_US)}) {
+              "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
         buffer.AttachTo(*msg, parser::Severity::Because);
       }
     }

diff  --git a/flang/test/Semantics/call24.f90 b/flang/test/Semantics/call24.f90
index 9013a3f621b26..7d2ba9ff80d40 100644
--- a/flang/test/Semantics/call24.f90
+++ b/flang/test/Semantics/call24.f90
@@ -8,9 +8,19 @@ subroutine foo(a_pointer)
   real, pointer :: a_pointer(:)
 end subroutine
 
+subroutine bar(a_pointer)
+  procedure(real), pointer :: a_pointer
+end subroutine
+
+subroutine baz(proc)
+  external :: proc
+  real, optional :: proc
+end subroutine
+
 subroutine test()
   real, pointer :: a_pointer(:)
   real, pointer :: an_array(:)
+  intrinsic :: sin
 
   ! This call would be allowed if the interface was explicit here,
   ! but its handling with an implicit interface is 
diff erent (no
@@ -23,4 +33,12 @@ subroutine test()
 
   !ERROR: References to the procedure 'foo' require an explicit interface
   call foo(an_array)
+
+  !ERROR: References to the procedure 'bar' require an explicit interface
+  !WARNING: If the procedure's interface were explicit, this reference would be in error
+  !BECAUSE: Actual argument associated with procedure pointer dummy argument 'a_pointer=' must be a POINTER unless INTENT(IN)
+  call bar(sin)
+
+  !ERROR: References to the procedure 'baz' require an explicit interface
+  call baz(sin)
 end subroutine

diff  --git a/flang/test/Semantics/call25.f90 b/flang/test/Semantics/call25.f90
index 0f9219f30694f..7ef6beb6adf7c 100644
--- a/flang/test/Semantics/call25.f90
+++ b/flang/test/Semantics/call25.f90
@@ -43,7 +43,7 @@ program main
   call subr2(notChar)
   call subr3(explicitLength)
   call subr3(assumedLength)
-  !CHECK: warning: If the procedure's interface were explicit, this reference would be in error:
+  !CHECK: warning: If the procedure's interface were explicit, this reference would be in error
   !CHECK: because: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
   call subr3(notChar)
 end program