[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

Author: klausler

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
 

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

flang/lib/Semantics/resolve-names.cpp

@@ -901,11 +901,12 @@ class DeclarationVisitor : public ArraySpecVisitor,
   // 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 @@ class DeclarationVisitor : public ArraySpecVisitor,
   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 @@ class DeclarationVisitor : public ArraySpecVisitor,
   } 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 &);
@@ -5009,8 +5023,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()) {
@@ -5036,7 +5052,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.
@@ -5320,9 +5338,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;
 }
 
@@ -5333,9 +5349,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;
@@ -5345,9 +5370,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;
 }
 
@@ -5886,13 +5923,24 @@ 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()) {
     Say(name, "No explicit type declared for '%s'"_err_en_US);
     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) {

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

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

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]

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

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

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 /

flang/test/Semantics/symbol05.f90

@@ -49,10 +49,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