[flang] Implemented 2 Semantic checks for DATA statement and fixed a few bugs

Summary
  - Implemented C876, C877
  - Fixed IsConstantExpr to check C879
  - Fixed bugs in few test cases - data01.f90, block-data01.f90,
  pre-fir-tree02.f90
  - Modified implementation of C8106 to identify all automatic objects
  and modified equivalence01.f90 to reflect the changes

Differential Revision: https://reviews.llvm.org/D78424

flang/include/flang/Semantics/tools.h

@@ -146,6 +146,8 @@ bool IsFinalizable(const Symbol &);
 bool IsFinalizable(const DerivedTypeSpec &);
 bool HasImpureFinal(const DerivedTypeSpec &);
 bool IsCoarray(const Symbol &);
+bool IsInBlankCommon(const Symbol &);
+bool IsAutomaticObject(const Symbol &);
 inline bool IsAssumedSizeArray(const Symbol &symbol) {
   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
   return details && details->IsAssumedSize();

flang/lib/Evaluate/check-expression.cpp

@@ -59,7 +59,9 @@ public:
     }
     return true;
   }
-
+  bool operator()(const Component &component) const {
+    return (*this)(component.base());
+  }
   // Forbid integer division by zero in constants.
   template <int KIND>
   bool operator()(

flang/lib/Semantics/check-data.cpp

@@ -56,22 +56,69 @@ public:
   }
   bool operator()(const evaluate::Component &component) {
     hasComponent_ = true;
-    return (*this)(component.base());
+    const Symbol &lastSymbol{component.GetLastSymbol()};
+    if (isPointerAllowed_) {
+      if (IsPointer(lastSymbol) && hasSubscript_) { // C877
+        context_.Say(source_,
+            "Rightmost data object pointer '%s' must not be subscripted"_err_en_US,
+            lastSymbol.name().ToString());
+        return false;
+      }
+      RestrictPointer();
+    } else {
+      if (IsPointer(lastSymbol)) { // C877
+        context_.Say(source_,
+            "Data object must not contain pointer '%s' as a non-rightmost part"_err_en_US,
+            lastSymbol.name().ToString());
+        return false;
+      }
+    }
+    if (!isFirstSymbolChecked_) {
+      isFirstSymbolChecked_ = true;
+      if (!CheckFirstSymbol(component.GetFirstSymbol())) {
+        return false;
+      }
+    }
+    return (*this)(component.base()) && (*this)(lastSymbol);
+  }
+  bool operator()(const evaluate::ArrayRef &arrayRef) {
+    hasSubscript_ = true;
+    return (*this)(arrayRef.base()) && (*this)(arrayRef.subscript());
+  }
+  bool operator()(const evaluate::Substring &substring) {
+    hasSubscript_ = true;
+    return (*this)(substring.parent()) && (*this)(substring.lower()) &&
+        (*this)(substring.upper());
+  }
+  bool operator()(const evaluate::CoarrayRef &) { // C874
+    hasSubscript_ = true;
+    context_.Say(
+        source_, "Data object must not be a coindexed variable"_err_en_US);
+    return false;
+  }
+  bool operator()(const evaluate::Symbol &symbol) {
+    if (!isFirstSymbolChecked_) {
+      return CheckFirstSymbol(symbol) && CheckAnySymbol(symbol);
+    } else {
+      return CheckAnySymbol(symbol);
+    }
   }
   bool operator()(const evaluate::Subscript &subs) {
-    hasSubscript_ = true;
+    DataVarChecker subscriptChecker{context_, source_};
+    subscriptChecker.RestrictPointer();
     return std::visit(
-        common::visitors{
-            [&](const evaluate::IndirectSubscriptIntegerExpr &expr) {
-              return CheckSubscriptExpr(expr);
-            },
-            [&](const evaluate::Triplet &triplet) {
-              return CheckSubscriptExpr(triplet.lower()) &&
-                  CheckSubscriptExpr(triplet.upper()) &&
-                  CheckSubscriptExpr(triplet.stride());
-            },
-        },
-        subs.u);
+               common::visitors{
+                   [&](const evaluate::IndirectSubscriptIntegerExpr &expr) {
+                     return CheckSubscriptExpr(expr);
+                   },
+                   [&](const evaluate::Triplet &triplet) {
+                     return CheckSubscriptExpr(triplet.lower()) &&
+                         CheckSubscriptExpr(triplet.upper()) &&
+                         CheckSubscriptExpr(triplet.stride());
+                   },
+               },
+               subs.u) &&
+        subscriptChecker(subs.u);
   }
   template <typename T>
   bool operator()(const evaluate::FunctionRef<T> &) const { // C875
@@ -79,11 +126,7 @@ public:
         "Data object variable must not be a function reference"_err_en_US);
     return false;
   }
