[flang] Compile-time checks for shape conformance on assignments

[klausler]

Summary

Assignment statements need to check for array shape conformance
errors that are discernable at compilation time.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Semantics/expression.cpp

public:
 
   bool IsIntrinsicRelational(
       RelationalOperator, const DynamicType &, const DynamicType &) const;
   bool IsIntrinsicLogical() const;
   bool IsIntrinsicNumeric(NumericOperator) const;
   bool IsIntrinsicConcat() const;
 
   bool CheckConformance();
+  bool CheckAssignmentConformance();
   bool CheckForNullPointer(const char *where = "as an operand here");
 
   // Find and return a user-defined operator or report an error.
   // The provided message is used if there is no such operator.
   MaybeExpr TryDefinedOp(const char *, parser::MessageFixedText,
       const Symbol **definedOpSymbolPtr = nullptr, bool isUserOp = false);
   template <typename E>
   MaybeExpr TryDefinedOp(E opr, parser::MessageFixedText msg) {
if (!context_.AnyFatalError()) {
           dump.str());
     }
   }
 }
 
 const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
   if (!x.typedAssignment) {
     ArgumentAnalyzer analyzer{*this};
-    analyzer.Analyze(std::get<parser::Variable>(x.t));
+    const auto &variable{std::get<parser::Variable>(x.t)};
+    analyzer.Analyze(variable);
     analyzer.Analyze(std::get<parser::Expr>(x.t));
     std::optional<Assignment> assignment;
     if (!analyzer.fatalErrors()) {
+      auto restorer{GetContextualMessages().SetLocation(variable.GetSource())};
       std::optional<ProcedureRef> procRef{analyzer.TryDefinedAssignment()};
       if (!procRef) {
         analyzer.CheckForNullPointer(
             "in a non-pointer intrinsic assignment statement");
       }
       assignment.emplace(analyzer.MoveExpr(0), analyzer.MoveExpr(1));
       if (procRef) {
         assignment->u = std::move(*procRef);
if (lhs && rhs) {
           return false;
         }
       }
     }
   }
   return true; // no proven problem
 }
 
