[flang] Fixes for RESHAPE()

[PeteSteinfeld]

Summary

I fixed an assert caused by passing an empty array as the source= argument to
RESHAPE(). In the process, I noticed that there were no tests for RESHAPE(),
so I wrote a test that covers all the description in 16.9.163. In the process,
I made the error messages more consistent and descriptive. I also changed the
test to see if a reference to an intrinsic function was a constant to say that
it is a constant if it's a refererence to an invalid intrinsic. This avoids
emitting multiple messages for the same erroneous source.

[tskeith]

flang/lib/Evaluate/fold-implementation.h

621

This message doesn't need to be split to fit into 80 columns.

625

Same here.

flang/test/Semantics/reshape.f90

28

To be consistent with the messages above, order= should be in quotes.

[tskeith]

flang/lib/Evaluate/check-expression.cpp

49

This string should be a named constant, maybe in fold-implementation.h.

[PeteSteinfeld]

I fixed the error messages to put quotes around the names of arguments.

I also created a constant for the name of the invalid intrinsic created when
constant folding runs into errors.

flang/include/flang/Evaluate/constant.h

 std::size_t TotalElementCount(const ConstantSubscripts &);
 
 // Validate dimension re-ordering like ORDER in RESHAPE.
 // On success, return a vector that can be used as dimOrder in
 // ConstantBound::IncrementSubscripts().
 std::optional<std::vector<int>> ValidateDimensionOrder(
     int rank, const std::vector<int> &order);
 
-bool IsValidShape(const ConstantSubscripts &);
+bool HasNegativeExtent(const ConstantSubscripts &);
 
 class ConstantBounds {
 public:
   ConstantBounds() = default;
   explicit ConstantBounds(const ConstantSubscripts &shape);
   explicit ConstantBounds(ConstantSubscripts &&shape);
   ~ConstantBounds();
   const ConstantSubscripts &shape() const { return shape_; }

flang/include/flang/Evaluate/intrinsics.h

public:
   // untouched.
   std::optional<SpecificCall> Probe(
       const CallCharacteristics &, ActualArguments &, FoldingContext &) const;
 
   // Probe the intrinsics with the name of a potential specific intrinsic.
   std::optional<SpecificIntrinsicFunctionInterface> IsSpecificIntrinsicFunction(
       const std::string &) const;
 
+  // Illegal name for an intrinsic used to avoid cascading error messages when
+  // constant folding.
+  static const inline std::string InvalidName{
+      "(invalid intrinsic function call)"};
+
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
 private:
   Implementation *impl_{nullptr}; // owning pointer
 };
 } // namespace Fortran::evaluate
 #endif // FORTRAN_EVALUATE_INTRINSICS_H_

flang/lib/Evaluate/check-expression.cpp

