[flang] I fixed a problem in C1123. This constraint requires that expressions in a DO

CONCURRENT header not reference names declared in the same header.  To
implement this, I changed the "Pre" function for ConcurrentHeader to walk the
subtree in an order that caused the variables associated with the declared
names to be created before any of the expressions were walked.

I added the test dosemantics04.f90 to test this.

Original-commit: flang-compiler/f18@9f3b552414
Reviewed-on: https://github.com/flang-compiler/f18/pull/504
Tree-same-pre-rewrite: false

flang/lib/semantics/resolve-names.cc

@@ -875,7 +875,6 @@ private:
 class ConstructVisitor : public DeclarationVisitor {
 public:
   bool Pre(const parser::ConcurrentHeader &);
-  void Post(const parser::ConcurrentHeader &);
   bool Pre(const parser::LocalitySpec::Local &);
   bool Pre(const parser::LocalitySpec::LocalInit &);
   bool Pre(const parser::LocalitySpec::Shared &);
@@ -885,7 +884,6 @@ public:
   bool Pre(const parser::DataStmtObject &);
   bool Pre(const parser::DoConstruct &);
   void Post(const parser::DoConstruct &);
-  void Post(const parser::ConcurrentControl &);
   bool Pre(const parser::ForallConstruct &);
   void Post(const parser::ForallConstruct &);
   bool Pre(const parser::ForallStmt &);
@@ -970,6 +968,8 @@ private:
   void SetTypeFromAssociation(Symbol &);
   void SetAttrsFromAssociation(Symbol &);
   Selector ResolveSelector(const parser::Selector &);
+  void ResolveControlExpression(const parser::ConcurrentControl &control);
+  void ResolveIndexName(const parser::Name &name);
 };
 
 // Walk the parse tree and resolve names to symbols.
