[flang-commits] [flang] [flang] Silence errors on C_LOC/C_FUNLOC in specification expressions (PR #96108)

[Peter Klausler via flang-commits]

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

Transformational functions from the intrinsic module ISO_C_BINDING are allowed in specification expressions, so tweak some general checks that would otherwise trigger error messages about inadmissible targets, dummy procedures in specification expressions, and pure procedures with impure dummy procedures.

>From d45672f222287b737b3501fb88bcbd20754ce2b4 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 19 Jun 2024 12:46:30 -0700
Subject: [PATCH] [flang] Silence errors on C_LOC/C_FUNLOC in specification
 expressions

Transformational functions from the intrinsic module ISO_C_BINDING are allowed
in specification expressions, so tweak some general checks that would otherwise
trigger error messages about inadmissible targets, dummy procedures in specification
expressions, and pure procedures with impure dummy procedures.
---
 flang/lib/Evaluate/check-expression.cpp    |  3 ++-
 flang/lib/Evaluate/tools.cpp               |  2 ++
 flang/lib/Semantics/check-declarations.cpp |  5 ++++-
 flang/module/__fortran_builtins.f90        |  5 ++++-
 flang/test/Semantics/c_loc01.f90           | 13 +++++++++++++
 5 files changed, 25 insertions(+), 3 deletions(-)

diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index a4b152c60a72f..5d904cfc3a069 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -649,7 +649,8 @@ class CheckSpecificationExprHelper
               return std::holds_alternative<characteristics::DummyProcedure>(
                   dummy.u);
             })};
-        if (iter != procChars->dummyArguments.end()) {
+        if (iter != procChars->dummyArguments.end() &&
+            ultimate.name().ToString() != "__builtin_c_funloc") {
           return "reference to function '"s + ultimate.name().ToString() +
               "' with dummy procedure argument '" + iter->name + '\'';
         }
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index b2a50ab9b6b83..a5f4faa0cef8f 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -82,6 +82,8 @@ auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
   const Symbol &ultimate{symbol.GetUltimate()};
   return !IsNamedConstant(ultimate) &&
       (ultimate.has<semantics::ObjectEntityDetails>() ||
+          (ultimate.has<semantics::EntityDetails>() &&
+              ultimate.attrs().test(semantics::Attr::TARGET)) ||
           ultimate.has<semantics::AssocEntityDetails>());
 }
 auto IsVariableHelper::operator()(const Component &x) const -> Result {
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 4bb625bfbc2ca..aa79fd04ac378 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -354,7 +354,10 @@ void CheckHelper::Check(const Symbol &symbol) {
       messages_.Say(
           "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
     }
-    if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) {
+    if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") {
+      // The intrinsic procedure C_FUNLOC() gets a pass on this check.
+    } else if (IsProcedure(symbol) && !IsPureProcedure(symbol) &&
+        IsDummy(symbol)) {
       messages_.Say(
           "A dummy procedure of a pure subprogram must be pure"_err_en_US);
     }
diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90
index b33d843710127..44b0f17339cd9 100644
--- a/flang/module/__fortran_builtins.f90
+++ b/flang/module/__fortran_builtins.f90
@@ -182,7 +182,10 @@
     __builtin_c_ptr_ne = x%__address /= y%__address
   end function
 
-  function __builtin_c_funloc(x)
+  ! Semantics has some special-case code that allows c_funloc()
+  ! to appear in a specification expression and exempts it
+  ! from the requirement that "x" be a pure dummy procedure.
+  pure function __builtin_c_funloc(x)
     type(__builtin_c_funptr) :: __builtin_c_funloc
     external :: x
     __builtin_c_funloc = __builtin_c_funptr(loc(x))
diff --git a/flang/test/Semantics/c_loc01.f90 b/flang/test/Semantics/c_loc01.f90
index 7c9e294172993..83b88d2ebd4b0 100644
--- a/flang/test/Semantics/c_loc01.f90
+++ b/flang/test/Semantics/c_loc01.f90
@@ -4,7 +4,10 @@ module m
   type haslen(L)
     integer, len :: L
   end type
+  integer, target :: targ
  contains
+  subroutine subr
+  end
   subroutine test(assumedType, poly, nclen)
     type(*), target :: assumedType
     class(*), target ::  poly
@@ -17,6 +20,8 @@ subroutine test(assumedType, poly, nclen)
     type(hasLen(1)), target :: clen
     type(hasLen(*)), target :: nclen
     character(2), target :: ch
+    real :: arr1(purefun1(c_loc(targ))) ! ok
+    real :: arr2(purefun2(c_funloc(subr))) ! ok
     !ERROR: C_LOC() argument must be a data pointer or target
     cp = c_loc(notATarget)
     !ERROR: C_LOC() argument must be a data pointer or target
@@ -44,4 +49,12 @@ subroutine test(assumedType, poly, nclen)
     !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(c_funptr) and TYPE(c_ptr)
     cfp = cp
   end
+  pure integer function purefun1(p)
+    type(c_ptr), intent(in) :: p
+    purefun1 = 1
+  end
+  pure integer function purefun2(p)
+    type(c_funptr), intent(in) :: p
+    purefun2 = 1
+  end
 end module