[flang-commits] [flang] bd28a0a - [flang] Catch attempts to do anything with statement functions other than call them

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-10-30T17:54:22-07:00
New Revision: bd28a0a51181ad33dc9030fb887d26cd6b238c1f

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

LOG: [flang] Catch attempts to do anything with statement functions other than call them

A statement function in Fortran may be called, but it may not be the target
of a procedure pointer or passed as an actual argument.

Added: 
    

Modified: 
    flang/lib/Semantics/check-call.cpp
    flang/lib/Semantics/pointer-assignment.cpp
    flang/test/Semantics/assign03.f90
    flang/test/Semantics/call02.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 418d66d3d5db..d36ddd3623ba 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -77,13 +77,21 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
                    "actual argument", *expr, context)}) {
       const auto *argProcDesignator{
           std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
-      const auto *argProcSymbol{
-          argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
-      if (argProcSymbol && !argChars->IsTypelessIntrinsicDummy() &&
-          argProcDesignator && argProcDesignator->IsElemental()) { // C1533
-        evaluate::SayWithDeclaration(messages, *argProcSymbol,
-            "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
-            argProcSymbol->name());
+      if (const auto *argProcSymbol{
+              argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}) {
+        if (!argChars->IsTypelessIntrinsicDummy() && argProcDesignator &&
+            argProcDesignator->IsElemental()) { // C1533
+          evaluate::SayWithDeclaration(messages, *argProcSymbol,
+              "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
+              argProcSymbol->name());
+        } else if (const auto *subp{argProcSymbol->GetUltimate()
+                                        .detailsIf<SubprogramDetails>()}) {
+          if (subp->stmtFunction()) {
+            evaluate::SayWithDeclaration(messages, *argProcSymbol,
+                "Statement function '%s' may not be passed as an actual argument"_err_en_US,
+                argProcSymbol->name());
+          }
+        }
       }
     }
   }
@@ -574,6 +582,17 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
         std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
     const auto *argProcSymbol{
         argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
+    if (argProcSymbol) {
+      if (const auto *subp{
+              argProcSymbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
+        if (subp->stmtFunction()) {
+          evaluate::SayWithDeclaration(messages, *argProcSymbol,
+              "Statement function '%s' may not be passed as an actual argument"_err_en_US,
+              argProcSymbol->name());
+          return;
+        }
+      }
+    }
     if (auto argChars{characteristics::DummyArgument::FromActual(
             "actual argument", *expr, context)}) {
       if (!argChars->IsTypelessIntrinsicDummy()) {

diff  --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 69e80e5a1240..54e36f5b085b 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -279,6 +279,17 @@ bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
+  if (const Symbol * symbol{d.GetSymbol()}) {
+    if (const auto *subp{
+            symbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
+      if (subp->stmtFunction()) {
+        evaluate::SayWithDeclaration(context_.messages(), *symbol,
+            "Statement function '%s' may not be the target of a pointer assignment"_err_en_US,
+            symbol->name());
+        return false;
+      }
+    }
+  }
   if (auto chars{Procedure::Characterize(d, context_)}) {
     return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic());
   } else {

diff  --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index 5740339edb55..a5d12be48785 100644
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -314,4 +314,11 @@ subroutine s13
     ptr => s_external
     call ptr
   end subroutine
+
+  subroutine s14
+    procedure(real), pointer :: ptr
+    sf(x) = x + 1.
+    !ERROR: Statement function 'sf' may not be the target of a pointer assignment
+    ptr => sf
+  end subroutine
 end

diff  --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90
index 8ef10415be80..264a79f8983a 100644
--- a/flang/test/Semantics/call02.f90
+++ b/flang/test/Semantics/call02.f90
@@ -43,6 +43,19 @@ elemental integer function elem()
   end function
 end
 
+subroutine s03
+  interface
+    subroutine sub1(p)
+      procedure(real) :: p
+    end subroutine
+  end interface
+  sf(x) = x + 1.
+  !ERROR: Statement function 'sf' may not be passed as an actual argument
+  call sub1(sf)
+  !ERROR: Statement function 'sf' may not be passed as an actual argument
+  call sub2(sf)
+end
+
 module m01
   procedure(sin) :: elem01
   interface