return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
         IsInitialProcedureTarget(ultimate);
   }
   bool operator()(const CoarrayRef &) const { return false; }
   bool operator()(const semantics::ParamValue &param) const {
     return param.isExplicit() && (*this)(param.GetExplicit());
   }
   template <typename T> bool operator()(const FunctionRef<T> &call) const {
     if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
-      return intrinsic->name == "kind";
+      // kind is always a constant, and we avoid cascading errors by calling
+      // invalid calls to intrinsics constant
+      return intrinsic->name == "kind" ||
+          intrinsic->name == IntrinsicProcTable::InvalidName;
       // TODO: other inquiry intrinsics
     } else {
       return false;
     }
   }
   bool operator()(const StructureConstructor &constructor) const {
     for (const auto &[symRef, expr] : constructor) {
       if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {

flang/lib/Evaluate/constant.cpp

for (int j{0}; j < rank; ++j) {
       seenDimensions.set(dim - 1);
     }
     return dimOrder;
   } else {
     return std::nullopt;
   }
 }
 
-bool IsValidShape(const ConstantSubscripts &shape) {
+bool HasNegativeExtent(const ConstantSubscripts &shape) {
   for (ConstantSubscript extent : shape) {
     if (extent < 0) {
-      return false;
+      return true;
     }
   }
-  return shape.size() <= common::maxRank;
+  return false;
 }
 
 template <typename RESULT, typename ELEMENT>
 ConstantBase<RESULT, ELEMENT>::ConstantBase(
     std::vector<Element> &&x, ConstantSubscripts &&sh, Result res)
     : ConstantBounds(std::move(sh)), result_{res}, values_(std::move(x)) {
   CHECK(size() == TotalElementCount(shape()));
 }

flang/lib/Evaluate/fold-implementation.h

 #include "flang/Common/template.h"
 #include "flang/Common/unwrap.h"
 #include "flang/Evaluate/characteristics.h"
 #include "flang/Evaluate/common.h"
 #include "flang/Evaluate/constant.h"
 #include "flang/Evaluate/expression.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/formatting.h"
+#include "flang/Evaluate/intrinsics.h"
 #include "flang/Evaluate/shape.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Evaluate/traverse.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"

 }
 
 // Transform an intrinsic function reference that contains user errors
 // into an intrinsic with the same characteristic but the "invalid" name.
 // This to prevent generating warnings over and over if the expression
 // gets re-folded.
 template <typename T> Expr<T> MakeInvalidIntrinsic(FunctionRef<T> &&funcRef) {
   SpecificIntrinsic invalid{std::get<SpecificIntrinsic>(funcRef.proc().u)};
-  invalid.name = "(invalid intrinsic function call)";
+  invalid.name = IntrinsicProcTable::InvalidName;
   return Expr<T>{FunctionRef<T>{ProcedureDesignator{std::move(invalid)},
-      ActualArguments{ActualArgument{AsGenericExpr(std::move(funcRef))}}}};
+      ActualArguments{std::move(funcRef.arguments())}}};
 }
 
 template <typename T> Expr<T> Folder<T>::Reshape(FunctionRef<T> &&funcRef) {
   auto args{funcRef.arguments()};
   CHECK(args.size() == 4);
   const auto *source{UnwrapConstantValue<T>(args[0])};
   const auto *pad{UnwrapConstantValue<T>(args[2])};
   std::optional<std::vector<ConstantSubscript>> shape{
       GetIntegerVector<ConstantSubscript>(args[1])};
   std::optional<std::vector<int>> order{GetIntegerVector<int>(args[3])};
   if (!source || !shape || (args[2] && !pad) || (args[3] && !order)) {
     return Expr<T>{std::move(funcRef)}; // Non-constant arguments
-  } else if (!IsValidShape(shape.value())) {
-    context_.messages().Say("Invalid SHAPE in RESHAPE"_en_US);
+  } else if (shape.value().size() > common::maxRank) {
+    context_.messages().Say(
+        "Size of 'shape=' argument must not be greater than %d"_err_en_US,
+        common::maxRank);
+  } else if (HasNegativeExtent(shape.value())) {
+    context_.messages().Say(
+        "'shape=' argument must not have a negative extent"_err_en_US);
   } else {
     int rank{GetRank(shape.value())};
     std::size_t resultElements{TotalElementCount(shape.value())};
     std::optional<std::vector<int>> dimOrder;
     if (order) {
       dimOrder = ValidateDimensionOrder(rank, *order);
     }
     std::vector<int> *dimOrderPtr{dimOrder ? &dimOrder.value() : nullptr};
     if (order && !dimOrder) {
-      context_.messages().Say("Invalid ORDER in RESHAPE"_en_US);
+      context_.messages().Say("Invalid 'order=' argument in RESHAPE"_err_en_US);
     } else if (resultElements > source->size() && (!pad || pad->empty())) {
-      context_.messages().Say("Too few SOURCE elements in RESHAPE and PAD"
-                              "is not present or has null size"_en_US);
+      context_.messages().Say(
+          "Too few elements in 'source=' argument and 'pad=' "
+          "argument is not present or has null size"_err_en_US);
     } else {
-      Constant<T> result{!source->empty()
+      Constant<T> result{!source->empty() || !pad
               ? source->Reshape(std::move(shape.value()))
               : pad->Reshape(std::move(shape.value()))};
       ConstantSubscripts subscripts{result.lbounds()};
       auto copied{result.CopyFrom(*source,
           std::min(source->size(), resultElements), subscripts, dimOrderPtr)};
       if (copied < resultElements) {
         CHECK(pad);
         copied += result.CopyFrom(

flang/lib/Evaluate/intrinsics.cpp

if (const ActualArgument * arg{actualForDummy[j]}) {
       case Rank::scalar:
         argOk = rank == 0;
         break;
       case Rank::vector:
         argOk = rank == 1;
         break;
       case Rank::shape:
         CHECK(!shapeArgSize);
-        if (rank == 1) {
+        if (rank != 1) {
+          messages.Say(
+              "'shape=' argument must be an array of rank 1"_err_en_US);
+          return std::nullopt;
+        } else {
           if (auto shape{GetShape(context, *arg)}) {
             if (auto constShape{AsConstantShape(context, *shape)}) {
               shapeArgSize = constShape->At(ConstantSubscripts{1}).ToInt64();
               CHECK(shapeArgSize >= 0);
               argOk = true;
             }
           }
         }

flang/test/Semantics/reshape.f90

+! RUN: %S/test_errors.sh %s %t %f18
+
+!Tests for RESHAPE
+program reshaper
+  ! RESHAPE with arguments SOURCE and SHAPE
+  integer, parameter :: array1(2,3) = RESHAPE([(n, n=1,6)], [2,3])
+  ! RESHAPE with arguments SOURCE, SHAPE, and PAD
+  integer :: array2(2,3) = RESHAPE([(n, n=1,4)], [2,3], [99])
+  ! RESHAPE with arguments SOURCE, SHAPE, PAD, and ORDER
+  integer :: array3(2,3) = RESHAPE([(n, n=1,4)], [2,3], [99], [2, 1])
+  !ERROR: Too few elements in 'source=' argument and 'pad=' argument is not present or has null size
+  integer :: array4(2,3) = RESHAPE([(n, n=1,5)], [2,3])
+  !ERROR: Actual argument for 'shape=' has bad type 'REAL(4)'
+  integer :: array5(2,3) = RESHAPE([(n, n=1,6)], [2.2,3.3])
+  !ERROR: 'shape=' argument must be an array of rank 1
+  integer :: array6(2,3) = RESHAPE([(n, n=1,6)], RESHAPE([(n, n=1,6)], [2,3]))
+  !ERROR: 'shape=' argument must be an array of rank 1
+  integer :: array7(2,3) = RESHAPE([(n, n=1,4)], 343)
+  !ERROR: Actual argument for 'pad=' has bad type or kind 'INTEGER(8)'
+  integer :: array8(2,3) = RESHAPE([(n, n=1,4)], [2,3], [99_8])
+  !ERROR: Actual argument for 'pad=' has bad type or kind 'REAL(4)'
+  real :: array9(2,3) = RESHAPE([(n, n=1,4)], [2,3], [99.9])
+  !ERROR: Invalid 'order=' argument in RESHAPE
+  real :: array10(2,3) = RESHAPE([(n,n=1,4)],[2,3],[99],[2,3])
+  !ERROR: Actual argument for 'order=' has bad type 'REAL(4)'
+  real :: array11(2,3) = RESHAPE([(n, n=1,4)], [2,3], [99], [2.2,3.3])
+  !ERROR: Invalid 'order=' argument in RESHAPE
+  real :: array12(2,3) = RESHAPE([(n, n=1,4)], [2,3], [99], [1])
+  !ERROR: Invalid 'order=' argument in RESHAPE
+  real :: array13(2,3) = RESHAPE([(n, n = 1, 4)], [2, 3], [99], [1, 1])
+
+  ! Examples that have caused problems
+  integer :: array14(0,0,0) = RESHAPE([(n,n=1,0)],[0,0,0])
+  integer, parameter :: array15(1) = RESHAPE([(n,n=1,2)],[1])
+  integer, parameter :: array16(1) = RESHAPE([(n,n=1,8)],[1], [0], array15)
+  integer, parameter, dimension(3,4) :: array17 = 3
+  integer, parameter, dimension(3,4) :: array18 = RESHAPE(array17, [3,4])
+  ! Implicit reshape of array of components
+  type :: dType
+    integer :: field(2)
+  end type dType
+  type(dType), parameter :: array19(*) = [dType::dType(field=[1,2])]
+  logical, parameter :: lVar = all(array19(:)%field(1) == [2])
+
+  !ERROR: Size of 'shape=' argument must not be greater than 15
+  CALL ext_sub(RESHAPE([(n, n=1,20)], &
+    [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1]))
+  !ERROR: 'shape=' argument must not have a negative extent
+  CALL ext_sub(RESHAPE([(n, n=1,20)], [1, -5, 3]))
+end program reshaper