[flang-commits] [flang] 486be17 - [flang] Catch impure specifics called in DO CONCURRENT
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Jul 17 11:41:15 PDT 2023
Author: Peter Klausler
Date: 2023-07-17T11:41:10-07:00
New Revision: 486be17ddaf639dc13b8df4ba078f2677f0c5829
URL: https://github.com/llvm/llvm-project/commit/486be17ddaf639dc13b8df4ba078f2677f0c5829
DIFF: https://github.com/llvm/llvm-project/commit/486be17ddaf639dc13b8df4ba078f2677f0c5829.diff
LOG: [flang] Catch impure specifics called in DO CONCURRENT
Rework the code used to check for calls to impure procedures in DO CONCURRENT
constructs. The current code wasn't checking the representation of the
procedure references in the strongly typed expressions, so it was missing
calls to impure subprograms made via generic interfaces. While here,
improve error messages, and fix some minor issues exposed by testing the
improved checks.
Differential Revision: https://reviews.llvm.org/D155489
Added:
Modified:
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Semantics/check-do-forall.cpp
flang/module/__fortran_ieee_exceptions.f90
flang/test/Semantics/call11.f90
flang/test/Semantics/doconcurrent01.f90
flang/test/Semantics/doconcurrent09.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 04cc7b3bd793dd..c6f32c08824788 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2361,6 +2361,10 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
attrs.set(characteristics::Procedure::Attr::Elemental);
}
if (call.isSubroutineCall) {
+ if (intrinsicClass == IntrinsicClass::pureSubroutine /* MOVE_ALLOC */ ||
+ intrinsicClass == IntrinsicClass::elementalSubroutine /* MVBITS */) {
+ attrs.set(characteristics::Procedure::Attr::Pure);
+ }
return SpecificCall{
SpecificIntrinsic{
name, characteristics::Procedure{std::move(dummyArgs), attrs}},
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 8ba301d773f604..a1ed4660efde79 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -12,6 +12,7 @@
#include "flang/Evaluate/call.h"
#include "flang/Evaluate/expression.h"
#include "flang/Evaluate/tools.h"
+#include "flang/Evaluate/traverse.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parse-tree-visitor.h"
#include "flang/Parser/tools.h"
@@ -90,9 +91,16 @@ class DoConcurrentBodyEnforce {
: context_{context}, doConcurrentSourcePosition_{
doConcurrentSourcePosition} {}
std::set<parser::Label> labels() { return labels_; }
- template <typename T> bool Pre(const T &) { return true; }
- template <typename T> void Post(const T &) {}
-
+ template <typename T> bool Pre(const T &x) {
+ if (const auto *expr{GetExpr(context_, x)}) {
+ if (auto bad{FindImpureCall(context_.foldingContext(), *expr)}) {
+ context_.Say(currentStatementSourcePosition_,
+ "Impure procedure '%s' may not be referenced in DO CONCURRENT"_err_en_US,
+ *bad);
+ }
+ }
+ return true;
+ }
template <typename T> bool Pre(const parser::Statement<T> &statement) {
currentStatementSourcePosition_ = statement.source;
if (statement.label.has_value()) {
@@ -100,11 +108,21 @@ class DoConcurrentBodyEnforce {
}
return true;
}
-
template <typename T> bool Pre(const parser::UnlabeledStatement<T> &stmt) {
currentStatementSourcePosition_ = stmt.source;
return true;
}
+ bool Pre(const parser::CallStmt &x) {
+ if (x.typedCall.get()) {
+ if (auto bad{FindImpureCall(context_.foldingContext(), *x.typedCall)}) {
+ context_.Say(currentStatementSourcePosition_,
+ "Impure procedure '%s' may not be referenced in DO CONCURRENT"_err_en_US,
+ *bad);
+ }
+ }
+ return true;
+ }
+ template <typename T> void Post(const T &) {}
// C1140 -- Can't deallocate a polymorphic entity in a DO CONCURRENT.
// Deallocation can be caused by exiting a block that declares an allocatable
@@ -271,12 +289,6 @@ class DoConcurrentBodyEnforce {
// not pure, and impure procedures are caught by checks for constraint C1139
void Post(const parser::ProcedureDesignator &procedureDesignator) {
if (auto *name{std::get_if<parser::Name>(&procedureDesignator.u)}) {
- if (name->symbol && !IsPureProcedure(*name->symbol)) {
- SayWithDo(context_, currentStatementSourcePosition_,
- "Call to an impure procedure is not allowed in DO"
- " CONCURRENT"_err_en_US,
- doConcurrentSourcePosition_);
- }
if (name->symbol &&
fromScope(*name->symbol, "__fortran_ieee_exceptions"s)) {
if (name->source == "ieee_set_halting_mode") {
@@ -286,16 +298,6 @@ class DoConcurrentBodyEnforce {
doConcurrentSourcePosition_);
}
}
- } else {
- // C1139: this a procedure component
- auto &component{std::get<parser::ProcComponentRef>(procedureDesignator.u)
- .v.thing.component};
- if (component.symbol && !IsPureProcedure(*component.symbol)) {
- SayWithDo(context_, currentStatementSourcePosition_,
- "Call to an impure procedure component is not allowed"
- " in DO CONCURRENT"_err_en_US,
- doConcurrentSourcePosition_);
- }
}
}
@@ -411,13 +413,11 @@ class DoContext {
void Check(const parser::DoConstruct &doConstruct) {
if (doConstruct.IsDoConcurrent()) {
CheckDoConcurrent(doConstruct);
- return;
- }
- if (doConstruct.IsDoNormal()) {
+ } else if (doConstruct.IsDoNormal()) {
CheckDoNormal(doConstruct);
- return;
+ } else {
+ // TODO: handle the other cases
}
- // TODO: handle the other cases
}
void Check(const parser::ForallStmt &stmt) {
diff --git a/flang/module/__fortran_ieee_exceptions.f90 b/flang/module/__fortran_ieee_exceptions.f90
index 895eee544af0d7..77dc6f85517869 100644
--- a/flang/module/__fortran_ieee_exceptions.f90
+++ b/flang/module/__fortran_ieee_exceptions.f90
@@ -80,14 +80,14 @@ end subroutine ieee_get_halting_mode_0
end interface
interface ieee_get_modes
- subroutine ieee_get_modes_0(modes)
+ pure subroutine ieee_get_modes_0(modes)
import ieee_modes_type
type(ieee_modes_type), intent(out) :: modes
end subroutine ieee_get_modes_0
end interface
interface ieee_get_status
- subroutine ieee_get_status_0(status)
+ pure subroutine ieee_get_status_0(status)
import ieee_status_type
type(ieee_status_type), intent(out) :: status
end subroutine ieee_get_status_0
diff --git a/flang/test/Semantics/call11.f90 b/flang/test/Semantics/call11.f90
index 4307571ba749b8..f4f47407955623 100644
--- a/flang/test/Semantics/call11.f90
+++ b/flang/test/Semantics/call11.f90
@@ -39,7 +39,7 @@ subroutine test
end forall
!ERROR: DO CONCURRENT mask expression may not reference impure procedure 'impure'
do concurrent (j=1:1, impure(j) /= 0) ! C1121
- !ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
a(j) = impure(j) ! C1139
end do
end subroutine
@@ -61,7 +61,7 @@ subroutine test2
end do
!ERROR: DO CONCURRENT mask expression may not reference impure procedure 'impure'
do concurrent (j=1:1, x%tbp_impure(j) /= 0) ! C1121
- !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
a(j) = x%tbp_impure(j) ! C1139
end do
end subroutine
diff --git a/flang/test/Semantics/doconcurrent01.f90 b/flang/test/Semantics/doconcurrent01.f90
index 36595df5a62fb6..7c13a26814e5be 100644
--- a/flang/test/Semantics/doconcurrent01.f90
+++ b/flang/test/Semantics/doconcurrent01.f90
@@ -48,8 +48,7 @@ subroutine do_concurrent_test2(i,j,n,flag)
change team (j)
!ERROR: An image control statement is not allowed in DO CONCURRENT
critical
-!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
- call ieee_get_status(status)
+ call ieee_get_status(status) ! ok
!ERROR: IEEE_SET_HALTING_MODE is not allowed in DO CONCURRENT
call ieee_set_halting_mode(flag, halting)
end critical
@@ -193,6 +192,10 @@ subroutine s7()
pure integer function pf()
end function pf
end interface
+ interface generic
+ impure integer function ipf()
+ end function ipf
+ end interface
type :: procTypeNotPure
procedure(notPureFunc), pointer, nopass :: notPureProcComponent
@@ -223,10 +226,16 @@ end function pf
! This should generate an error
do concurrent (i = 1:10)
-!ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+!ERROR: Impure procedure 'notpureproccomponent' may not be referenced in DO CONCURRENT
ivar = procVarNotPure%notPureProcComponent()
end do
+ ! This should generate an error
+ do concurrent (i = 1:10)
+!ERROR: Impure procedure 'ipf' may not be referenced in DO CONCURRENT
+ ivar = generic()
+ end do
+
contains
integer function notPureFunc()
notPureFunc = 2
diff --git a/flang/test/Semantics/doconcurrent09.f90 b/flang/test/Semantics/doconcurrent09.f90
index d783da0e144c47..2e7a79c4172909 100644
--- a/flang/test/Semantics/doconcurrent09.f90
+++ b/flang/test/Semantics/doconcurrent09.f90
@@ -33,15 +33,15 @@ program test
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
+ !ERROR: Impure procedure 'ips' may not be referenced in DO CONCURRENT
call purity(1.)
- !ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+ !ERROR: Impure procedure 'ips' may not be referenced 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
+ !ERROR: Impure procedure 'ipb' may not be referenced in DO CONCURRENT
call x%purity(1.)
- !ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
+ !ERROR: Impure procedure 'ipb' may not be referenced in DO CONCURRENT
call x%ipb(1.)
end do
end program
More information about the flang-commits
mailing list