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

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: vdonaldson.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
Herald added a reviewer: sscalpone.
Herald added a project: All.
klausler requested review of this revision.

The purity or impurity of a call to a generic interface
depends on the attributes of the specific procedure or specific
binding.  Change expression analysis of calls to generic interfaces
to replace the symbol in the parse tree with the specific procedure
or binding; this ensures that later checking for purity in
DO CONCURRENT and other contexts will be accurate.

Remove an "XFAIL" from a test that now passes again with this fix.


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.431207.patch
Type: text/x-patch
Size: 2511 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20220522/be450dd8/attachment.bin>