[flang-commits] [flang] bd92bca - [flang] Fix purity testing for generic calls

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-05-24T13:40:25-07:00
New Revision: bd92bca53517bfbce3396d9f87f42fa438e8d1fd

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

LOG: [flang] Fix purity testing for generic calls

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.

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

Added: 
    flang/test/Semantics/doconcurrent09.f90

Modified: 
    flang/lib/Semantics/expression.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index c1417b653720..98816017dbfe 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -1921,7 +1921,10 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
               }};
           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 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
         *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

diff  --git a/flang/test/Semantics/doconcurrent09.f90 b/flang/test/Semantics/doconcurrent09.f90
new file mode 100644
index 000000000000..d783da0e144c
--- /dev/null
+++ b/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