Index: flang/include/flang/Evaluate/tools.h =================================================================== --- flang/include/flang/Evaluate/tools.h +++ flang/include/flang/Evaluate/tools.h @@ -1076,6 +1076,41 @@ std::optional> DataConstantConversionExtension( FoldingContext &, const DynamicType &, const Expr &); +/// Is this a variable wrapped in parentheses? +template bool IsParenthesizedVariable(const A &) { return false; } +template bool IsParenthesizedVariable(const Expr &expr) { + if constexpr (common::HasMember, decltype(Expr::u)>) { + if (const auto *parentheses = std::get_if>(&expr.u)) + return IsVariable(parentheses->left()); + return false; + } else { + return std::visit( + [&](const auto &x) { return IsParenthesizedVariable(x); }, expr.u); + } +} + +/// Is there at least an array arugment? +bool HasArrayArgs(ActualArguments &); + +/// Check if the two variables has conflict storage by static analysis. This +/// does not cover the dynamic analysis such as pointer variables or non-compile +/// time indices of array. +/// FIXME: Support indirect storage conflict such as checking the conflict of x +/// and y when x and a are equivalenced and y is associated with a. +bool HasStorageConflict(const Symbol &, const Symbol &); +template +bool HasStorageConflict(const A &x, const B &y) { + if (IsParenthesizedVariable(x) || IsParenthesizedVariable(y)) { + return false; + } + if (const Symbol * xSym{GetLastSymbol(x)}) { + if (const Symbol * ySym{GetLastSymbol(y)}) { + return HasStorageConflict(*xSym, *ySym); + } + } + return false; +} + } // namespace Fortran::evaluate namespace Fortran::semantics { Index: flang/lib/Evaluate/tools.cpp =================================================================== --- flang/lib/Evaluate/tools.cpp +++ flang/lib/Evaluate/tools.cpp @@ -1125,6 +1125,53 @@ IsAllocatableOrPointerObject(expr, context); } +bool HasArrayArgs(ActualArguments &actuals) { + for (const auto &arg : actuals) { + if (arg && arg.value().Rank() > 0) { + return true; + } + } + return false; +} + +bool HasStorageConflict(const Symbol &x, const Symbol &y) { + if (x.GetUltimate() == y.GetUltimate() || + semantics::ResolveAssociations(x) == semantics::ResolveAssociations(y)) { + return true; + } + auto checkEquivalence = [&](const Symbol &a, const Symbol &b) -> bool { + if (const semantics::EquivalenceSet * + set{semantics::FindEquivalenceSet(a)}) { + for (const semantics::EquivalenceObject &object : *set) { + if (object.symbol.GetUltimate() == b.GetUltimate()) { + return true; + } + } + } + return false; + }; + if (checkEquivalence(x, y) || checkEquivalence(y, x)) { + return true; + } + if (const Symbol * blockX{semantics::FindCommonBlockContaining(x)}) { + if (const Symbol * blockY{semantics::FindCommonBlockContaining(y)}) { + if (blockX->name() == blockY->name()) { + std::function getRootUseSymbol = + [&](const Symbol &sym) -> const Symbol & { + if (const auto *useSym{sym.detailsIf()}) { + return getRootUseSymbol(useSym->symbol()); + } + return sym; + }; + if (getRootUseSymbol(x).offset() == getRootUseSymbol(y).offset()) { + return true; + } + } + } + } + return false; +} + } // namespace Fortran::evaluate namespace Fortran::semantics { Index: flang/lib/Lower/ConvertExpr.cpp =================================================================== --- flang/lib/Lower/ConvertExpr.cpp +++ flang/lib/Lower/ConvertExpr.cpp @@ -337,25 +337,6 @@ return x.Rank() != 0; } -/// Is this a variable wrapped in parentheses? -template -static bool isParenthesizedVariable(const A &) { - return false; -} -template -static bool isParenthesizedVariable(const Fortran::evaluate::Expr &expr) { - using ExprVariant = decltype(Fortran::evaluate::Expr::u); - using Parentheses = Fortran::evaluate::Parentheses; - if constexpr (Fortran::common::HasMember) { - if (const auto *parentheses = std::get_if(&expr.u)) - return Fortran::evaluate::IsVariable(parentheses->left()); - return false; - } else { - return std::visit([&](const auto &x) { return isParenthesizedVariable(x); }, - expr.u); - } -} - /// Does \p expr only refer to symbols that are mapped to IR values in \p symMap /// ? static bool allSymbolsInExprPresentInMap(const Fortran::lower::SomeExpr &expr, @@ -2602,7 +2583,7 @@ // variable (see R1524). For expressions, a variable storage must not be // argument associated since it could be modified inside the call, or the // variable could also be modified by other means during the call. - if (!isParenthesizedVariable(expr)) + if (!Fortran::evaluate::IsParenthesizedVariable(expr)) return genExtAddr(expr); if (expr.Rank() > 0) return asArray(expr); @@ -4735,7 +4716,7 @@ PushSemantics(ConstituentSemantics::DataValue); CC cc = genarr(x); mlir::Location loc = getLoc(); - if (isParenthesizedVariable(x)) { + if (Fortran::evaluate::IsParenthesizedVariable(x)) { // Parenthesised variables are lowered to a reference to the variable // storage. When passing it as an argument, a copy must be passed. return [=](IterSpace iters) -> ExtValue { Index: flang/lib/Semantics/check-call.cpp =================================================================== --- flang/lib/Semantics/check-call.cpp +++ flang/lib/Semantics/check-call.cpp @@ -822,13 +822,7 @@ std::optional shape; std::string shapeName; int index{0}; - bool hasArrayArg{false}; - for (const auto &arg : actuals) { - if (arg && arg.value().Rank() > 0) { - hasArrayArg = true; - break; - } - } + bool hasArrayArg{evaluate::HasArrayArgs(actuals)}; for (const auto &arg : actuals) { const auto &dummy{proc.dummyArguments.at(index++)}; if (arg) { @@ -951,5 +945,28 @@ msgs->Annex(std::move(buffer)); } } + if (proc.IsElemental() && evaluate::HasArrayArgs(actuals) && + (messages.empty() || !messages.messages()->AnyFatalError())) { + for (int i = 0; i < (int)actuals.size(); i++) { + for (int j = i + 1; j < (int)actuals.size(); j++) { + if (actuals[i].has_value() && actuals[j].has_value()) { + evaluate::ActualArgument &arg1{actuals[i].value()}; + evaluate::ActualArgument &arg2{actuals[j].value()}; + auto *expr1{arg1.UnwrapExpr()}; + auto *expr2{arg2.UnwrapExpr()}; + if (arg1.dummyIntent() == common::Intent::Out || + arg1.dummyIntent() == common::Intent::InOut || + arg2.dummyIntent() == common::Intent::Out || + arg2.dummyIntent() == common::Intent::InOut) { + if (evaluate::HasStorageConflict(*expr1, *expr2)) { + messages.Say( + "Actual argument %s might interfere with actual argument %s"_warn_en_US, + expr1->AsFortran(), expr2->AsFortran()); + } + } + } + } + } + } } } // namespace Fortran::semantics Index: flang/test/Semantics/call27.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/call27.f90 @@ -0,0 +1,110 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 + +! Test the storage conflict of elemental procedure + +subroutine sub0() + integer :: a(3), b(3), x(3), y(3) + common /blk/ a, b + common /blk/ x, y + + call elemsub(x, a(3:1:-1), b, y(3:1:-1)) ! no warning +contains + elemental subroutine elemsub(a, b, c, d) + integer, intent(in) :: b, d + integer, intent(out) :: a, c + a = b + 1 + c = d + 1 + end +end + +module mod1 + integer :: a(3), b(3) + common /blk2/ a, b +end + +subroutine sub1() + use mod1 + integer :: x(3), y(3) + common /blk2/ x, y + + !WARNING: Actual argument x might interfere with actual argument a(3_8:1_8:-1_8) + !WARNING: Actual argument b might interfere with actual argument y(3_8:1_8:-1_8) + call elemsub(x, a(3:1:-1), b, y(3:1:-1)) +contains + elemental subroutine elemsub(a, b, c, d) + integer, intent(in) :: b, d + integer, intent(out) :: a, c + a = b + 1 + c = d + 1 + end +end + +module mod2 + use mod1 + integer :: x(3), y(3) + common /blk2/ x, y +end + +subroutine sub2() + use mod2 + + !WARNING: Actual argument x might interfere with actual argument a(3_8:1_8:-1_8) + !WARNING: Actual argument b might interfere with actual argument y(3_8:1_8:-1_8) + call elemsub(x, a(3:1:-1), b, y(3:1:-1)) +contains + elemental subroutine elemsub(a, b, c, d) + integer, intent(in) :: b, d + integer, intent(out) :: a, c + a = b + 1 + c = d + 1 + end +end + +subroutine sub3() + integer :: array(3) = (/1,2,3/), array2(3) = (/1,2,3/) + associate (arr => array, arr2 => array2) + !WARNING: Actual argument array might interfere with actual argument arr(3_8:1_8:-1_8) + !WARNING: Actual argument arr2 might interfere with actual argument array2(3_8:1_8:-1_8) + call elemsub(array, arr(3:1:-1), arr2, array2(3:1:-1)) + end associate +contains + elemental subroutine elemsub(a, b, c, d) + integer, intent(in) :: b, d + integer, intent(out) :: a, c + a = b + 1 + c = d + 1 + end +end + +subroutine sub4() + integer :: array(3) = (/1,2,3/), array2(3) = (/1,2,3/) + integer :: arr(3), arr2(3) + equivalence(array, arr) + equivalence(array2, arr2) + + !WARNING: Actual argument array might interfere with actual argument arr(3_8:1_8:-1_8) + !WARNING: Actual argument arr2 might interfere with actual argument array2(3_8:1_8:-1_8) + call elemsub(array, arr(3:1:-1), arr2, array2(3:1:-1)) +contains + elemental subroutine elemsub(a, b, c, d) + integer, intent(in) :: b, d + integer, intent(out) :: a, c + a = b + 1 + c = d + 1 + end +end + +subroutine sub5() + integer :: array(3) = (/1,2,3/), array2(3) = (/1,2,3/) + + !WARNING: Actual argument array might interfere with actual argument array(3_8:1_8:-1_8) + !WARNING: Actual argument array2 might interfere with actual argument array2(3_8:1_8:-1_8) + call elemsub(array, array(3:1:-1), array2, array2(3:1:-1)) +contains + elemental subroutine elemsub(a, b, c, d) + integer, intent(in) :: b, d + integer, intent(out) :: a, c + a = b + 1 + c = d + 1 + end +end