[flang] Move checks for valid array-spec to check-declarations.cc

At the time we finish processing an array-spec in `resolve-names.cc`,
we don't know if the entity is going to be declared ALLOCATABLE later
so we can't check for validity there. In the new test in `resolve58.f90`
(based on issue flang-compiler/f18#930) we were reporting an error on `b` and not on `a`
when it should be the reverse.

The fix is to move array-spec checking to `check-declarations.cc`,
after name resolution is complete.

Fixes flang-compiler/f18#930.

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

diff --git a/flang/lib/semantics/check-declarations.cc b/flang/lib/semantics/check-declarations.cc
index 74048b7..385811d 100644 (file)
--- a/flang/lib/semantics/check-declarations.cc
+++ b/flang/lib/semantics/check-declarations.cc
@@ -55,6 +55,7 @@ private:
       const Symbol &proc, const Symbol *interface, const WithPassArg &);
   void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
   void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
+  void CheckArraySpec(const Symbol &, const ArraySpec &);
   void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
   void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
   void CheckGeneric(const Symbol &, const GenericDetails &);
@@ -285,6 +286,7 @@ void CheckHelper::CheckValue(
 
 void CheckHelper::CheckObjectEntity(
     const Symbol &symbol, const ObjectEntityDetails &details) {
+  CheckArraySpec(symbol, details.shape());
   Check(details.shape());
   Check(details.coshape());
   if (!details.coshape().empty()) {
@@ -345,6 +347,84 @@ void CheckHelper::CheckObjectEntity(
   }
 }
 
+// The six different kinds of array-specs:
+//   array-spec     -> explicit-shape-list | deferred-shape-list
+//                     | assumed-shape-list | implied-shape-list
+//                     | assumed-size | assumed-rank
+//   explicit-shape -> [ lb : ] ub
+//   deferred-shape -> :
+//   assumed-shape  -> [ lb ] :
+//   implied-shape  -> [ lb : ] *
+//   assumed-size   -> [ explicit-shape-list , ] [ lb : ] *
+//   assumed-rank   -> ..
+// Note:
+// - deferred-shape is also an assumed-shape
+// - A single "*" or "lb:*" might be assumed-size or implied-shape-list
+void CheckHelper::CheckArraySpec(
+    const Symbol &symbol, const ArraySpec &arraySpec) {
+  if (arraySpec.Rank() == 0) {
+    return;
+  }
+  bool isExplicit{arraySpec.IsExplicitShape()};
+  bool isDeferred{arraySpec.IsDeferredShape()};
+  bool isImplied{arraySpec.IsImpliedShape()};
+  bool isAssumedShape{arraySpec.IsAssumedShape()};
+  bool isAssumedSize{arraySpec.IsAssumedSize()};
+  bool isAssumedRank{arraySpec.IsAssumedRank()};
+  std::optional<parser::MessageFixedText> msg;
+  if (symbol.test(Symbol::Flag::CrayPointee) && !isExplicit && !isAssumedSize) {
+    msg = "Cray pointee '%s' must have must have explicit shape or"
+          " assumed size"_err_en_US;
+  } else if (IsAllocatableOrPointer(symbol) && !isDeferred && !isAssumedRank) {
+    if (symbol.owner().IsDerivedType()) {  // C745
+      if (IsAllocatable(symbol)) {
+        msg = "Allocatable array component '%s' must have"
+              " deferred shape"_err_en_US;
+      } else {
+        msg = "Array pointer component '%s' must have deferred shape"_err_en_US;
+      }
+    } else {
+      if (IsAllocatable(symbol)) {  // C832
+        msg = "Allocatable array '%s' must have deferred shape or"
+              " assumed rank"_err_en_US;
+      } else {
+        msg = "Array pointer '%s' must have deferred shape or"
+              " assumed rank"_err_en_US;
+      }
+    }
+  } else if (symbol.IsDummy()) {
+    if (isImplied && !isAssumedSize) {  // C836
+      msg = "Dummy array argument '%s' may not have implied shape"_err_en_US;
+    }
+  } else if (isAssumedShape && !isDeferred) {
+    msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
+  } else if (isAssumedSize && !isImplied) {  // C833
+    msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
+  } else if (isAssumedRank) {  // C837
+    msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
+  } else if (isImplied) {
+    if (!IsNamedConstant(symbol)) {  // C836
+      msg = "Implied-shape array '%s' must be a named constant"_err_en_US;
+    }
+  } else if (IsNamedConstant(symbol)) {
+    if (!isExplicit && !isImplied) {
+      msg = "Named constant '%s' array must have explicit or"
+            " implied shape"_err_en_US;
+    }
+  } else if (!IsAllocatableOrPointer(symbol) && !isExplicit) {
+    if (symbol.owner().IsDerivedType()) {  // C749
+      msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must"
+            " have explicit shape"_err_en_US;
+    } else {  // C816
+      msg = "Array '%s' without ALLOCATABLE or POINTER attribute must have"
+            " explicit shape"_err_en_US;
+    }
+  }
+  if (msg) {
+    context_.Say(std::move(*msg), symbol.name());
+  }
+}
+
 void CheckHelper::CheckProcEntity(
     const Symbol &symbol, const ProcEntityDetails &details) {
   if (details.isDummy()) {

diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc
index 412b836..a1bf22e 100644 (file)
--- a/flang/lib/semantics/resolve-names.cc
+++ b/flang/lib/semantics/resolve-names.cc
@@ -888,7 +888,6 @@ private:
   void Initialization(const parser::Name &, const parser::Initialization &,
       bool inComponentDecl);
   bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol);
-  bool CheckArraySpec(const parser::Name &, const Symbol &, const ArraySpec &);
 
   // Declare an object or procedure entity.
   // T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails
@@ -3170,10 +3169,8 @@ Symbol &DeclarationVisitor::DeclareObjectEntity(
         Say(name,
             "The dimensions of '%s' have already been declared"_err_en_US);
         context().SetError(symbol);
-      } else if (CheckArraySpec(name, symbol, arraySpec())) {
-        details->set_shape(arraySpec());
       } else {
-        context().SetError(symbol);
+        details->set_shape(arraySpec());
       }
     }
     if (!coarraySpec().empty()) {
@@ -3193,96 +3190,6 @@ Symbol &DeclarationVisitor::DeclareObjectEntity(
   return symbol;
 }
 
-// The six different kinds of array-specs:
-//   array-spec     -> explicit-shape-list | deferred-shape-list
-//                     | assumed-shape-list | implied-shape-list
-//                     | assumed-size | assumed-rank
-//   explicit-shape -> [ lb : ] ub
-//   deferred-shape -> :
-//   assumed-shape  -> [ lb ] :
-//   implied-shape  -> [ lb : ] *
-//   assumed-size   -> [ explicit-shape-list , ] [ lb : ] *
-//   assumed-rank   -> ..
-// Note:
-// - deferred-shape is also an assumed-shape
-// - A single "*" or "lb:*" might be assumed-size or implied-shape-list
-bool DeclarationVisitor::CheckArraySpec(const parser::Name &name,
-    const Symbol &symbol, const ArraySpec &arraySpec) {
-  if (arraySpec.Rank() == 0) {
-    return true;
-  }
-  bool isExplicit{arraySpec.IsExplicitShape()};
-  bool isDeferred{arraySpec.IsDeferredShape()};
-  bool isImplied{arraySpec.IsImpliedShape()};
-  bool isAssumedShape{arraySpec.IsAssumedShape()};
-  bool isAssumedSize{arraySpec.IsAssumedSize()};
-  bool isAssumedRank{arraySpec.IsAssumedRank()};
-  if (symbol.test(Symbol::Flag::CrayPointee) && !isExplicit && !isAssumedSize) {
-    Say(name,
-        "Cray pointee '%s' must have must have explicit shape or assumed size"_err_en_US);
-    return false;
-  }
-  if (IsAllocatableOrPointer(symbol) && !isDeferred && !isAssumedRank) {
-    if (symbol.owner().IsDerivedType()) {  // C745
-      if (IsAllocatable(symbol)) {
-        Say(name,
-            "Allocatable array component '%s' must have deferred shape"_err_en_US);
-      } else {
-        Say(name,
-            "Array pointer component '%s' must have deferred shape"_err_en_US);
-      }
-    } else {
-      if (IsAllocatable(symbol)) {  // C832
-        Say(name,
-            "Allocatable array '%s' must have deferred shape or assumed rank"_err_en_US);
-      } else {
-        Say(name,
-            "Array pointer '%s' must have deferred shape or assumed rank"_err_en_US);
-      }
-    }
-    return false;
-  }
-  if (symbol.IsDummy()) {
-    if (isImplied && !isAssumedSize) {  // C836
-      Say(name,
-          "Dummy array argument '%s' may not have implied shape"_err_en_US);
-      return false;
-    }
-  } else if (isAssumedShape && !isDeferred) {
-    Say(name, "Assumed-shape array '%s' must be a dummy argument"_err_en_US);
-    return false;
-  } else if (isAssumedSize && !isImplied) {  // C833
-    Say(name, "Assumed-size array '%s' must be a dummy argument"_err_en_US);
-    return false;
-  } else if (isAssumedRank) {  // C837
-    Say(name, "Assumed-rank array '%s' must be a dummy argument"_err_en_US);
-    return false;
-  } else if (isImplied) {
-    if (!IsNamedConstant(symbol)) {  // C836
-      Say(name, "Implied-shape array '%s' must be a named constant"_err_en_US);
-      return false;
-    }
-  } else if (IsNamedConstant(symbol)) {
-    if (!isExplicit && !isImplied) {
-      Say(name,
-          "Named constant '%s' array must have explicit or implied shape"_err_en_US);
-      return false;
-    }
-  } else if (!IsAllocatableOrPointer(symbol) && !isExplicit) {
-    if (symbol.owner().IsDerivedType()) {  // C749
-      Say(name,
-          "Component array '%s' without ALLOCATABLE or POINTER attribute must"
-          " have explicit shape"_err_en_US);
-    } else {  // C816
-      Say(name,
-          "Array '%s' without ALLOCATABLE or POINTER attribute must have"
-          " explicit shape"_err_en_US);
-    }
-    return false;
-  }
-  return true;
-}
-
 void DeclarationVisitor::Post(const parser::IntegerTypeSpec &x) {
   SetDeclTypeSpec(MakeNumericType(TypeCategory::Integer, x.v));
 }
@@ -3911,15 +3818,14 @@ bool DeclarationVisitor::Pre(const parser::BasedPointerStmt &x) {
       BeginArraySpec();
       Walk(std::get<std::optional<parser::ArraySpec>>(bp.t));
       const auto &spec{arraySpec()};
-      if (spec.empty()) {
-        // No array spec
-        CheckArraySpec(
-            pointeeName, pointee, pointee.get<ObjectEntityDetails>().shape());
-      } else if (pointee.Rank() > 0) {
-        SayWithDecl(pointeeName, pointee,
-            "Array spec was already declared for '%s'"_err_en_US);
-      } else if (CheckArraySpec(pointeeName, pointee, spec)) {
-        pointee.get<ObjectEntityDetails>().set_shape(spec);
+      if (!spec.empty()) {
+        auto &details{pointee.get<ObjectEntityDetails>()};
+        if (details.shape().empty()) {
+          details.set_shape(spec);
+        } else {
+          SayWithDecl(pointeeName, pointee,
+              "Array spec was already declared for '%s'"_err_en_US);
+        }
       }
       ClearArraySpec();
       currScope().add_crayPointer(pointeeName.source, *pointer);

diff --git a/flang/test/semantics/resolve58.f90 b/flang/test/semantics/resolve58.f90
index c0271e5..00232dc 100644 (file)
--- a/flang/test/semantics/resolve58.f90
+++ b/flang/test/semantics/resolve58.f90
@@ -48,3 +48,10 @@ function f()
   !ERROR: Array 'f' without ALLOCATABLE or POINTER attribute must have explicit shape
   real, dimension(:) :: f  ! C832
 end
+
+subroutine s5()
+  !ERROR: Allocatable array 'a' must have deferred shape or assumed rank
+  integer :: a(10), b(:)
+  allocatable :: a
+  allocatable :: b
+end subroutine

diff --git a/flang/test/semantics/resolve61.f90 b/flang/test/semantics/resolve61.f90
index 0a416d0..727b264 100644 (file)
--- a/flang/test/semantics/resolve61.f90
+++ b/flang/test/semantics/resolve61.f90
@@ -44,8 +44,8 @@ program p7
 contains
   subroutine s(x, y)
     real :: x(*)  ! assumed size
-    real :: y(:)  ! assumed shape
     !ERROR: Cray pointee 'y' must have must have explicit shape or assumed size
+    real :: y(:)  ! assumed shape
     pointer(w, y)
   end
 end