-  bool operator()(const evaluate::CoarrayRef &) const { // C874
-    context_.Say(
-        source_, "Data object must not be a coindexed variable"_err_en_US);
-    return false;
-  }
+  void RestrictPointer() { isPointerAllowed_ = false; }
 
 private:
   bool CheckSubscriptExpr(
@@ -104,21 +147,71 @@ private:
       return true;
     }
   }
+  bool CheckFirstSymbol(const Symbol &symbol);
+  bool CheckAnySymbol(const Symbol &symbol);
 
   SemanticsContext &context_;
   parser::CharBlock source_;
   bool hasComponent_{false};
   bool hasSubscript_{false};
+  bool isPointerAllowed_{true};
+  bool isFirstSymbolChecked_{false};
 };
 
-// TODO: C876, C877, C879
+bool DataVarChecker::CheckFirstSymbol(const Symbol &symbol) { // C876
+  const Scope &scope{context_.FindScope(source_)};
+  if (IsDummy(symbol)) {
+    context_.Say(source_,
+        "Data object part '%s' must not be a dummy argument"_err_en_US,
+        symbol.name().ToString());
+  } else if (IsFunction(symbol)) {
+    context_.Say(source_,
+        "Data object part '%s' must not be a function name"_err_en_US,
+        symbol.name().ToString());
+  } else if (symbol.IsFuncResult()) {
+    context_.Say(source_,
+        "Data object part '%s' must not be a function result"_err_en_US,
+        symbol.name().ToString());
+  } else if (IsHostAssociated(symbol, scope)) {
+    context_.Say(source_,
+        "Data object part '%s' must not be accessed by host association"_err_en_US,
+        symbol.name().ToString());
+  } else if (IsUseAssociated(symbol, scope)) {
+    context_.Say(source_,
+        "Data object part '%s' must not be accessed by use association"_err_en_US,
+        symbol.name().ToString());
+  } else if (IsInBlankCommon(symbol)) {
+    context_.Say(source_,
+        "Data object part '%s' must not be in blank COMMON"_err_en_US,
+        symbol.name().ToString());
+  } else {
+    return true;
+  }
+  return false;
+}
+
+bool DataVarChecker::CheckAnySymbol(const Symbol &symbol) { // C876
+  if (IsAutomaticObject(symbol)) {
+    context_.Say(source_,
+        "Data object part '%s' must not be an automatic object"_err_en_US,
+        symbol.name().ToString());
+  } else if (IsAllocatable(symbol)) {
+    context_.Say(source_,
+        "Data object part '%s' must not be an allocatable object"_err_en_US,
+        symbol.name().ToString());
+  } else {
+    return true;
+  }
+  return false;
+}
+
 void DataChecker::Leave(const parser::DataIDoObject &object) {
   if (const auto *designator{
           std::get_if<parser::Scalar<common::Indirection<parser::Designator>>>(
               &object.u)}) {
     if (MaybeExpr expr{exprAnalyzer_.Analyze(*designator)}) {
       auto source{designator->thing.value().source};
-      if (evaluate::IsConstantExpr(*expr)) { // C878
+      if (evaluate::IsConstantExpr(*expr)) { // C878,C879
         exprAnalyzer_.Say(
             source, "Data implied do object must be a variable"_err_en_US);
       } else {

flang/lib/Semantics/resolve-names-utils.cpp

@@ -595,16 +595,9 @@ bool EquivalenceSets::CheckObject(const parser::Name &name) {
         msg = "Nonsequence derived type object '%s'"
               " is not allowed in an equivalence set"_err_en_US;
       }
-    } else if (symbol.IsObjectArray()) {
-      for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) {
-        auto &lbound{spec.lbound().GetExplicit()};
-        auto &ubound{spec.ubound().GetExplicit()};
-        if ((lbound && !evaluate::ToInt64(*lbound)) ||
-            (ubound && !evaluate::ToInt64(*ubound))) {
-          msg = "Automatic array '%s'"
-                " is not allowed in an equivalence set"_err_en_US;
-        }
-      }
+    } else if (IsAutomaticObject(symbol)) {
+      msg = "Automatic object '%s'"
+            " is not allowed in an equivalence set"_err_en_US;
     }
   }
   if (!msg.text().empty()) {

flang/lib/Semantics/tools.cpp

@@ -581,6 +581,35 @@ bool HasImpureFinal(const DerivedTypeSpec &derived) {
 
 bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; }
 
+bool IsAutomaticObject(const Symbol &symbol) {
+  if (IsDummy(symbol) || IsPointer(symbol) || IsAllocatable(symbol)) {
+    return false;
+  }
+  if (const DeclTypeSpec * type{symbol.GetType()}) {
+    if (type->category() == DeclTypeSpec::Character) {
+      ParamValue length{type->characterTypeSpec().length()};
+      if (length.isExplicit()) {
+        if (MaybeIntExpr lengthExpr{length.GetExplicit()}) {
+          if (!ToInt64(lengthExpr)) {
+            return true;
+          }
+        }
+      }
+    }
+  }
+  if (symbol.IsObjectArray()) {
+    for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) {
+      auto &lbound{spec.lbound().GetExplicit()};
+      auto &ubound{spec.ubound().GetExplicit()};
+      if ((lbound && !evaluate::ToInt64(*lbound)) ||
+          (ubound && !evaluate::ToInt64(*ubound))) {
+        return true;
+      }
+    }
+  }
+  return false;
+}
+
 bool IsAssumedLengthCharacter(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     return type->category() == DeclTypeSpec::Character &&
@@ -590,6 +619,20 @@ bool IsAssumedLengthCharacter(const Symbol &symbol) {
   }
 }
 
+bool IsInBlankCommon(const Symbol &symbol) {
+  if (FindCommonBlockContaining(symbol)) {
+    if (const auto *details{
+            symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
+      if (details->commonBlock()) {
+        if (details->commonBlock()->name().empty()) {
+          return true;
+        }
+      }
+    }
+  }
+  return false;
+}
+
 // C722 and C723:  For a function to be assumed length, it must be external and
 // of CHARACTER type
 bool IsExternal(const Symbol &symbol) {

flang/test/Lower/pre-fir-tree02.f90

@@ -326,7 +326,7 @@ subroutine sub3()
 end subroutine
 
 ! CHECK: Subroutine sub4
-subroutine sub4(i, j)
+subroutine sub4()
   integer :: i
   print*, "test"
   ! CHECK: DataStmt

flang/test/Semantics/block-data01.f90

@@ -11,9 +11,6 @@ block data foo
   procedure(sin), pointer :: p => cos
   !ERROR: 'p' is already declared as a procedure
   common /block/ pi, p
-  real :: inBlankCommon
-  data inBlankCommon / 1.0 /
-  common inBlankCommon
   !ERROR: An initialized variable in BLOCK DATA must be in a COMMON block
   integer :: inDataButNotCommon
   data inDataButNotCommon /1/

flang/test/Semantics/data01.f90

@@ -1,20 +1,16 @@
 ! RUN: %S/test_errors.sh %s %t %f18
 !Test for checking data constraints, C882-C887
-module m1
+subroutine CheckRepeat
   type person
     integer :: age
     character(len=25) :: name
   end type
   integer, parameter::digits(5) = ( /-11,-22,-33,44,55/ )
-  integer ::notConstDigits(5) = ( /-11,-22,-33,44,55/ )
+  integer ::notConstDigits(5)
   real, parameter::numbers(5) = ( /-11.11,-22.22,-33.33,44.44,55.55/ )
   integer, parameter :: repeat = -1
   integer :: myAge = 2 
   type(person) myName
-end
-
-subroutine CheckRepeat
-  use m1
   !C882
   !ERROR: Missing initialization for parameter 'uninitialized'
   integer, parameter :: uninitialized
@@ -39,7 +35,12 @@ subroutine CheckRepeat
 end
 
 subroutine CheckValue
-  use m1
+  type person
+    integer :: age
+    character(len=25) :: name
+  end type
+  integer :: myAge = 2
+  type(person) myName
   !OK: constant structure constructor
   data myname / person(1, 'Abcd Ijkl') /
   !C883

flang/test/Semantics/data03.f90

@@ -62,6 +62,12 @@ module m
       !C880
       !ERROR: Data implied do structure component must be subscripted
       DATA(nums % one, i = 1, 5) / 5 * 1 /
+      !C879
+      !ERROR: Data implied do object must be a variable
+      DATA(newNums % numbers(i), i = 1, 5) / 5 * 1 /
+      !C879
+      !ERROR: Data implied do object must be a variable
+      DATA(newNumsArray(i) % one, i = 1, 5) / 5 * 1 /
       !C880
       !OK: Correct use
       DATA(largeArray(j) % nums % one, j = 1, 10) / 10 * 1 /

flang/test/Semantics/data04.f90

@@ -0,0 +1,155 @@
+! RUN: %S/test_errors.sh %s %t %f18
+!Testing data constraints : C876, C877
+module m
+  integer :: first
+  contains
+    subroutine h
+      integer a,b
+      !C876
+      !ERROR: Data object part 'first' must not be accessed by host association
+      DATA first /1/
+    end subroutine
+
+    function g(i)
+      integer ::i
+      g = i *1024
+    end
+
+    function f(i)
+      integer ::i
+      integer ::result
+      integer, allocatable :: a
+      integer :: b(i)
+      character(len=i), pointer:: charPtr
+      character(len=i), allocatable:: charAlloc
+      !C876
+      !ERROR: Data object part 'i' must not be a dummy argument
+      DATA i /1/
+      !C876
+      !ERROR: Data object part 'f' must not be a function result
+      DATA f /1/
+      !C876
+      !ERROR: Data object part 'g' must not be a function name
+      DATA g /1/
+      !C876
+      !ERROR: Data object part 'a' must not be an allocatable object
+      DATA a /1/
+      !C876
+      !ERROR: Data object part 'b' must not be an automatic object
+      DATA b(0) /1/
+      !C876
+      !Ok: As charPtr is a pointer, it is not an automatic object
+      DATA charPtr / NULL() /
+      !C876
+      !ERROR: Data object part 'charalloc' must not be an allocatable object
+      DATA charAlloc / 'abc' /
+      f = i *1024
+    end
+
+    subroutine CheckObject(i)
+      type specialNumbers
+        integer one
+        integer numbers(5)
+        type(specialNumbers), pointer :: headOfTheList
+        integer, pointer, dimension(:) :: ptoarray
+        character, pointer, dimension(:) :: ptochar
+      end type
+      type large
+        integer, allocatable :: allocVal
+        integer, allocatable :: elt(:)
+        integer val
+        type(specialNumbers) numsArray(5)
+      end type
+      type(large) largeNumber
+      type(large), allocatable :: allocatableLarge
+      type(large) :: largeNumberArray(i)
+      type(large) :: largeArray(5)
+      character :: name(i)
+      !C877
+      !OK: Correct use
+      DATA(largeNumber % numsArray(j) % headOfTheList, j = 1, 10) / 10 * NULL() /
+      !C877
+      !ERROR: Data object must not contain pointer 'headofthelist' as a non-rightmost part
+      DATA(largeNumber % numsArray(j) % headOfTheList % one, j = 1, 10) / 10 * NULL() /
+      !C877
+      !ERROR: Rightmost data object pointer 'ptoarray' must not be subscripted
+      DATA(largeNumber % numsArray(j) % ptoarray(1), j = 1, 10) / 10 * 1 /
+      !C877
+      !ERROR: Rightmost data object pointer 'ptochar' must not be subscripted
+      DATA largeNumber % numsArray(0) % ptochar(1:2) / 'ab' /
+      !C876
+      !ERROR: Data object part 'elt' must not be an allocatable object
+      DATA(largeNumber % elt(j) , j = 1, 10) / 10 * 1/
+      !C876
+      !ERROR: Data object part 'allocval' must not be an allocatable object
+      DATA(largeArray(j) % allocVal , j = 1, 10) / 10 * 1/
+      !C876
+      !ERROR: Data object part 'allocatablelarge' must not be an allocatable object
+      DATA allocatableLarge % val / 1 /
+      !C876
+      !ERROR: Data object part 'largenumberarray' must not be an automatic object
+      DATA(largeNumberArray(j) % val, j = 1, 10) / 10 * NULL() /
+      !C876
+      !ERROR: Data object part 'name' must not be an automatic object
+      DATA name( : 2) / 'Ancd' /
+    end
+  end
+
+  block data foo
+          integer :: a,b
+          common /c/ a,b
+          !C876
+          !OK: Correct use
+          DATA a /1/
+  end block data
+
+  module m2
+    integer m2_i
+    type newType
+      integer number
+    end type
+    type(newType) m2_number1
+    contains
+
+    subroutine checkDerivedType(m2_number)
+      type(newType) m2_number
+      type(newType) m2_number3
+      !C876
+      !ERROR: Data object part 'm2_number' must not be a dummy argument
+      DATA m2_number%number /1/
+      !C876
+      !ERROR: Data object part 'm2_number1' must not be accessed by host association
+      DATA m2_number1%number /1/
+      !C876
+      !OK: m2_number3 is not associated through use association
+      DATA m2_number3%number /1/
+    end
+  end
+
+  program new
+    use m2
+    integer a
+    real    b,c
+    type seqType
+      sequence
+      integer number
+    end type
+    type(SeqType) num
+    COMMON b,a,c,num
+    type(newType) m2_number2
+    !C876
+    !ERROR: Data object part 'b' must not be in blank COMMON
+    DATA b /1/
+    !C876
+    !ERROR: Data object part 'm2_i' must not be accessed by use association
+    DATA m2_i /1/
+    !C876
+    !ERROR: Data object part 'm2_number1' must not be accessed by use association
+    DATA m2_number1%number /1/
+    !C876
+    !OK: m2_number2 is not associated through use association
+    DATA m2_number2%number /1/
+    !C876
+    !ERROR: Data object part 'num' must not be in blank COMMON
+    DATA num%number /1/
+  end program

flang/test/Semantics/equivalence01.f90

@@ -128,7 +128,7 @@ end
 subroutine s11(n)
   integer :: n
   real :: x(n), y
-  !ERROR: Automatic array 'x' is not allowed in an equivalence set
+  !ERROR: Automatic object 'x' is not allowed in an equivalence set
   equivalence(x(1), y)
 end