[flang] Check shape conformance on initializers

Specifically, ensure that initializers conform with their objects
according to 8.2 para 4.

Differential Revision: https://reviews.llvm.org/D86886

flang/lib/Evaluate/check-expression.cpp

@@ -310,7 +310,7 @@ public:
 
   Result operator()(const TypeParamInquiry &inq) const {
     if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
-        inq.parameter().owner() != scope_) { // C750, C754
+        inq.base() /* X%T, not local T */) { // C750, C754
       return "non-constant reference to a type parameter inquiry not "
              "allowed for derived type components or type parameter values";
     }

flang/lib/Evaluate/shape.cpp

@@ -684,9 +684,9 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
 
 bool CheckConformance(parser::ContextualMessages &messages, const Shape &left,
     const Shape &right, const char *leftIs, const char *rightIs) {
-  if (!left.empty() && !right.empty()) {
-    int n{GetRank(left)};
-    int rn{GetRank(right)};
+  int n{GetRank(left)};
+  int rn{GetRank(right)};
+  if (n != 0 && rn != 0) {
     if (n != rn) {
       messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
           leftIs, n, rightIs, rn);

flang/lib/Evaluate/tools.cpp

@@ -661,11 +661,6 @@ std::optional<Expr<SomeType>> ConvertToType(
 
 std::optional<Expr<SomeType>> ConvertToType(
     const Symbol &symbol, Expr<SomeType> &&x) {
-  if (int xRank{x.Rank()}; xRank > 0) {
-    if (symbol.Rank() != xRank) {
-      return std::nullopt;
-    }
-  }
   if (auto symType{DynamicType::From(symbol)}) {
     return ConvertToType(*symType, std::move(x));
   }

flang/lib/Semantics/check-declarations.cpp

@@ -30,6 +30,7 @@ using evaluate::characteristics::Procedure;
 class CheckHelper {
 public:
   explicit CheckHelper(SemanticsContext &c) : context_{c} {}
+  CheckHelper(SemanticsContext &c, const Scope &s) : context_{c}, scope_{&s} {}
 
   void Check() { Check(context_.globalScope()); }
   void Check(const ParamValue &, bool canBeAssumed);
@@ -42,6 +43,7 @@ public:
   void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);
   void Check(const Symbol &);
   void Check(const Scope &);
+  void CheckInitialization(const Symbol &);
 
 private:
   template <typename A> void CheckSpecExpr(const A &x) {
@@ -95,6 +97,9 @@ private:
     }
   }
   bool IsResultOkToDiffer(const FunctionResult &);
+  bool IsScopePDT() const {
+    return scope_ && scope_->IsParameterizedDerivedType();
+  }
 
   SemanticsContext &context_;
   evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
@@ -450,15 +455,20 @@ void CheckHelper::CheckObjectEntity(
       }
     }
   }
+  bool badInit{false};
   if (symbol.owner().kind() != Scope::Kind::DerivedType &&
       IsInitialized(symbol, true /*ignore DATA, already caught*/)) { // C808
     if (IsAutomatic(symbol)) {
+      badInit = true;
       messages_.Say("An automatic variable must not be initialized"_err_en_US);
     } else if (IsDummy(symbol)) {
+      badInit = true;
       messages_.Say("A dummy argument must not be initialized"_err_en_US);
     } else if (IsFunctionResult(symbol)) {
+      badInit = true;
       messages_.Say("A function result must not be initialized"_err_en_US);
     } else if (IsInBlankCommon(symbol)) {
+      badInit = true;
       messages_.Say(
           "A variable in blank COMMON should not be initialized"_en_US);
     }
@@ -482,6 +492,51 @@ void CheckHelper::CheckObjectEntity(
           symbol.name());
     }
   }
+  if (!badInit && !IsScopePDT()) {
+    CheckInitialization(symbol);
+  }
+}
+
+void CheckHelper::CheckInitialization(const Symbol &symbol) {
+  const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
+  if (!details) {
+    // not an object
+  } else if (const auto &init{details->init()}) { // 8.2 para 4
+    int initRank{init->Rank()};
+    int symbolRank{details->shape().Rank()};
+    if (IsPointer(symbol)) {
+      // Pointer initialization rank/shape errors are caught earlier in
+      // name resolution
+    } else if (details->shape().IsImpliedShape() ||
+        details->shape().IsDeferredShape()) {
+      if (symbolRank != initRank) {
+        messages_.Say(
+            "%s-shape array '%s' has rank %d, but its initializer has rank %d"_err_en_US,
+            details->shape().IsImpliedShape() ? "Implied" : "Deferred",
+            symbol.name(), symbolRank, initRank);
+      }
+    } else if (symbolRank != initRank && initRank != 0) {
+      // Pointer initializer rank errors are caught elsewhere
+      messages_.Say(
+          "'%s' has rank %d, but its initializer has rank %d"_err_en_US,
+          symbol.name(), symbolRank, initRank);
+    } else if (auto symbolShape{evaluate::GetShape(foldingContext_, symbol)}) {
+      if (!evaluate::AsConstantExtents(foldingContext_, *symbolShape)) {
+        // C762
+        messages_.Say(
+            "Shape of '%s' is not implied, deferred, nor constant"_err_en_US,
+            symbol.name());
+      } else if (auto initShape{evaluate::GetShape(foldingContext_, *init)}) {
+        if (initRank == symbolRank) {
+          evaluate::CheckConformance(
+              messages_, *symbolShape, *initShape, "object", "initializer");
+        } else {
+          CHECK(initRank == 0);
+          // TODO: expand scalar now, or in lowering?
+        }
+      }
+    }
+  }
 }
 
 // The six different kinds of array-specs:
