llvm · klausler · Jan 14, 2025 · Jan 9, 2025
diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h
@@ -183,8 +183,12 @@ class GetShapeHelper
   }
   template <typename D, typename R, typename LO, typename RO>
   Result operator()(const Operation<D, R, LO, RO> &operation) const {
-    if (operation.right().Rank() > 0) {
-      return (*this)(operation.right());
+    if (int rr{operation.right().Rank()}; rr > 0) {
+      if (int lr{operation.left().Rank()}; lr == 0 || lr == rr) {
+        return (*this)(operation.right());
+      } else {
+        return std::nullopt;
+      }
     } else {
       return (*this)(operation.left());
     }

diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
@@ -1643,8 +1643,12 @@ auto ApplyElementwise(FoldingContext &context,
     -> std::optional<Expr<RESULT>> {
   auto resultLength{ComputeResultLength(operation)};
   auto &leftExpr{operation.left()};
-  leftExpr = Fold(context, std::move(leftExpr));
   auto &rightExpr{operation.right()};
+  if (leftExpr.Rank() != rightExpr.Rank() && leftExpr.Rank() != 0 &&
+      rightExpr.Rank() != 0) {
+    return std::nullopt; // error recovery
+  }
+  leftExpr = Fold(context, std::move(leftExpr));
   rightExpr = Fold(context, std::move(rightExpr));
   if (leftExpr.Rank() > 0) {
     if (std::optional<Shape> leftShape{GetShape(context, leftExpr)}) {

diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
@@ -254,7 +254,8 @@ class GetLowerBoundHelper
       if (dimension_ < rank) {
         const semantics::ShapeSpec &shapeSpec{object->shape()[dimension_]};
         if (shapeSpec.lbound().isExplicit()) {
-          if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) {
+          if (const auto &lbound{shapeSpec.lbound().GetExplicit()};
+              lbound && lbound->Rank() == 0) {
             if constexpr (LBOUND_SEMANTICS) {
               bool ok{false};
               auto lbValue{ToInt64(*lbound)};
@@ -266,7 +267,8 @@ class GetLowerBoundHelper
               } else if (lbValue.value_or(0) == 1) {
                 // Lower bound is 1, regardless of extent
                 ok = true;
-              } else if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) {
+              } else if (const auto &ubound{shapeSpec.ubound().GetExplicit()};
+                  ubound && ubound->Rank() == 0) {
                 // If we can't prove that the dimension is nonempty,
                 // we must be conservative.
                 // TODO: simple symbolic math in expression rewriting to
@@ -459,7 +461,7 @@ static MaybeExtentExpr GetNonNegativeExtent(
     } else {
       return ExtentExpr{*uval - *lval + 1};
     }
-  } else if (lbound && ubound &&
+  } else if (lbound && ubound && lbound->Rank() == 0 && ubound->Rank() == 0 &&
       (!invariantOnly ||
           (IsScopeInvariantExpr(*lbound) && IsScopeInvariantExpr(*ubound)))) {
     // Apply effective IDIM (MAX calculation with 0) so thet the
@@ -608,7 +610,8 @@ MaybeExtentExpr GetRawUpperBound(
     int rank{details->shape().Rank()};
     if (dimension < rank) {
       const auto &bound{details->shape()[dimension].ubound().GetExplicit()};
-      if (bound && (!invariantOnly || IsScopeInvariantExpr(*bound))) {
+      if (bound && bound->Rank() == 0 &&
+          (!invariantOnly || IsScopeInvariantExpr(*bound))) {
         return *bound;
       } else if (semantics::IsAssumedSizeArray(symbol) &&
           dimension + 1 == symbol.Rank()) {
@@ -640,7 +643,8 @@ MaybeExtentExpr GetRawUpperBound(FoldingContext &context,
 static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,
     const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
   const auto &ubound{shapeSpec.ubound().GetExplicit()};
-  if (ubound && (!invariantOnly || IsScopeInvariantExpr(*ubound))) {
+  if (ubound && ubound->Rank() == 0 &&
+      (!invariantOnly || IsScopeInvariantExpr(*ubound))) {
     if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
       if (auto cstExtent{ToInt64(
               context ? Fold(*context, std::move(*extent)) : *extent)}) {
@@ -731,7 +735,8 @@ MaybeExtentExpr GetLCOBOUND(
     if (dimension < corank) {
       const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]};
       if (const auto &lcobound{shapeSpec.lbound().GetExplicit()}) {
-        if (!invariantOnly || IsScopeInvariantExpr(*lcobound)) {
+        if (lcobound->Rank() == 0 &&
+            (!invariantOnly || IsScopeInvariantExpr(*lcobound))) {
           return *lcobound;
         }
       }
@@ -748,7 +753,8 @@ MaybeExtentExpr GetUCOBOUND(
     if (dimension < corank - 1) {
       const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]};
       if (const auto ucobound{shapeSpec.ubound().GetExplicit()}) {
-        if (!invariantOnly || IsScopeInvariantExpr(*ucobound)) {
+        if (ucobound->Rank() == 0 &&
+            (!invariantOnly || IsScopeInvariantExpr(*ucobound))) {
           return *ucobound;
         }
       }
@@ -822,7 +828,7 @@ auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
             if (subp.isFunction()) {
               auto resultShape{(*this)(subp.result())};
               if (resultShape && !useResultSymbolShape_) {
-                // Ensure the shape is constant. Otherwise, it may be referring
+                // Ensure the shape is constant. Otherwise, it may be reerring
                 // to symbols that belong to the function's scope and are
                 // meaningless on the caller side without the related call
                 // expression.
@@ -908,23 +914,33 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
       if (auto chars{characteristics::Procedure::FromActuals(
               call.proc(), call.arguments(), *context_)}) {
         std::size_t j{0};
-        std::size_t anyArrayArgRank{0};
+        const ActualArgument *nonOptionalArrayArg{nullptr};
+        int anyArrayArgRank{0};
         for (const auto &arg : call.arguments()) {
           if (arg && arg->Rank() > 0 && j < chars->dummyArguments.size()) {
-            anyArrayArgRank = arg->Rank();
-            if (!chars->dummyArguments[j].IsOptional()) {
-              return (*this)(*arg);
+            if (!anyArrayArgRank) {
+              anyArrayArgRank = arg->Rank();
+            } else if (arg->Rank() != anyArrayArgRank) {
+              return std::nullopt; // error recovery
+            }
+            if (!nonOptionalArrayArg &&
+                !chars->dummyArguments[j].IsOptional()) {
+              nonOptionalArrayArg = &*arg;
             }
           }
           ++j;
         }
         if (anyArrayArgRank) {
-          // All dummy array arguments of the procedure are OPTIONAL.
-          // We cannot take the shape from just any array argument,
-          // because all of them might be OPTIONAL dummy arguments
-          // of the caller. Return unknown shape ranked according
-          // to the last actual array argument.
-          return Shape(anyArrayArgRank, MaybeExtentExpr{});
+          if (nonOptionalArrayArg) {
+            return (*this)(*nonOptionalArrayArg);
+          } else {
+            // All dummy array arguments of the procedure are OPTIONAL.
+            // We cannot take the shape from just any array argument,
+            // because all of them might be OPTIONAL dummy arguments
+            // of the caller. Return unknown shape ranked according
+            // to the last actual array argument.
+            return Shape(anyArrayArgRank, MaybeExtentExpr{});
+          }
         }
       }
     }

diff --git a/flang/test/Semantics/bug122002a.f90 b/flang/test/Semantics/bug122002a.f90
@@ -0,0 +1,5 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! ERROR: Missing initialization for parameter 'n'
+! ERROR: Must be a scalar value, but is a rank-1 array
+integer, parameter :: n(n)
+end
diff --git a/flang/test/Semantics/bug122002b.f90 b/flang/test/Semantics/bug122002b.f90
@@ -0,0 +1,13 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+SUBROUTINE sub00(a,b,n,m)
+  complex(2) n,m
+! ERROR: Must have INTEGER type, but is COMPLEX(2)
+! ERROR: Must have INTEGER type, but is COMPLEX(2)
+! ERROR: The type of 'b' has already been implicitly declared
+  complex(3) a(n,m), b(size((LOG ((x * (a) - a + b / a - a))+1 - x)))
+  a = a ** n
+! ERROR: DO controls should be INTEGER
+  DO 10 j = 1,m
+    a = n ** a
+    10   PRINT *, g
+END SUBROUTINE sub00