diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2361,6 +2361,10 @@ 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 --- 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 @@ : context_{context}, doConcurrentSourcePosition_{ doConcurrentSourcePosition} {} std::set labels() { return labels_; } - template bool Pre(const T &) { return true; } - template void Post(const T &) {} - + template 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 bool Pre(const parser::Statement &statement) { currentStatementSourcePosition_ = statement.source; if (statement.label.has_value()) { @@ -100,11 +108,21 @@ } return true; } - template bool Pre(const parser::UnlabeledStatement &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 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 @@ // not pure, and impure procedures are caught by checks for constraint C1139 void Post(const parser::ProcedureDesignator &procedureDesignator) { if (auto *name{std::get_if(&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 @@ doConcurrentSourcePosition_); } } - } else { - // C1139: this a procedure component - auto &component{std::get(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 @@ 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 --- a/flang/module/__fortran_ieee_exceptions.f90 +++ b/flang/module/__fortran_ieee_exceptions.f90 @@ -80,14 +80,14 @@ 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 --- a/flang/test/Semantics/call11.f90 +++ b/flang/test/Semantics/call11.f90 @@ -39,7 +39,7 @@ 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 @@ 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 --- a/flang/test/Semantics/doconcurrent01.f90 +++ b/flang/test/Semantics/doconcurrent01.f90 @@ -48,8 +48,7 @@ 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 @@ 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 @@ ! 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 --- a/flang/test/Semantics/doconcurrent09.f90 +++ b/flang/test/Semantics/doconcurrent09.f90 @@ -33,15 +33,15 @@ 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