[flang-commits] [PATCH] D126150: [flang] Fix purity testing for generic calls

[Peter Klausler via Phabricator via flang-commits]

This revision was automatically updated to reflect the committed changes.
Closed by commit rGbd92bca53517: [flang] Fix purity testing for generic calls (authored by klausler).

Repository:
  rG LLVM Github Monorepo

CHANGES SINCE LAST ACTION
  https://reviews.llvm.org/D126150/new/

https://reviews.llvm.org/D126150

Files:
  flang/lib/Semantics/expression.cpp
  flang/test/Semantics/doconcurrent09.f90


Index: flang/test/Semantics/doconcurrent09.f90
===================================================================
--- /dev/null
+++ flang/test/Semantics/doconcurrent09.f90
@@ -0,0 +1,47 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Ensure that DO CONCURRENT purity checks apply to specific procedures
+! in the case of calls to generic interfaces.
+module m
+  interface purity
+    module procedure :: ps, ips
+  end interface
+  type t
+   contains
+    procedure :: pb, ipb
+    generic :: purity => pb, ipb
+  end type
+ contains
+  pure subroutine ps(n)
+    integer, intent(in) :: n
+  end subroutine
+  impure subroutine ips(a)
+    real, intent(in) :: a
+  end subroutine
+  pure subroutine pb(x,n)
+    class(t), intent(in) :: x
+    integer, intent(in) :: n
+  end subroutine
+  impure subroutine ipb(x,n)
+    class(t), intent(in) :: x
+    real, intent(in) :: n
+  end subroutine
+end module
+
+program test
+  use m
+  type(t) :: x
+  do concurrent (j=1:1)
+    call ps(1) ! ok
+    call purity(1) ! ok
+    !ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+    call purity(1.)
+    !ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+    call ips(1.)
+    call x%pb(1) ! ok
+    call x%purity(1) ! ok
+    !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+    call x%purity(1.)
+    !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+    call x%ipb(1.)
+  end do
+end program
Index: flang/lib/Semantics/expression.cpp
===================================================================
--- flang/lib/Semantics/expression.cpp
+++ flang/lib/Semantics/expression.cpp
@@ -1921,7 +1921,10 @@
               }};
           auto pair{ResolveGeneric(*sym, arguments, adjustment)};
           sym = pair.first;
-          if (!sym) {
+          if (sym) {
+            // re-resolve the name to the specific binding
+            sc.component.symbol = const_cast<Symbol *>(sym);
+          } else {
             EmitGenericResolutionError(*sc.component.symbol, pair.second);
             return std::nullopt;
           }
@@ -2184,6 +2187,10 @@
         *symbol, arguments, noAdjustment, mightBeStructureConstructor)};
     resolution = pair.first;
     dueToNullActual = pair.second;
+    if (resolution) {
+      // re-resolve name to the specific procedure
+      name.symbol = const_cast<Symbol *>(resolution);
+    }
   }
   if (!resolution) {
     // Not generic, or no resolution; may be intrinsic


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D126150.431779.patch
Type: text/x-patch
Size: 2511 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20220524/e44983ac/attachment-0001.bin>