@@ -3886,12 +3886,78 @@ ParamValue DeclarationVisitor::GetParamValue(const parser::TypeParamValue &x) {
 
 // ConstructVisitor implementation
 
-bool ConstructVisitor::Pre(const parser::ConcurrentHeader &) {
-  BeginDeclTypeSpec();
-  return true;
+void ConstructVisitor::ResolveIndexName(const parser::Name &name) {
+  auto *prev{FindSymbol(name)};
+  if (prev) {
+    if (prev->owner().kind() == Scope::Kind::Forall ||
+        prev->owner() == currScope()) {
+      SayAlreadyDeclared(name, *prev);
+      return;
+    }
+    name.symbol = nullptr;
+  }
+  auto &symbol{DeclareObjectEntity(name, {})};
+
+  if (symbol.GetType()) {
+    // type came from explicit type-spec
+  } else if (!prev) {
+    ApplyImplicitRules(symbol);
+  } else if (!prev->has<ObjectEntityDetails>() && !prev->has<EntityDetails>()) {
+    Say2(name, "Index name '%s' conflicts with existing identifier"_err_en_US,
+        *prev, "Previous declaration of '%s'"_en_US);
+    return;
+  } else {
+    if (auto *type{prev->GetType()}) {
+      symbol.SetType(*type);
+    }
+    if (prev->IsObjectArray()) {
+      SayWithDecl(name, *prev, "Index variable '%s' is not scalar"_err_en_US);
+      return;
+    }
+  }
+  EvaluateExpr(parser::Scalar{parser::Integer{common::Clone(name)}});
 }
-void ConstructVisitor::Post(const parser::ConcurrentHeader &) {
+
+void ConstructVisitor::ResolveControlExpression(
+    const parser::ConcurrentControl &control) {
+  Walk(std::get<1>(control.t));
+  Walk(std::get<2>(control.t));
+  const auto &optionalStep{std::get<3>(control.t)};
+  if (optionalStep.has_value()) {
+    Walk(optionalStep.value());
+  }
+}
+
+// We need to make sure that all of the index-names get declared before the
+// expressions in the loop control are evaluated so that references to the
+// index-names in the expressions are correctly detected.
+bool ConstructVisitor::Pre(const parser::ConcurrentHeader &header) {
+  BeginDeclTypeSpec();
+
+  // Process the type spec, if present
+  auto &typeSpec{std::get<std::optional<parser::IntegerTypeSpec>>(header.t)};
+  if (typeSpec.has_value()) {
+    SetDeclTypeSpec(MakeNumericType(TypeCategory::Integer, typeSpec->v));
+  }
+
+  // Process the index-name nodes in the ConcurrentControl nodes
+  auto &controls{std::get<std::list<parser::ConcurrentControl>>(header.t)};
+  for (auto &control : controls) {
+    ResolveIndexName(std::get<parser::Name>(control.t));
+  }
+
+  // Process the expressions in ConcurrentControls
+  for (auto &control : controls) {
+    ResolveControlExpression(control);
+  }
+
+  // Resolve the names in the scalar-mask-expr, if present
+  auto &maskExpr{std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)};
+  if (maskExpr.has_value()) {
+    Walk(maskExpr.value());
+  }
   EndDeclTypeSpec();
+  return false;
 }
 
 bool ConstructVisitor::Pre(const parser::LocalitySpec::Local &x) {
@@ -3902,6 +3968,7 @@ bool ConstructVisitor::Pre(const parser::LocalitySpec::Local &x) {
   }
   return false;
 }
+
 bool ConstructVisitor::Pre(const parser::LocalitySpec::LocalInit &x) {
   for (auto &name : x.v) {
     if (auto *symbol{DeclareLocalEntity(name)}) {
@@ -3984,38 +4051,6 @@ void ConstructVisitor::Post(const parser::DoConstruct &x) {
   }
 }
 
-void ConstructVisitor::Post(const parser::ConcurrentControl &x) {
-  const auto &name{std::get<parser::Name>(x.t)};
-  auto *prev{FindSymbol(name)};
-  if (prev) {
-    if (prev->owner().kind() == Scope::Kind::Forall ||
-        prev->owner() == currScope()) {
-      SayAlreadyDeclared(name, *prev);
-      return;
-    }
-    name.symbol = nullptr;
-  }
-  auto &symbol{DeclareObjectEntity(name, {})};
-  if (symbol.GetType()) {
-    // type came from explicit type-spec
-  } else if (!prev) {
-    ApplyImplicitRules(symbol);
-  } else if (!prev->has<ObjectEntityDetails>() && !prev->has<EntityDetails>()) {
-    Say2(name, "Index name '%s' conflicts with existing identifier"_err_en_US,
-        *prev, "Previous declaration of '%s'"_en_US);
-    return;
-  } else {
-    if (auto *type{prev->GetType()}) {
-      symbol.SetType(*type);
-    }
-    if (prev->IsObjectArray()) {
-      SayWithDecl(name, *prev, "Index variable '%s' is not scalar"_err_en_US);
-      return;
-    }
-  }
-  EvaluateExpr(parser::Scalar{parser::Integer{common::Clone(name)}});
-}
-
 bool ConstructVisitor::Pre(const parser::ForallConstruct &) {
   PushScope(Scope::Kind::Forall, nullptr);
   return true;

flang/test/semantics/CMakeLists.txt

@@ -125,6 +125,7 @@ set(ERROR_TESTS
   dosemantics01.f90
   dosemantics02.f90
   dosemantics03.f90
+  dosemantics04.f90
   expr-errors01.f90
   null01.f90
   equivalence01.f90

flang/test/semantics/dosemantics04.f90

@@ -0,0 +1,46 @@
+! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! Issue 458 -- semantic checks for a normal DO loop.  The DO variable
+! and the initial, final, and step expressions must be INTEGER if the
+! options for standard conformance and turning warnings into errors
+! are both in effect.  This test turns on the options for standards
+! conformance and turning warnings into errors.  This produces error
+! messages for the cases where REAL and DOUBLE PRECISION variables
+! and expressions are used in the DO controls.
+
+! C1123 -- Expressions in DO CONCURRENT header cannot reference variables
+! declared in the same header
+PROGRAM dosemantics04
+  IMPLICIT NONE
+  INTEGER :: a, i, j, k, n
+
+! No problems here
+  DO CONCURRENT (INTEGER *2 :: i = 1:10, i < j + n) LOCAL(n)
+    PRINT *, "hello"
+  END DO
+
+  DO 30 CONCURRENT (i = 1:n:1, j=1:n:2, k=1:n:3, a<3) LOCAL (a)
+    PRINT *, "hello"
+30 END DO
+
+!ERROR: concurrent-control expression references index-name
+  DO CONCURRENT (i = j:3, j=1:3)
+  END DO
+
+!ERROR: concurrent-control expression references index-name
+  DO CONCURRENT (INTEGER*2 :: i = 1:3, j=i:3)
+  END DO
+
+END PROGRAM dosemantics04