@@ -1287,7 +1342,8 @@ void CheckHelper::Check(const Scope &scope) {
   if (const Symbol * symbol{scope.symbol()}) {
     innermostSymbol_ = symbol;
   } else if (scope.IsDerivedType()) {
-    return; // PDT instantiations have null symbol()
+    // PDT instantiations have no symbol.
+    return;
   }
   for (const auto &set : scope.equivalenceSets()) {
     CheckEquivalenceSet(set);
@@ -1576,4 +1632,14 @@ void CheckDeclarations(SemanticsContext &context) {
   CheckHelper{context}.Check();
 }
 
+void CheckInstantiatedDerivedType(
+    SemanticsContext &context, const DerivedTypeSpec &type) {
+  if (const Scope * scope{type.scope()}) {
+    CheckHelper checker{context};
+    for (const auto &pair : *scope) {
+      checker.CheckInitialization(*pair.second);
+    }
+  }
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/check-declarations.h

@@ -12,6 +12,8 @@
 #define FORTRAN_SEMANTICS_CHECK_DECLARATIONS_H_
 namespace Fortran::semantics {
 class SemanticsContext;
+class DerivedTypeSpec;
 void CheckDeclarations(SemanticsContext &);
+void CheckInstantiatedDerivedType(SemanticsContext &, const DerivedTypeSpec &);
 } // namespace Fortran::semantics
 #endif

flang/lib/Semantics/expression.cpp

@@ -1528,7 +1528,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(
                 AttachDeclaration(
                     Say(expr.source,
                         "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
-                        symbol->name()),
+                        GetRank(*valueShape), symbol->name()),
                     *symbol);
               } else if (CheckConformance(messages, *componentShape,
                              *valueShape, "component", "value")) {

flang/lib/Semantics/pointer-assignment.cpp

@@ -225,8 +225,8 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
             rhsType->type().AsFortran(), lhsType_->type().AsFortran()};
 
       } else if (!isBoundsRemapping_) {
-        std::size_t lhsRank{lhsType_->shape().size()};
-        std::size_t rhsRank{rhsType->shape().size()};
+        int lhsRank{evaluate::GetRank(lhsType_->shape())};
+        int rhsRank{evaluate::GetRank(rhsType->shape())};
         if (lhsRank != rhsRank) {
           msg = MessageFormattedText{
               "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank,

flang/lib/Semantics/resolve-names.cpp

@@ -5733,9 +5733,9 @@ void DeclarationVisitor::NonPointerInitialization(const parser::Name &name,
       } else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
         CHECK(!details->init());
         Walk(expr);
-        // TODO: check C762 - all bounds and type parameters of component
-        // are colons or constant expressions if component is initialized
         if (inComponentDecl) {
+          // TODO: check C762 - all bounds and type parameters of component
+          // are colons or constant expressions if component is initialized
           // Can't convert to type of component, which might not yet
           // be known; that's done later during instantiation.
           if (MaybeExpr value{EvaluateExpr(expr)}) {

flang/lib/Semantics/type.cpp

@@ -7,6 +7,7 @@
 //===----------------------------------------------------------------------===//
 
 #include "flang/Semantics/type.h"
+#include "check-declarations.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Parser/characters.h"
 #include "flang/Semantics/scope.h"
@@ -284,6 +285,7 @@ void DerivedTypeSpec::Instantiate(
   auto restorer{foldingContext.WithPDTInstance(*this)};
   newScope.AddSourceRange(typeScope.sourceRange());
   InstantiateHelper{context, newScope}.InstantiateComponents(typeScope);
+  CheckInstantiatedDerivedType(context, *this);
 }
 
 void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {

flang/test/Evaluate/folding08.f90

@@ -18,9 +18,9 @@ module m
     logical, parameter :: test_lba1 = all(lba1 == [0])
     integer, parameter :: lba2(*) = lbound(a2)
     logical, parameter :: test_lba2 = all(lba2 == [0])
-    integer, parameter :: lbtadim(*) = lbound(ta,1)
+    integer, parameter :: lbtadim = lbound(ta,1)
     logical, parameter :: test_lbtadim = lbtadim == 0
-    integer, parameter :: ubtadim(*) = ubound(ta,1)
+    integer, parameter :: ubtadim = ubound(ta,1)
     logical, parameter :: test_ubtadim = ubtadim == 2
     integer, parameter :: lbta1(*) = lbound(ta)
     logical, parameter :: test_lbta1 = all(lbta1 == [0])

flang/test/Semantics/init01.f90

@@ -1,7 +1,7 @@
 ! RUN: %S/test_errors.sh %s %t %f18
-! Object pointer initializer error tests
+! Initializer error tests
 
-subroutine test(j)
+subroutine objectpointers(j)
   integer, intent(in) :: j
   real, allocatable, target, save :: x1
   real, codimension[*], target, save :: x2
@@ -23,4 +23,58 @@ subroutine test(j)
 
 !TODO: type incompatibility, non-deferred type parameter values, contiguity
 
-end subroutine test
+end subroutine
+
+subroutine dataobjects(j)
+  integer, intent(in) :: j
+  real, parameter :: x1(*) = [1., 2.]
+!ERROR: Implied-shape array 'x2' has rank 2, but its initializer has rank 1
+  real, parameter :: x2(*,*) = [1., 2.]
+!ERROR: Shape of 'x3' is not implied, deferred, nor constant
+  real, parameter :: x3(j) = [1., 2.]
+!ERROR: An automatic variable must not be initialized
+  real :: x4(j) = [1., 2.]
+!ERROR: 'x5' has rank 2, but its initializer has rank 1
+  real :: x5(2,2) = [1., 2., 3., 4.]
+  real :: x6(2,2) = 5.
+!ERROR: 'x7' has rank 0, but its initializer has rank 1
+  real :: x7 = [1.]
+  real :: x8(2,2) = reshape([1., 2., 3., 4.], [2, 2])
+!ERROR: Dimension 1 of object has extent 3, but initializer has extent 2
+  real :: x9(3) = [1., 2.]
+!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+  real :: x10(2,3) = reshape([real::(k,k=1,6)], [3, 2])
+end subroutine
+
+subroutine components
+  real, target, save :: a1(3)
+  real, target :: a2
+  real, save :: a3
+  real, target, save :: a4
+  type :: t1
+!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+    real :: x1(2) = [1., 2., 3.]
+  end type
+  type :: t2(kind, len)
+    integer, kind :: kind
+    integer, len :: len
+    real :: x1(2) = [1., 2., 3.]
+    real :: x2(kind) = [1., 2., 3.]
+    real :: x3(len) = [1., 2., 3.]
+    real, pointer :: p1(:) => a1
+!ERROR: An initial data target may not be a reference to an object 'a2' that lacks the SAVE attribute
+    real, pointer :: p2 => a2
+!ERROR: An initial data target may not be a reference to an object 'a3' that lacks the TARGET attribute
+    real, pointer :: p3 => a3
+!ERROR: Pointer has rank 0 but target has rank 1
+    real, pointer :: p4 => a1
+!ERROR: Pointer has rank 1 but target has rank 0
+    real, pointer :: p5(:) => a4
+  end type
+!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+  type(t2(3,3)) :: o1
+!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+  type(t2(2,2)) :: o2
+end subroutine

flang/test/Semantics/select-rank.f90

@@ -157,7 +157,7 @@ contains
    subroutine CALL_ME10(x)
     implicit none
     integer:: x(..), a=10,b=20,j
-    integer, dimension(10) :: arr = (/1,2,3,4,5/),brr
+    integer, dimension(5) :: arr = (/1,2,3,4,5/),brr
     integer :: const_variable=10
     integer, pointer :: ptr,nullptr=>NULL()
     type derived

flang/test/Semantics/structconst02.f90

@@ -35,7 +35,7 @@ module module1
     call scalararg(scalar(4)(ix='a'))
     !ERROR: Value in structure constructor of type LOGICAL(4) is incompatible with component 'ix' of type INTEGER(4)
     call scalararg(scalar(4)(ix=.false.))
-    !ERROR: Value in structure constructor of type INTEGER(4) is incompatible with component 'ix' of type INTEGER(4)
+    !ERROR: Rank-1 array value is not compatible with scalar component 'ix'
     call scalararg(scalar(4)(ix=[1]))
     !TODO more!
   end subroutine errors