[flang][Semantics] Introduce -Wpass-global-variable warning

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<LanguageFeature, LanguageFeature_enumSize>;
 using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;

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<evaluate::SomeType> &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<CommonBlockDetails>().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);
         }
       }
     }

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<ObjectEntityDetails>(&details_)}) {
     return &details->shape();
+  } else if (const auto *details{std::get_if<UseDetails>(&details_)}) {
+    return details->symbol().GetShape();
   } else {
     return nullptr;
   }

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.
 

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

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