[flang] Extension: reduced scope for some implied DO loop indices

The index of an implied DO loop in a DATA statement or array
constructor is defined by Fortran 2018 to have scope over its
implied DO loop.  This definition is unfortunate, because it
requires the implied DO loop's bounds expressions to be in the
scope of the index variable.  Consequently, in code like

  integer, parameter :: j = 5
  real, save :: a(5) = [(j, j=1, j)]

the upper bound of the loop is a reference to the index variable,
not the parameter in the enclosing scope.

This patch limits the scope of the index variable to the "body"
of the implied DO loop as one would naturally expect, with a warning.
I would have preferred to make this a hard error, but most Fortran
compilers treat this case as f18 now does.  If the standard
were to be fixed, the warning could be made optional.

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

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 34767f0..49855b2 100644 (file)
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -58,6 +58,11 @@ write(buffer,*,delim="QUOTE") quotes
 print "('>',a10,'<')", buffer
 end
 ```
+* The name of the control variable in an implied DO loop in an array
+  constructor or DATA statement has a scope over the value-list only,
+  not the bounds of the implied DO loop.  It is not advisable to use
+  an object of the same name as the index variable in a bounds
+  expression, but it will work, instead of being needlessly undefined.
 
 ## Extensions, deletions, and legacy features supported by default
 

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index e4ce88b..b3ec6b4 100644 (file)
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -1409,15 +1409,6 @@ void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
   if (const auto dynamicType{DynamicType::From(symbol)}) {
     kind = dynamicType->kind();
   }
-  if (!exprAnalyzer_.AddImpliedDo(name, kind)) {
-    if (!(messageDisplayedSet_ & 0x20)) {
-      exprAnalyzer_.SayAt(name,
-          "Implied DO index is active in surrounding implied DO loop "
-          "and may not have the same name"_err_en_US); // C7115
-      messageDisplayedSet_ |= 0x20;
-    }
-    return;
-  }
   std::optional<Expr<ImpliedDoIntType>> lower{
       GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.lower)};
   std::optional<Expr<ImpliedDoIntType>> upper{
@@ -1428,49 +1419,57 @@ void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
     if (!stride) {
       stride = Expr<ImpliedDoIntType>{1};
     }
-    // Check for constant bounds; the loop may require complete unrolling
-    // of the parse tree if all bounds are constant in order to allow the
-    // implied DO loop index to qualify as a constant expression.
-    auto cLower{ToInt64(lower)};
-    auto cUpper{ToInt64(upper)};
-    auto cStride{ToInt64(stride)};
-    if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) {
-      exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source,
-          "The stride of an implied DO loop must not be zero"_err_en_US);
-      messageDisplayedSet_ |= 0x10;
-    }
-    bool isConstant{cLower && cUpper && cStride && *cStride != 0};
-    bool isNonemptyConstant{isConstant &&
-        ((*cStride > 0 && *cLower <= *cUpper) ||
-            (*cStride < 0 && *cLower >= *cUpper))};
-    bool unrollConstantLoop{false};
-    parser::Messages buffer;
-    auto saveMessagesDisplayed{messageDisplayedSet_};
-    {
-      auto messageRestorer{
-          exprAnalyzer_.GetContextualMessages().SetMessages(buffer)};
-      auto v{std::move(values_)};
-      for (const auto &value :
-          std::get<std::list<parser::AcValue>>(impliedDo.t)) {
-        Add(value);
-      }
-      std::swap(v, values_);
-      if (isNonemptyConstant && buffer.AnyFatalError()) {
-        unrollConstantLoop = true;
-      } else {
-        values_.Push(ImpliedDo<SomeType>{name, std::move(*lower),
-            std::move(*upper), std::move(*stride), std::move(v)});
+    if (exprAnalyzer_.AddImpliedDo(name, kind)) {
+      // Check for constant bounds; the loop may require complete unrolling
+      // of the parse tree if all bounds are constant in order to allow the
+      // implied DO loop index to qualify as a constant expression.
+      auto cLower{ToInt64(lower)};
+      auto cUpper{ToInt64(upper)};
+      auto cStride{ToInt64(stride)};
+      if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) {
+        exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source,
+            "The stride of an implied DO loop must not be zero"_err_en_US);
+        messageDisplayedSet_ |= 0x10;
+      }
+      bool isConstant{cLower && cUpper && cStride && *cStride != 0};
+      bool isNonemptyConstant{isConstant &&
+          ((*cStride > 0 && *cLower <= *cUpper) ||
+              (*cStride < 0 && *cLower >= *cUpper))};
+      bool unrollConstantLoop{false};
+      parser::Messages buffer;
+      auto saveMessagesDisplayed{messageDisplayedSet_};
+      {
+        auto messageRestorer{
+            exprAnalyzer_.GetContextualMessages().SetMessages(buffer)};
+        auto v{std::move(values_)};
+        for (const auto &value :
+            std::get<std::list<parser::AcValue>>(impliedDo.t)) {
+          Add(value);
+        }
+        std::swap(v, values_);
+        if (isNonemptyConstant && buffer.AnyFatalError()) {
+          unrollConstantLoop = true;
+        } else {
+          values_.Push(ImpliedDo<SomeType>{name, std::move(*lower),
+              std::move(*upper), std::move(*stride), std::move(v)});
+        }
       }
-    }
-    if (unrollConstantLoop) {
-      messageDisplayedSet_ = saveMessagesDisplayed;
-      UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride);
-    } else if (auto *messages{
-                   exprAnalyzer_.GetContextualMessages().messages()}) {
-      messages->Annex(std::move(buffer));
+      if (unrollConstantLoop) {
+        messageDisplayedSet_ = saveMessagesDisplayed;
+        UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride);
+      } else if (auto *messages{
+                     exprAnalyzer_.GetContextualMessages().messages()}) {
+        messages->Annex(std::move(buffer));
+      }
+      exprAnalyzer_.RemoveImpliedDo(name);
+    } else if (!(messageDisplayedSet_ & 0x20)) {
+      exprAnalyzer_.SayAt(name,
+          "Implied DO index '%s' is active in a surrounding implied DO loop "
+          "and may not have the same name"_err_en_US,
+          name); // C7115
+      messageDisplayedSet_ |= 0x20;
     }
   }
-  exprAnalyzer_.RemoveImpliedDo(name);
 }
 
 // Fortran considers an implied DO index of an array constructor to be

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 40ca1c0..35c2981 100644 (file)
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -901,11 +901,12 @@ protected:
   // it comes from the entity in the containing scope, or implicit rules.
   // Return pointer to the new symbol, or nullptr on error.
   Symbol *DeclareLocalEntity(const parser::Name &);
-  // Declare a statement entity (e.g., an implied DO loop index).
-  // If there isn't a type specified, implicit rules apply.
-  // Return pointer to the new symbol, or nullptr on error.
-  Symbol *DeclareStatementEntity(
-      const parser::Name &, const std::optional<parser::IntegerTypeSpec> &);
+  // Declare a statement entity (i.e., an implied DO loop index for
+  // a DATA statement or an array constructor).  If there isn't an explict
+  // type specified, implicit rules apply. Return pointer to the new symbol,
+  // or nullptr on error.
+  Symbol *DeclareStatementEntity(const parser::DoVariable &,
+      const std::optional<parser::IntegerTypeSpec> &);
   Symbol &MakeCommonBlockSymbol(const parser::Name &);
   Symbol &MakeCommonBlockSymbol(const std::optional<parser::Name> &);
   bool CheckUseError(const parser::Name &);
@@ -926,6 +927,16 @@ protected:
   Symbol *NoteInterfaceName(const parser::Name &);
   bool IsUplevelReference(const Symbol &);
 
+  std::optional<SourceName> BeginCheckOnIndexUseInOwnBounds(
+      const parser::DoVariable &name) {
+    std::optional<SourceName> result{checkIndexUseInOwnBounds_};
+    checkIndexUseInOwnBounds_ = name.thing.thing.source;
+    return result;
+  }
+  void EndCheckOnIndexUseInOwnBounds(const std::optional<SourceName> &restore) {
+    checkIndexUseInOwnBounds_ = restore;
+  }
+
 private:
   // The attribute corresponding to the statement containing an ObjectDecl
   std::optional<Attr> objectDeclAttr_;
@@ -956,6 +967,9 @@ private:
   } enumerationState_;
   // Set for OldParameterStmt processing
   bool inOldStyleParameterStmt_{false};
+  // Set when walking DATA & array constructor implied DO loop bounds
+  // to warn about use of the implied DO intex therein.
+  std::optional<SourceName> checkIndexUseInOwnBounds_;
 
   bool HandleAttributeStmt(Attr, const std::list<parser::Name> &);
   Symbol &HandleAttributeStmt(Attr, const parser::Name &);
@@ -5010,8 +5024,10 @@ Symbol *DeclarationVisitor::DeclareLocalEntity(const parser::Name &name) {
   return &MakeHostAssocSymbol(name, prev);
 }
 
-Symbol *DeclarationVisitor::DeclareStatementEntity(const parser::Name &name,
+Symbol *DeclarationVisitor::DeclareStatementEntity(
+    const parser::DoVariable &doVar,
     const std::optional<parser::IntegerTypeSpec> &type) {
+  const parser::Name &name{doVar.thing.thing};
   const DeclTypeSpec *declTypeSpec{nullptr};
   if (auto *prev{FindSymbol(name)}) {
     if (prev->owner() == currScope()) {
@@ -5037,7 +5053,9 @@ Symbol *DeclarationVisitor::DeclareStatementEntity(const parser::Name &name,
   } else {
     ApplyImplicitRules(symbol);
   }
-  return Resolve(name, &symbol);
+  Symbol *result{Resolve(name, &symbol)};
+  AnalyzeExpr(context(), doVar); // enforce INTEGER type
+  return result;
 }
 
 // Set the type of an entity or report an error.
@@ -5321,9 +5339,7 @@ bool ConstructVisitor::Pre(const parser::LocalitySpec::Shared &x) {
 
 bool ConstructVisitor::Pre(const parser::AcSpec &x) {
   ProcessTypeSpec(x.type);
-  PushScope(Scope::Kind::ImpliedDos, nullptr);
   Walk(x.values);
-  PopScope();
   return false;
 }
 
@@ -5334,9 +5350,18 @@ bool ConstructVisitor::Pre(const parser::AcImpliedDo &x) {
   auto &control{std::get<parser::AcImpliedDoControl>(x.t)};
   auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(control.t)};
   auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)};
+  // F'2018 has the scope of the implied DO variable covering the entire
+  // implied DO production (19.4(5)), which seems wrong in cases where the name
+  // of the implied DO variable appears in one of the bound expressions. Thus
+  // this extension, which shrinks the scope of the variable to exclude the
+  // expressions in the bounds.
+  auto restore{BeginCheckOnIndexUseInOwnBounds(bounds.name)};
+  Walk(bounds.lower);
+  Walk(bounds.upper);
+  Walk(bounds.step);
+  EndCheckOnIndexUseInOwnBounds(restore);
   PushScope(Scope::Kind::ImpliedDos, nullptr);
-  DeclareStatementEntity(bounds.name.thing.thing, type);
-  Walk(bounds);
+  DeclareStatementEntity(bounds.name, type);
   Walk(values);
   PopScope();
   return false;
@@ -5346,9 +5371,21 @@ bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) {
   auto &objects{std::get<std::list<parser::DataIDoObject>>(x.t)};
   auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(x.t)};
   auto &bounds{std::get<parser::DataImpliedDo::Bounds>(x.t)};
-  DeclareStatementEntity(bounds.name.thing.thing, type);
-  Walk(bounds);
+  // See comment in Pre(AcImpliedDo) above.
+  auto restore{BeginCheckOnIndexUseInOwnBounds(bounds.name)};
+  Walk(bounds.lower);
+  Walk(bounds.upper);
+  Walk(bounds.step);
+  EndCheckOnIndexUseInOwnBounds(restore);
+  bool pushScope{currScope().kind() != Scope::Kind::ImpliedDos};
+  if (pushScope) {
+    PushScope(Scope::Kind::ImpliedDos, nullptr);
+  }
+  DeclareStatementEntity(bounds.name, type);
   Walk(objects);
+  if (pushScope) {
+    PopScope();
+  }
   return false;
 }
 
@@ -5887,6 +5924,12 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
       ConvertToObjectEntity(*symbol);
       ApplyImplicitRules(*symbol);
     }
+    if (checkIndexUseInOwnBounds_ &&
+        *checkIndexUseInOwnBounds_ == name.source) {
+      Say(name,
+          "Implied DO index '%s' uses an object of the same name in its bounds expressions"_en_US,
+          name.source);
+    }
     return &name;
   }
   if (isImplicitNoneType()) {
@@ -5894,6 +5937,11 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
     return nullptr;
   }
   // Create the symbol then ensure it is accessible
+  if (checkIndexUseInOwnBounds_ && *checkIndexUseInOwnBounds_ == name.source) {
+    Say(name,
+        "Implied DO index '%s' uses itself in its own bounds expressions"_err_en_US,
+        name.source);
+  }
   MakeSymbol(InclusiveScope(), name.source, Attrs{});
   auto *symbol{FindSymbol(name)};
   if (!symbol) {

diff --git a/flang/test/Semantics/array-constr-values.f90 b/flang/test/Semantics/array-constr-values.f90
index bc1ee0a..09f8bc3 100644 (file)
--- a/flang/test/Semantics/array-constr-values.f90
+++ b/flang/test/Semantics/array-constr-values.f90
@@ -58,7 +58,7 @@ subroutine checkC7115()
   real, dimension(10), parameter :: good1 = [(99.9, i = 1, 10)]
   real, dimension(100), parameter :: good2 = [((88.8, i = 1, 10), j = 1, 10)]
   real, dimension(-1:0), parameter :: good3 = [77.7, 66.6]
-  !ERROR: Implied DO index is active in surrounding implied DO loop and may not have the same name
+  !ERROR: Implied DO index 'i' is active in a surrounding implied DO loop and may not have the same name
   real, dimension(100), parameter :: bad = [((88.8, i = 1, 10), i = 1, 10)]
 
   !ERROR: Value of named constant 'bad2' ([INTEGER(4)::(int(j,kind=4),INTEGER(8)::j=1_8,1_8,0_8)]) cannot be computed as a constant value

diff --git a/flang/test/Semantics/data11.f90 b/flang/test/Semantics/data11.f90
new file mode 100644 (file)
index 0000000..213b92b
--- /dev/null
+++ b/flang/test/Semantics/data11.f90
@@ -0,0 +1,9 @@
+! RUN: %flang_fc1 -fsyntax-only -fdebug-dump-symbols %s 2>&1 | FileCheck %s
+! CHECK:  Implied DO index 'j' uses an object of the same name in its bounds expressions
+! CHECK: ObjectEntity type: REAL(4) shape: 1_8:5_8 init:[REAL(4)::1._4,2._4,3._4,4._4,5._4]
+! Verify that the scope of a DATA statement implied DO loop index does
+! not include the bounds expressions (language extension, with warning)
+integer, parameter :: j = 5
+real, save :: a(j)
+data (a(j),j=1,j)/1,2,3,4,5/
+end

diff --git a/flang/test/Semantics/modfile25.f90 b/flang/test/Semantics/modfile25.f90
index f17fd22..4a50ff5 100644 (file)
--- a/flang/test/Semantics/modfile25.f90
+++ b/flang/test/Semantics/modfile25.f90
@@ -39,7 +39,9 @@ end module m1
 ! integer(8),parameter::a1ss(1_8:*)=[INTEGER(8)::3_8]
 ! integer(8),parameter::a1sss(1_8:*)=[INTEGER(8)::1_8]
 ! integer(8),parameter::a1rs(1_8:*)=[INTEGER(8)::3_8,1_8,1_8,1_8]
+! intrinsic::rank
 ! integer(8),parameter::a1n(1_8:*)=[INTEGER(8)::125_8,5_8,5_8]
+! intrinsic::size
 ! integer(8),parameter::a1sn(1_8:*)=[INTEGER(8)::3_8,1_8,1_8]
 ! integer(8),parameter::ac1s(1_8:*)=[INTEGER(8)::1_8]
 ! integer(8),parameter::ac2s(1_8:*)=[INTEGER(8)::3_8]

diff --git a/flang/test/Semantics/modfile26.f90 b/flang/test/Semantics/modfile26.f90
index 28eeeb8..e57c537 100644 (file)
--- a/flang/test/Semantics/modfile26.f90
+++ b/flang/test/Semantics/modfile26.f90
@@ -66,12 +66,15 @@ end module m1
 !Expect: m1.mod
 !module m1
 !integer(4),parameter::iranges(1_8:*)=[INTEGER(4)::2_4,4_4,9_4,18_4,38_4]
+!intrinsic::range
 !logical(4),parameter::ircheck=.true._4
 !intrinsic::all
 !integer(4),parameter::intpvals(1_8:*)=[INTEGER(4)::0_4,2_4,3_4,4_4,5_4,9_4,10_4,18_4,19_4,38_4,39_4]
 !integer(4),parameter::intpkinds(1_8:*)=[INTEGER(4)::1_4,1_4,2_4,2_4,4_4,4_4,8_4,8_4,16_4,16_4,-1_4]
+!intrinsic::size
 !logical(4),parameter::ipcheck=.true._4
 !integer(4),parameter::realprecs(1_8:*)=[INTEGER(4)::3_4,2_4,6_4,15_4,18_4,33_4]
+!intrinsic::precision
 !logical(4),parameter::rpreccheck=.true._4
 !integer(4),parameter::realpvals(1_8:*)=[INTEGER(4)::0_4,3_4,4_4,6_4,7_4,15_4,16_4,18_4,19_4,33_4,34_4]
 !integer(4),parameter::realpkinds(1_8:*)=[INTEGER(4)::2_4,2_4,4_4,4_4,8_4,8_4,10_4,10_4,16_4,16_4,-1_4]
@@ -82,7 +85,9 @@ end module m1
 !integer(4),parameter::realrkinds(1_8:*)=[INTEGER(4)::2_4,2_4,3_4,3_4,8_4,8_4,10_4,10_4,-2_4]
 !logical(4),parameter::realrcheck=.true._4
 !logical(4),parameter::radixcheck=.true._4
+!intrinsic::radix
 !integer(4),parameter::intdigits(1_8:*)=[INTEGER(4)::7_4,15_4,31_4,63_4,127_4]
+!intrinsic::digits
 !logical(4),parameter::intdigitscheck=.true._4
 !integer(4),parameter::realdigits(1_8:*)=[INTEGER(4)::11_4,8_4,24_4,53_4,64_4,113_4]
 !logical(4),parameter::realdigitscheck=.true._4

diff --git a/flang/test/Semantics/resolve106.f90 b/flang/test/Semantics/resolve106.f90
new file mode 100644 (file)
index 0000000..b8215f7
--- /dev/null
+++ b/flang/test/Semantics/resolve106.f90
@@ -0,0 +1,5 @@
+!RUN: %flang -fsyntax-only %s 2>&1 | FileCheck %s
+integer, parameter :: j = 10
+! CHECK: Implied DO index 'j' uses an object of the same name in its bounds expressions
+real :: a(10) = [(j, j=1,j)]
+end

diff --git a/flang/test/Semantics/resolve30.f90 b/flang/test/Semantics/resolve30.f90
index ecf488a..f34ad5f 100644 (file)
--- a/flang/test/Semantics/resolve30.f90
+++ b/flang/test/Semantics/resolve30.f90
@@ -31,9 +31,9 @@ subroutine s3
 end
 
 subroutine s4
-  real :: i, j
+  real :: j
   !ERROR: Must have INTEGER type, but is REAL(4)
-  real :: a(16) = [(i, i=1, 16)]
+  real :: a(16) = [(x, x=1, 16)]
   real :: b(16)
   !ERROR: Must have INTEGER type, but is REAL(4)
   data(b(j), j=1, 16) / 16 * 0.0 /

diff --git a/flang/test/Semantics/symbol05.f90 b/flang/test/Semantics/symbol05.f90
index 442bd19..306127f 100644 (file)
--- a/flang/test/Semantics/symbol05.f90
+++ b/flang/test/Semantics/symbol05.f90
@@ -48,10 +48,10 @@ subroutine s3
   !DEF: /s3/Block1/t DerivedType
   type :: t
    !DEF: /s3/Block1/t/x ObjectEntity REAL(4)
-   !DEF: /s3/Block1/t/ImpliedDos1/ImpliedDos1/i (Implicit) ObjectEntity INTEGER(4)
+   !DEF: /s3/Block1/t/ImpliedDos1/i (Implicit) ObjectEntity INTEGER(4)
    real :: x(10) = [(i, i=1,10)]
    !DEF: /s3/Block1/t/y ObjectEntity REAL(4)
-   !DEF: /s3/Block1/t/ImpliedDos2/ImpliedDos1/j ObjectEntity INTEGER(8)
+   !DEF: /s3/Block1/t/ImpliedDos2/j ObjectEntity INTEGER(8)
    real :: y(10) = [(j, j=1,10)]
   end type
  end block