diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h index 51364d552be64..494995e8844b6 100644 --- a/flang/include/flang/Support/Fortran-features.h +++ b/flang/include/flang/Support/Fortran-features.h @@ -79,7 +79,7 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable, CompatibleDeclarationsFromDistinctModules, ConstantIsContiguous, NullActualForDefaultIntentAllocatable, UseAssociationIntoSameNameSubprogram, HostAssociatedIntentOutInSpecExpr, NonVolatilePointerToVolatile, - RealConstantWidening, VolatileOrAsynchronousTemporary) + RealConstantWidening, VolatileOrAsynchronousTemporary, PassGlobalVariable) using LanguageFeatures = EnumSet; using UsageWarnings = EnumSet; diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 81c53aaf9e339..28b4c8f6cef30 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -26,8 +26,111 @@ namespace characteristics = Fortran::evaluate::characteristics; namespace Fortran::semantics { +// Raise warnings for some dangerous context of passing global variables +// - any variable from common blocks except +// - 1-element arrays being single member of COMMON +// - passed to intrinsic +// - passed to PURE procedure +// - passed to VALUE dummy argument +// - avy variable from module except +// - having attribute PARAMETER or PRIVATE +// - having DERIVED type +// - passed to intrinsic +// - passed to PURE procedure +// - passed to VALUE dummy argument +// - being arrays having 1-D rank and is not having ALLOCATABLE or POINTER or +// VOLATILE attributes +static void CheckPassGlobalVariable( + const evaluate::Expr &actual, + const parser::ContextualMessages &messages, SemanticsContext &context, + evaluate::FoldingContext &foldingContext, + const evaluate::SpecificIntrinsic *intrinsic, + const characteristics::Procedure *procedure, bool dummyIsValue = false) { + const Symbol *actualFirstSymbol{evaluate::GetFirstSymbol(actual)}; + if (!actualFirstSymbol) { + return; + } + bool warn{false}; + std::string ownerType{""}; + std::string ownerName{""}; + if (actualFirstSymbol->flags().test(Symbol::Flag::InCommonBlock)) { + const Symbol *common{FindCommonBlockContaining(*actualFirstSymbol)}; + ownerType = "COMMON"; + ownerName = common->name().ToString(); + if (intrinsic) { + // intrinsics can not change any global variable + } else if (procedure && procedure->IsPure()) { + // pure procedures can not affect global state + } else if (dummyIsValue) { + // copy of variable is passing + } else if (!(actualFirstSymbol->Rank() == 1 && + actualFirstSymbol->offset() == 0)) { + warn = true; + } else if (actualFirstSymbol->Rank() == 1) { + bool actualIsArrayElement{IsArrayElement(actual) != nullptr}; + if (!actualIsArrayElement) { + warn = true; + } + if (const ArraySpec *dims{actualFirstSymbol->GetShape()}; + dims && dims->IsExplicitShape()) { + // tricky way to check that array has only one element + if (!((*dims)[0].lbound().GetExplicit() == + (*dims)[0].ubound().GetExplicit())) { + warn = true; + } + } + if (common->get().objects().size() > 1) { + warn = true; + } + } + } else if (const auto &owner{actualFirstSymbol->GetUltimate().owner()}; + owner.IsModule() || owner.IsSubmodule()) { + const Scope *module{FindModuleContaining(owner)}; + ownerType = "MODULE"; + ownerName = module->GetName()->ToString(); + if (actualFirstSymbol->attrs().test(Attr::PARAMETER) || + actualFirstSymbol->attrs().test(Attr::PRIVATE)) { + // parameter can not be changed anywhere + // private may be used for singletons + } else if (auto type{characteristics::TypeAndShape::Characterize( + actualFirstSymbol, foldingContext)}; + type->type().category() == TypeCategory::Derived) { + // derived types are easy to maintain + } else if (intrinsic) { + // intrinsics can not change any global variable + } else if (procedure && procedure->IsPure()) { + // pure procedures can not affect global state + } else if (dummyIsValue) { + // copy of variable is passing + } else if (actualFirstSymbol->Rank() != 1) { + warn = true; + } else if (!actualFirstSymbol->attrs().test(Attr::ALLOCATABLE) && + !actualFirstSymbol->attrs().test(Attr::POINTER) && + !actualFirstSymbol->attrs().test(Attr::VOLATILE)) { + bool actualIsArrayElement{IsArrayElement(actual) != nullptr}; + if (!actualIsArrayElement) { + warn = true; + } + if (const ArraySpec *dims{actualFirstSymbol->GetShape()}; + dims && dims->IsExplicitShape()) { + // tricky way to check that array has only one element + if (!((*dims)[0].lbound().GetExplicit() == + (*dims)[0].ubound().GetExplicit())) { + warn = true; + } + } + } + } + if (warn) { + context.Warn(common::UsageWarning::PassGlobalVariable, messages.at(), + "Passing global variable '%s' from %s '%s' as function argument"_warn_en_US, + actualFirstSymbol->name(), ownerType, ownerName); + } +} + static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, - parser::ContextualMessages &messages, SemanticsContext &context) { + parser::ContextualMessages &messages, SemanticsContext &context, + evaluate::FoldingContext &foldingContext) { auto restorer{ messages.SetLocation(arg.sourceLocation().value_or(messages.at()))}; if (auto kw{arg.keyword()}) { @@ -118,6 +221,11 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, } } } + + if (const auto *expr{arg.UnwrapExpr()}) { + CheckPassGlobalVariable(*expr, messages, context, foldingContext, + /*intrinsic=*/nullptr, /*procedure=*/nullptr); + } } // F'2023 15.5.2.12p1: "Sequence association only applies when the dummy @@ -1153,6 +1261,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, messages.Say( "%VAL argument must be a scalar numeric or logical expression"_err_en_US); } + + CheckPassGlobalVariable(actual, messages, context, foldingContext, intrinsic, + &procedure, dummyIsValue); } static void CheckProcedureArg(evaluate::ActualArgument &arg, @@ -2409,7 +2520,7 @@ bool CheckArguments(const characteristics::Procedure &proc, auto restorer{messages.SetMessages(implicitBuffer)}; for (auto &actual : actuals) { if (actual) { - CheckImplicitInterfaceArg(*actual, messages, context); + CheckImplicitInterfaceArg(*actual, messages, context, foldingContext); } } } diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp index 6152f61fafd7f..3432b1e235618 100644 --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -453,6 +453,8 @@ bool Symbol::IsFuncResult() const { const ArraySpec *Symbol::GetShape() const { if (const auto *details{std::get_if(&details_)}) { return &details->shape(); + } else if (const auto *details{std::get_if(&details_)}) { + return details->symbol().GetShape(); } else { return nullptr; } diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90 index b9b463a44979d..c41b736329c3b 100644 --- a/flang/test/Semantics/call05.f90 +++ b/flang/test/Semantics/call05.f90 @@ -1,4 +1,4 @@ -! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic +! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Wno-pass-global-variable ! Test 15.5.2.5 constraints and restrictions for POINTER & ALLOCATABLE ! arguments when both sides of the call have the same attributes. diff --git a/flang/test/Semantics/call07.f90 b/flang/test/Semantics/call07.f90 index 7e29fb74dd615..8352bee6f8a5e 100644 --- a/flang/test/Semantics/call07.f90 +++ b/flang/test/Semantics/call07.f90 @@ -1,4 +1,4 @@ -! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic +! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Wno-pass-global-variable ! Test 15.5.2.7 constraints and restrictions for POINTER dummy arguments. module m diff --git a/flang/test/Semantics/pass-global-variables01.f90 b/flang/test/Semantics/pass-global-variables01.f90 new file mode 100644 index 0000000000000..d373b43489fe9 --- /dev/null +++ b/flang/test/Semantics/pass-global-variables01.f90 @@ -0,0 +1,169 @@ +!RUN: %python %S/test_errors.py %s %flang_fc1 -Werror -Wpass-global-variable +module explicit_test_mod + implicit none (type, external) + integer :: i1 + integer :: i2(1) + integer :: i3(3) + integer, allocatable :: ia(:) + + real :: x1, y1 + real :: x2, y2 + real :: z, z2 + common /xy1/ x1, y1(1) + common /xy2/ x2(1), y2 + common /fm/ z(1) + common /fm_bad/ z2(5) +contains + subroutine pass_int(i) + integer, intent(inout) :: i + end subroutine pass_int + subroutine pass_int_1d(i) + integer, intent(inout) :: i(*) + end subroutine pass_int_1d + subroutine pass_real(r) + real, intent(inout) :: r + end subroutine pass_real + subroutine pass_real_1d(r) + real, intent(inout) :: r(*) + end subroutine pass_real_1d + subroutine explicit_test(n) + integer, intent(in) :: n + + !WARNING: Passing global variable 'i1' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call pass_int(i1) !< warn: basic type + call pass_int(i2(1)) !< ok: shape == [1] + call pass_int(i2(n)) !< ok: shape == [1] + !WARNING: Passing global variable 'i3' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call pass_int(i3(1)) !< warn: shape /= [1] + !WARNING: Passing global variable 'i3' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call pass_int(i3(n)) !< warn: shape /= [1] + !WARNING: Passing global variable 'i2' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call pass_int_1d(i2) !< warn: whole array is passed + call pass_int_1d(i2(n:n+3)) !< ok: subrange of array + !WARNING: Passing global variable 'i3' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call pass_int_1d(i3) !< warn: shape /= [1] + !WARNING: Passing global variable 'i3' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call pass_int_1d(i3(n:n+3)) !< warn: shape /= [1] + call pass_int(ia(1)) !< ok: allocatable + call pass_int(ia(n)) !< ok: allocatable + call pass_int_1d(ia) !< ok: allocatable + call pass_int_1d(ia(n:n+3)) !< ok: allocatable + + !WARNING: Passing global variable 'x1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call pass_real(x1) !< warn: x1 from common + !WARNING: Passing global variable 'y1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call pass_real_1d(y1) !< warn: y1 from common or offset /= 0 + !WARNING: Passing global variable 'y1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call pass_real(y1(1)) !< warn: offset /= 0 + !WARNING: Passing global variable 'y1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call pass_real(y1(n)) !< warn: offset /= 0 + !WARNING: Passing global variable 'y1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call pass_real_1d(y1(n:n+3)) !< warn: offset /= 0 + + !WARNING: Passing global variable 'y2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call pass_real(y2) !< warn: offset /= 0 + !WARNING: Passing global variable 'x2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call pass_real_1d(x2) !< warn: more than one variable in common block + !WARNING: Passing global variable 'x2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call pass_real(x2(1)) !< warn: more than one variable in common block + !WARNING: Passing global variable 'x2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call pass_real(x2(n)) !< warn: more than one variable in common block + !WARNING: Passing global variable 'x2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call pass_real_1d(x2(n:n+3)) !< warn: more than one variable in common block + + !WARNING: Passing global variable 'z' from COMMON 'fm' as function argument [-Wpass-global-variable] + call pass_real_1d(z) !< warn: z from common + call pass_real(z(1)) !< ok: single element/begin of mem block + call pass_real(z(n)) !< ok: single element/begin of mem block + call pass_real_1d(z(n:n+3)) !< ok: mem block + + !WARNING: Passing global variable 'z2' from COMMON 'fm_bad' as function argument [-Wpass-global-variable] + call pass_real_1d(z2) !< warn: shape /= [1] + !WARNING: Passing global variable 'z2' from COMMON 'fm_bad' as function argument [-Wpass-global-variable] + call pass_real(z2(1)) !< warn: shape /= [1] + !WARNING: Passing global variable 'z2' from COMMON 'fm_bad' as function argument [-Wpass-global-variable] + call pass_real(z2(n)) !< warn: shape /= [1] + !WARNING: Passing global variable 'z2' from COMMON 'fm_bad' as function argument [-Wpass-global-variable] + call pass_real_1d(z2(n:n+3)) !< warn: shape /= [1] + end subroutine explicit_test +end module explicit_test_mod + +subroutine module_test(n) + use explicit_test_mod, only: i1, i2, i3, ia + implicit none (type, external) + integer, intent(in) :: n + + external :: imp_pass_int, imp_pass_int_1d + + !WARNING: Passing global variable 'i1' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call imp_pass_int(i1) !< warn: i1 from common + call imp_pass_int(i2(1)) !< ok: single element/begin of mem block + call imp_pass_int(i2(n)) !< ok: single element/begin of mem block + !WARNING: Passing global variable 'i3' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call imp_pass_int(i3(1)) !< warn: shape /= [1] + !WARNING: Passing global variable 'i3' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call imp_pass_int(i3(n)) !< warn: shape /= [1] + call imp_pass_int(ia(1)) !< ok: allocatable + call imp_pass_int(ia(n)) !< ok: allocatable + + !WARNING: Passing global variable 'i2' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call imp_pass_int_1d(i2) !< warn: i2 from module + call imp_pass_int_1d(i2(n:n+3)) !< ok: mem block + !WARNING: Passing global variable 'i3' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call imp_pass_int_1d(i3) !< warn: i3 from module & shape /= [1] + !WARNING: Passing global variable 'i3' from MODULE 'explicit_test_mod' as function argument [-Wpass-global-variable] + call imp_pass_int_1d(i3(n:n+3)) !< warn: shape /= [1] + call imp_pass_int_1d(ia) !< ok: allocatable + call imp_pass_int_1d(ia(n:n+3)) !< ok: allocatable +end subroutine module_test + +subroutine implicit_test(n) + implicit none (type, external) + integer, intent(in) :: n + real :: x1, y1 + real :: x2, y2 + real :: z, z2 + common /xy1/ x1, y1(1) + common /xy2/ x2(1), y2 + common /fm/ z(1) + common /fm_bad/ z2(5) + + external :: imp_pass_real, imp_pass_real_1d + + !WARNING: Passing global variable 'x1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call imp_pass_real(x1) !< warn: x1 from common + !WARNING: Passing global variable 'y1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call imp_pass_real_1d(y1) !< warn: y1 from common and offset /= 0 + !WARNING: Passing global variable 'y1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call imp_pass_real(y1(1)) !< warn: offset /= 0 + !WARNING: Passing global variable 'y1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call imp_pass_real(y1(n)) !< warn: offset /= 0 + !WARNING: Passing global variable 'y1' from COMMON 'xy1' as function argument [-Wpass-global-variable] + call imp_pass_real_1d(y1(n:n+3)) !< warn: offset /= 0 + + !WARNING: Passing global variable 'y2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call imp_pass_real(y2) !< warn: y2 from common and offset /= 0 + !WARNING: Passing global variable 'x2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call imp_pass_real_1d(x2) !< warn: x2 from common + !WARNING: Passing global variable 'x2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call imp_pass_real(x2(1)) !< warn: more than one variable in common + !WARNING: Passing global variable 'x2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call imp_pass_real(x2(n)) !< warn: more than one variable in common + !WARNING: Passing global variable 'x2' from COMMON 'xy2' as function argument [-Wpass-global-variable] + call imp_pass_real_1d(x2(n:n+3)) !< warn: more than one variable in common + + !WARNING: Passing global variable 'z' from COMMON 'fm' as function argument [-Wpass-global-variable] + call imp_pass_real_1d(z) !< warn: z from common + call imp_pass_real(z(1)) !< ok: single element/begin of mem block + call imp_pass_real(z(n)) !< ok: single element/begin of mem block + call imp_pass_real_1d(z(n:n+3)) !< ok: mem block + + !WARNING: Passing global variable 'z2' from COMMON 'fm_bad' as function argument [-Wpass-global-variable] + call imp_pass_real_1d(z2) !< warn: z2 from common, shape /= [1] + !WARNING: Passing global variable 'z2' from COMMON 'fm_bad' as function argument [-Wpass-global-variable] + call imp_pass_real(z2(1)) !< warn: shape /= [1] + !WARNING: Passing global variable 'z2' from COMMON 'fm_bad' as function argument [-Wpass-global-variable] + call imp_pass_real(z2(n)) !< warn: shape /= [1] + !WARNING: Passing global variable 'z2' from COMMON 'fm_bad' as function argument [-Wpass-global-variable] + call imp_pass_real_1d(z2(n:n+3)) !< warn: shape /= [1] +end subroutine implicit_test diff --git a/flang/test/Semantics/pass-global-variables02.f90 b/flang/test/Semantics/pass-global-variables02.f90 new file mode 100644 index 0000000000000..46733665bfef8 --- /dev/null +++ b/flang/test/Semantics/pass-global-variables02.f90 @@ -0,0 +1,61 @@ +!RUN: %python %S/test_errors.py %s %flang_fc1 -Werror -Wpass-global-variable +module test_mod + implicit none (type, external) + + type :: wt + integer :: ival + end type wt + type :: qt + type(wt) :: w + end type qt + type(wt) :: w(2) + type(qt) :: q + + integer, parameter :: ipar = 1 + integer, private :: ipri + integer, public :: ipub + + common /ex/ ic + integer :: ic + +contains + subroutine pass_int_in(i) + integer, intent(in) :: i + end subroutine pass_int_in + subroutine pass_int(i) + integer, intent(inout) :: i + end subroutine pass_int + pure subroutine pure_int(i) + integer, intent(inout) :: i + end subroutine pure_int + subroutine pass_ival(i) + integer, value :: i + end subroutine pass_ival + subroutine pass_qt(q) + type(qt), intent(in) :: q + end subroutine pass_qt + + subroutine tests() + + call pass_ival(ipub) !< ok: pass to value + call pass_int_in(ipar) !< ok: pass parameter + call pass_int(ipri) !< ok: pass private + !WARNING: Passing global variable 'ipub' from MODULE 'test_mod' as function argument [-Wpass-global-variable] + call pass_int(ipub) !< warn: pass public + call pure_int(ipub) !< ok: pass to pure + call pass_int(w(1)%ival) !< ok: comes from derived + call pass_qt(q) !< ok: derived + + ipub = iand(ipub, ipar) !< ok: passed to intrinsic + + call pass_ival(ic) !< ok: passed to value + !WARNING: Passing global variable 'ic' from COMMON 'ex' as function argument [-Wpass-global-variable] + call pass_int_in(ic) !< warn: intent(in) does not guarantee that ic is not changing during call + !WARNING: Passing global variable 'ic' from COMMON 'ex' as function argument [-Wpass-global-variable] + call pass_int(ic) !< warn: global variable may be changed during call + call pure_int(ic) !< ok: pure keeps value + + ic = iand(ic, ic) !< ok: passed to intrinsic + + end subroutine tests +end module test_mod diff --git a/flang/test/Semantics/stmt-func02.f90 b/flang/test/Semantics/stmt-func02.f90 index 10166a0abf7b1..04f643356f55a 100644 --- a/flang/test/Semantics/stmt-func02.f90 +++ b/flang/test/Semantics/stmt-func02.f90 @@ -1,4 +1,4 @@ -! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic +! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Wno-pass-global-variable module m1 contains real function rf2(x) diff --git a/flang/unittests/Common/FortranFeaturesTest.cpp b/flang/unittests/Common/FortranFeaturesTest.cpp index 9408da0361e1d..72946f5cb316b 100644 --- a/flang/unittests/Common/FortranFeaturesTest.cpp +++ b/flang/unittests/Common/FortranFeaturesTest.cpp @@ -556,6 +556,9 @@ TEST(FortranFeaturesTest, CamelCaseToLowerCaseHyphenated) { EXPECT_EQ(CamelCaseToLowerCaseHyphenated( EnumToString(UsageWarning::NonVolatilePointerToVolatile)), "non-volatile-pointer-to-volatile"); + EXPECT_EQ(CamelCaseToLowerCaseHyphenated( + EnumToString(UsageWarning::PassGlobalVariable)), + "pass-global-variable"); } TEST(FortranFeaturesTest, HintLanguageControlFlag) {