[flang] More semantic checking for DO constructs

This time I'm adding to the checks for constraint C1137, which states
that image control statements cannot appear in a DO CONCURRENT.  The
checks I added test to see if the DO CONCURRENT contains an ALLOCATE or
DEALLOCATE that references a coarray.

Original-commit: flang-compiler/f18@c16b883db3
Reviewed-on: https://github.com/flang-compiler/f18/pull/769

flang/lib/semantics/check-do.cc

@@ -24,6 +24,7 @@
 #include "../evaluate/tools.h"
 #include "../parser/message.h"
 #include "../parser/parse-tree-visitor.h"
+#include "../parser/tools.h"
 
 namespace Fortran::semantics {
 
@@ -126,6 +127,7 @@ public:
         "image control statement not allowed in DO CONCURRENT"_err_en_US);
   }
 
+  // more C1137 checks
   void Post(const parser::SyncAllStmt &) { NoImageControl(); }
   void Post(const parser::SyncImagesStmt &) { NoImageControl(); }
   void Post(const parser::SyncMemoryStmt &) { NoImageControl(); }
@@ -139,18 +141,14 @@ public:
   void Post(const parser::UnlockStmt &) { NoImageControl(); }
   void Post(const parser::StopStmt &) { NoImageControl(); }
 
-  void Post(const parser::AllocateStmt &) {
-    if (anyObjectIsCoarray()) {
-      context_.Say(currentStatementSourcePosition_,
-          "ALLOCATE coarray not allowed in DO CONCURRENT"_err_en_US);
-    }
+  // more C1137 checks
+  void Post(const parser::AllocateStmt &allocateStmt) {
+    CheckDoesntContainCoarray(allocateStmt);
   }
 
-  void Post(const parser::DeallocateStmt &) {
-    if (anyObjectIsCoarray()) {
-      context_.Say(currentStatementSourcePosition_,
-          "DEALLOCATE coarray not allowed in DO CONCURRENT"_err_en_US);
-    }
+  void Post(const parser::DeallocateStmt &deallocateStmt) {
+    CheckDoesntContainCoarray(deallocateStmt);  // C1137
+
     // C1140: deallocation of polymorphic objects
     if (anyObjectIsPolymorphic()) {
       context_.Say(currentStatementSourcePosition_,
@@ -219,6 +217,35 @@ public:
   }
 
 private:
+  // C1137 helper functions
+  void CheckAllocateObjectIsntCoarray(
+      const parser::AllocateObject &allocateObject, StmtType stmtType) {
+    const parser::Name &name{GetLastName(allocateObject)};
+    if (name.symbol && IsCoarray(*name.symbol)) {
+      context_.Say(name.source,
+          "%s coarray not allowed in DO CONCURRENT"_err_en_US,
+          EnumToString(stmtType));
+    }
+  }
+
+  void CheckDoesntContainCoarray(const parser::AllocateStmt &allocateStmt) {
+    const auto &allocationList{
+        std::get<std::list<parser::Allocation>>(allocateStmt.t)};
+    for (const auto &allocation : allocationList) {
+      const auto &allocateObject{
+          std::get<parser::AllocateObject>(allocation.t)};
+      CheckAllocateObjectIsntCoarray(allocateObject, StmtType::ALLOCATE);
+    }
+  }
+
+  void CheckDoesntContainCoarray(const parser::DeallocateStmt &deallocateStmt) {
+    const auto &allocateObjectList{
+        std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)};
+    for (const auto &allocateObject : allocateObjectList) {
+      CheckAllocateObjectIsntCoarray(allocateObject, StmtType::DEALLOCATE);
+    }
+  }
+
   bool anyObjectIsCoarray() { return false; }  // FIXME placeholder
   bool anyObjectIsPolymorphic() { return false; }  // FIXME placeholder
   bool EndTDeallocatesCoarray() { return false; }  // FIXME placeholder
@@ -476,7 +503,7 @@ private:
     SymbolSet result;
     if (const auto *expr{GetExpr(expression)}) {
       for (const Symbol *symbol : evaluate::CollectSymbols(*expr)) {
-        if (const Symbol * root{GetAssociationRoot(*symbol)}) {
+        if (const Symbol * root{GetAssociationRoot(DEREF(symbol))}) {
           result.insert(root);
         }
       }

flang/lib/semantics/check-do.h

@@ -26,9 +26,8 @@ struct ExitStmt;
 
 namespace Fortran::semantics {
 
-// To specify CYCLE and EXIT statements in semantic checking that's common to
-// both of them.
-ENUM_CLASS(StmtType, CYCLE, EXIT)
+// To specify different statement types used in semantic checking.
+ENUM_CLASS(StmtType, CYCLE, EXIT, ALLOCATE, DEALLOCATE)
 
 class DoChecker : public virtual BaseChecker {
 public:

flang/test/semantics/doconcurrent01.f90

@@ -121,3 +121,63 @@ subroutine s5()
     unlock(l)
   end do
 end subroutine s5
+
+subroutine s6()
+  type :: type0
+    integer, allocatable, dimension(:) :: type0_field
+    integer, allocatable, dimension(:), codimension[*] :: coarray_type0_field
+  end type
+
+  type :: type1
+    type(type0) :: type1_field
+  end type
+
+  type(type1), allocatable :: pvar;
+  type(type1), allocatable :: qvar;
+  integer, allocatable, dimension(:) :: array1
+  integer, allocatable, dimension(:) :: array2
+  integer, allocatable, codimension[*] :: ca
+
+  ! All of the following are allowable outside a DO CONCURRENT
+  allocate(pvar)
+  allocate(array1(3), pvar%type1_field%type0_field(3), array2(9))
+  allocate(pvar%type1_field%coarray_type0_field(3)[*])
+  allocate(ca[*])
+  allocate(pvar, ca[*], qvar, pvar%type1_field%coarray_type0_field(3)[*])
+
+  do concurrent (i = 1:10)
+  allocate(pvar%type1_field%type0_field(3))
+  end do
+
+  do concurrent (i = 1:10)
+!ERROR: ALLOCATE coarray not allowed in DO CONCURRENT
+    allocate(ca[*])
+  end do
+
+  do concurrent (i = 1:10)
+!ERROR: DEALLOCATE coarray not allowed in DO CONCURRENT
+    deallocate(ca)
+  end do
+
+  do concurrent (i = 1:10)
+!ERROR: ALLOCATE coarray not allowed in DO CONCURRENT
+  allocate(pvar%type1_field%coarray_type0_field(3)[*])
+  end do
+
+  do concurrent (i = 1:10)
+!ERROR: DEALLOCATE coarray not allowed in DO CONCURRENT
+  deallocate(pvar%type1_field%coarray_type0_field)
+  end do
+
+  do concurrent (i = 1:10)
+!ERROR: ALLOCATE coarray not allowed in DO CONCURRENT
+!ERROR: ALLOCATE coarray not allowed in DO CONCURRENT
+  allocate(pvar, ca[*], qvar, pvar%type1_field%coarray_type0_field(3)[*])
+  end do
+
+  do concurrent (i = 1:10)
+!ERROR: DEALLOCATE coarray not allowed in DO CONCURRENT
+!ERROR: DEALLOCATE coarray not allowed in DO CONCURRENT
+  deallocate(pvar, ca, qvar, pvar%type1_field%coarray_type0_field)
+  end do
+end subroutine s6