[flang] Add one semantic check for masked array assignment

[peixin]

Summary

As Fortran 2018 states, in each where-assignment-stmt, the mask-expr and
the variable being defined shall be arrays of the same shape. The
previous check does not consider checking if it is an array.

[klausler]

flang/lib/Semantics/assignment.cpp

223

This message is correct but it might be more clear to say that the variable and mask must not be scalars.

[peixin]

Change the semantic info into "The mask or variable must not be scalar" according to @klausler 's comments.

flang/lib/Semantics/assignment.cpp

if (isPointerAssignment) {
           return CheckCopyabilityInPureScope(messages, rhs, scope);
         }
       }
     }
   }
   return true;
 }
 
-// 10.2.3.1(2) The masks and LHS of assignments must all have the same shape
+// 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape
 void AssignmentContext::CheckShape(parser::CharBlock at, const SomeExpr *expr) {
   if (auto shape{evaluate::GetShape(foldingContext(), expr)}) {
     std::size_t size{shape->size()};
+    if (size == 0) {
+      Say(at, "The mask or variable must not be scalar"_err_en_US);
+    }
     if (whereDepth_ == 0) {
       whereExtents_.resize(size);
     } else if (whereExtents_.size() != size) {
       Say(at,
           "Must have rank %zd to match prior mask or assignment of"
           " WHERE construct"_err_en_US,
           whereExtents_.size());
       return;

flang/test/Semantics/assign01.f90

where(m1)
     x = y
     !ERROR: Dimension 2 must have extent 4 to match prior mask or assignment of WHERE construct
     a = b
     !ERROR: Dimension 2 must have extent 4 to match prior mask or assignment of WHERE construct
     where(m2)
     end where
   end where
 end
+
+subroutine s4
+  integer :: x1 = 0, x2(2) = 0
+  logical :: l1 = .false., l2(2) = (/.true., .false./), l3 = .false.
+  !ERROR: The mask or variable must not be scalar
+  where (l1)
+    !ERROR: The mask or variable must not be scalar
+    x1 = 1
+  end where
+  !ERROR: The mask or variable must not be scalar
+  where (l1)
+    !ERROR: The mask or variable must not be scalar
+    where (l3)
+      !ERROR: The mask or variable must not be scalar
+      x1 = 1
+    end where
+  end where
+  !ERROR: The mask or variable must not be scalar
+  where (l2(2))
+    !ERROR: The mask or variable must not be scalar
+    x2(2) = 1
+  end where
+end

flang/test/Semantics/assign04.f90

subroutine s13()
   real :: x(1)
   integer :: n(1)
   x='0' ! fine
   n='0' ! fine
   !ERROR: Defined assignment in WHERE must be elemental, but 'ctora' is not
   where ([1==1]) x='*'
   where ([1==1]) n='*' ! fine
   forall (j=1:1)
+    !ERROR: The mask or variable must not be scalar
     where (j==1)
       !ERROR: Defined assignment in WHERE must be elemental, but 'ctor' is not
+      !ERROR: The mask or variable must not be scalar
       x(j)='?'
+      !ERROR: The mask or variable must not be scalar
       n(j)='?' ! fine
+    !ERROR: The mask or variable must not be scalar
     elsewhere (.false.)
       !ERROR: Defined assignment in WHERE must be elemental, but 'ctor' is not
+      !ERROR: The mask or variable must not be scalar
       x(j)='1'
+      !ERROR: The mask or variable must not be scalar
       n(j)='1' ! fine
     elsewhere
       !ERROR: Defined assignment in WHERE must be elemental, but 'ctor' is not
+      !ERROR: The mask or variable must not be scalar
       x(j)='9'
+      !ERROR: The mask or variable must not be scalar
       n(j)='9' ! fine
     end where
   end forall
   x='0' ! still fine
   n='0' ! still fine
  contains
   subroutine cToR(x, c)
     real, intent(out) :: x