+bool ArgumentAnalyzer::CheckAssignmentConformance() {
+  if (actuals_.size() == 2) {
+    const auto *lhs{actuals_.at(0).value().UnwrapExpr()};
+    const auto *rhs{actuals_.at(1).value().UnwrapExpr()};
+    if (lhs && rhs) {
+      auto &foldingContext{context_.GetFoldingContext()};
+      auto lhShape{GetShape(foldingContext, *lhs)};
+      auto rhShape{GetShape(foldingContext, *rhs)};
+      if (lhShape && rhShape) {
+        if (!evaluate::CheckConformance(foldingContext.messages(), *lhShape,
+                *rhShape, CheckConformanceFlags::RightScalarExpandable,
+                "left-hand side", "right-hand side")
+                 .value_or(true /*ok when conformance is not known now*/)) {
+          fatalErrors_ = true;
+          return false;
+        }
+      }
+    }
+  }
+  return true; // no proven problem
+}
+
 bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {
   for (const std::optional<ActualArgument> &arg : actuals_) {
     if (arg) {
       if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
         if (IsNullPointer(*expr)) {
           context_.Say(
               source_, "A NULL() pointer is not allowed %s"_err_en_US, where);
           fatalErrors_ = true;
std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {
   int lhsRank{lhs.Rank()};
   int rhsRank{rhs.Rank()};
   Tristate isDefined{
       semantics::IsDefinedAssignment(lhsType, lhsRank, rhsType, rhsRank)};
   if (isDefined == Tristate::No) {
     if (lhsType && rhsType) {
       AddAssignmentConversion(*lhsType, *rhsType);
     }
+    if (!fatalErrors_) {
+      CheckAssignmentConformance();
+    }
     return std::nullopt; // user-defined assignment not allowed for these args
   }
   auto restorer{context_.GetContextualMessages().SetLocation(source_)};
   if (std::optional<ProcedureRef> procRef{GetDefinedAssignmentProc()}) {
     if (context_.inWhereBody() && !procRef->proc().IsElemental()) { // C1032
       context_.Say(
           "Defined assignment in WHERE must be elemental, but '%s' is not"_err_en_US,
           DEREF(procRef->proc().GetSymbol()).name());

flang/test/Lower/Intrinsics/matmul.f90

 ! RUN: bbc -emit-fir %s -o - | FileCheck %s
 ! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s
 
 ! Test matmul intrinsic
 
 ! CHECK-LABEL: matmul_test
-! CHECK-SAME: (%[[X:.*]]: !fir.ref<!fir.array<3x1xf32>>{{.*}}, %[[Y:.*]]: !fir.ref<!fir.array<1x3xf32>>{{.*}}, %[[Z:.*]]: !fir.ref<!fir.array<2x2xf32>>{{.*}})
+! CHECK-SAME: (%[[X:.*]]: !fir.ref<!fir.array<3x1xf32>>{{.*}}, %[[Y:.*]]: !fir.ref<!fir.array<1x3xf32>>{{.*}}, %[[Z:.*]]: !fir.ref<!fir.array<3x3xf32>>{{.*}})
 ! CHECK:  %[[RESULT_BOX_ADDR:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?xf32>>>
 ! CHECK:  %[[C3:.*]] = arith.constant 3 : index
 ! CHECK:  %[[C1:.*]] = arith.constant 1 : index
 ! CHECK:  %[[C1_0:.*]] = arith.constant 1 : index
 ! CHECK:  %[[C3_1:.*]] = arith.constant 3 : index
-! CHECK:  %[[Z_BOX:.*]] = fir.array_load %[[Z]]({{.*}}) : (!fir.ref<!fir.array<2x2xf32>>, !fir.shape<2>) -> !fir.array<2x2xf32>
+! CHECK:  %[[Z_BOX:.*]] = fir.array_load %[[Z]]({{.*}}) : (!fir.ref<!fir.array<3x3xf32>>, !fir.shape<2>) -> !fir.array<3x3xf32>
 ! CHECK:  %[[X_SHAPE:.*]] = fir.shape %[[C3]], %[[C1]] : (index, index) -> !fir.shape<2>
 ! CHECK:  %[[X_BOX:.*]] = fir.embox %[[X]](%[[X_SHAPE]]) : (!fir.ref<!fir.array<3x1xf32>>, !fir.shape<2>) -> !fir.box<!fir.array<3x1xf32>>
 ! CHECK:  %[[Y_SHAPE:.*]] = fir.shape %[[C1_0]], %[[C3_1]] : (index, index) -> !fir.shape<2>
 ! CHECK:  %[[Y_BOX:.*]] = fir.embox %[[Y]](%[[Y_SHAPE]]) : (!fir.ref<!fir.array<1x3xf32>>, !fir.shape<2>) -> !fir.box<!fir.array<1x3xf32>>
 ! CHECK:  %[[ZERO_INIT:.*]] = fir.zero_bits !fir.heap<!fir.array<?x?xf32>>
 ! CHECK:  %[[C0:.*]] = arith.constant 0 : index
 ! CHECK:  %[[RESULT_SHAPE:.*]] = fir.shape %[[C0]], %[[C0]] : (index, index) -> !fir.shape<2>
 ! CHECK:  %[[RESULT_BOX_VAL:.*]] = fir.embox %[[ZERO_INIT]](%[[RESULT_SHAPE]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
 ! CHECK:  fir.store %[[RESULT_BOX_VAL]] to %[[RESULT_BOX_ADDR]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
 ! CHECK:  %[[RESULT_BOX_ADDR_RUNTIME:.*]] = fir.convert %[[RESULT_BOX_ADDR]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK:  %[[X_BOX_RUNTIME:.*]] = fir.convert %[[X_BOX]] : (!fir.box<!fir.array<3x1xf32>>) -> !fir.box<none>
 ! CHECK:  %[[Y_BOX_RUNTIME:.*]] = fir.convert %[[Y_BOX]] : (!fir.box<!fir.array<1x3xf32>>) -> !fir.box<none>
 ! CHECK:  {{.*}}fir.call @_FortranAMatmul(%[[RESULT_BOX_ADDR_RUNTIME]], %[[X_BOX_RUNTIME]], %[[Y_BOX_RUNTIME]], {{.*}}, {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, i32) -> none
 ! CHECK:  %[[RESULT_BOX:.*]] = fir.load %[[RESULT_BOX_ADDR]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
 ! CHECK:  %[[RESULT_TMP:.*]] = fir.box_addr %[[RESULT_BOX]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>) -> !fir.heap<!fir.array<?x?xf32>>
 ! CHECK:  %[[Z_COPY_FROM_RESULT:.*]] = fir.do_loop
 ! CHECK:    {{.*}}fir.array_fetch
 ! CHECK:    {{.*}}fir.array_update
 ! CHECK:    fir.result
 ! CHECK:  }
-! CHECK:  fir.array_merge_store %[[Z_BOX]], %[[Z_COPY_FROM_RESULT]] to %[[Z]] : !fir.array<2x2xf32>, !fir.array<2x2xf32>, !fir.ref<!fir.array<2x2xf32>>
+! CHECK:  fir.array_merge_store %[[Z_BOX]], %[[Z_COPY_FROM_RESULT]] to %[[Z]] : !fir.array<3x3xf32>, !fir.array<3x3xf32>, !fir.ref<!fir.array<3x3xf32>>
 ! CHECK:  fir.freemem %[[RESULT_TMP]] : !fir.heap<!fir.array<?x?xf32>>
 subroutine matmul_test(x,y,z)
-  real :: x(3,1), y(1,3), z(2,2)
+  real :: x(3,1), y(1,3), z(3,3)
   z = matmul(x,y)
 end subroutine
 
 ! CHECK-LABEL: matmul_test2
 ! CHECK-SAME: (%[[X_BOX:.*]]: !fir.box<!fir.array<?x?x!fir.logical<4>>>{{.*}}, %[[Y_BOX:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>{{.*}}, %[[Z_BOX:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>{{.*}})
 !CHECK:  %[[RESULT_BOX_ADDR:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>
 !CHECK:  %[[Z:.*]] = fir.array_load %[[Z_BOX]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.array<?x!fir.logical<4>>
 !CHECK:  %[[ZERO_INIT:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.logical<4>>>

flang/test/Lower/array-constructor-2.f90

subroutine test5(a, array2)
   ! CHECK-DAG: fir.freemem %[[tmp2]] : !fir.heap<!fir.array<2xf32>>
   ! CHECK-DAG: fir.freemem %[[tmp1]] : !fir.heap<!fir.array<2xf32>>
   ! CHECK: return
   a = [ const_array1, array2 ]
 end subroutine test5
 
 ! CHECK-LABEL: func @_QPtest6(
 subroutine test6(c, d, e)
-  character(5) :: c(3)
+  character(5) :: c(2)
   character(5) :: d, e
   ! CHECK: = fir.allocmem !fir.array<2x!fir.char<1,5>>
   ! CHECK: fir.call @realloc
   ! CHECK: %[[t:.*]] = fir.coordinate_of %{{.*}}, %{{.*}} : (!fir.heap<!fir.array<2x!fir.char<1,5>>>, index) -> !fir.ref<!fir.char<1,5>>
   ! CHECK: %[[to:.*]] = fir.convert %[[t]] : (!fir.ref<!fir.char<1,5>>) -> !fir.ref<i8>
   ! CHECK: fir.call @llvm.memcpy.p0.p0.i64(%[[to]], %{{.*}}, %{{.*}}, %false) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
   ! CHECK: fir.call @realloc
   ! CHECK: %[[t:.*]] = fir.coordinate_of %{{.*}}, %{{.*}} : (!fir.heap<!fir.array<2x!fir.char<1,5>>>, index) -> !fir.ref<!fir.char<1,5>>

flang/test/Semantics/array-constr-values.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Confirm enforcement of constraints and restrictions in 7.8
 ! C7110, C7111, C7112, C7113, C7114, C7115
 
 subroutine arrayconstructorvalues()
-  integer :: intarray(5)
+  integer :: intarray(4)
   integer(KIND=8) :: k8 = 20
 
   TYPE EMPLOYEE
     INTEGER AGE
     CHARACTER (LEN = 30) NAME
   END TYPE EMPLOYEE
   TYPE EMPLOYEER
     CHARACTER (LEN = 30) NAME

flang/test/Semantics/assign10.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Shape conformance checks on assignments
+program test
+  real :: a0, a1a(2), a1b(3), a2a(2,3), a2b(3,2)
+  a0 = 0. ! ok
+  !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar REAL(4) and rank 1 array of REAL(4)
+  a0 = [0.]
+  a1a = 0. ! ok
+  a1a = [(real(j),j=1,2)] ! ok
+  !ERROR: Dimension 1 of left-hand side has extent 2, but right-hand side has extent 3
+  a1a = [(real(j),j=1,3)]
+  !ERROR: Dimension 1 of left-hand side has extent 3, but right-hand side has extent 2
+  a1b = a1a
+  !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches rank 1 array of REAL(4) and rank 2 array of REAL(4)
+  a1a = a2a
+  a1a = a2a(:,1) ! ok
+  a2a = 0. ! ok
+  a2a(:,1) = a1a ! ok
+  !ERROR: Dimension 1 of left-hand side has extent 3, but right-hand side has extent 2
+  a2a(1,:) = a1a
+  !ERROR: Dimension 1 of left-hand side has extent 2, but right-hand side has extent 3
+  a2a = a2b
+end