[flang] Check shape conformance on initializers

[klausler]

Summary

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

[PeteSteinfeld]

All builds, tests, and looks good.

flang/lib/Evaluate/check-expression.cpp

Result operator()(const DescriptorInquiry &) const {
     // Subtle: Uses of SIZE(), LBOUND(), &c. that are valid in specification
     // expressions will have been converted to expressions over descriptor
     // inquiries by Fold().
     return std::nullopt;
   }
 
   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";
     }
     return std::nullopt;
   }
 
   template <typename T> Result operator()(const FunctionRef<T> &x) const {
     if (const auto *symbol{x.proc().GetSymbol()}) {

flang/lib/Evaluate/shape.cpp

if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
       // TODO: shapes of other non-elemental intrinsic results
     }
   }
   return std::nullopt;
 }
 
 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)};
+  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);
       return false;
     } else {
       for (int j{0}; j < n; ++j) {
         if (auto leftDim{ToInt64(left[j])}) {
           if (auto rightDim{ToInt64(right[j])}) {

flang/lib/Evaluate/tools.cpp

if (x) {
     return ConvertToType(to, std::move(*x));
   } else {
     return std::nullopt;
   }
 }
 
 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));
   }
   return std::nullopt;
 }
 
 std::optional<Expr<SomeType>> ConvertToType(
     const Symbol &to, std::optional<Expr<SomeType>> &&x) {

flang/lib/Semantics/check-declarations.h

 //===-- lib/Semantics/check-declarations.h ----------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 // Static declaration checks
 
 #ifndef FORTRAN_SEMANTICS_CHECK_DECLARATIONS_H_
 #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/check-declarations.cpp

 using evaluate::characteristics::DummyDataObject;
 using evaluate::characteristics::DummyProcedure;
 using evaluate::characteristics::FunctionResult;
 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);
   void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); }
   void Check(const ShapeSpec &spec) {
     Check(spec.lbound());
     Check(spec.ubound());
   }
   void Check(const ArraySpec &);
   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) {
     evaluate::CheckSpecificationExpr(
         x, messages_, DEREF(scope_), context_.intrinsics());
   }
   void CheckValue(const Symbol &, const DerivedTypeSpec *);
   void CheckVolatile(
private:
   void SayWithDeclaration(const Symbol &symbol, A &&...x) {
     if (parser::Message * msg{messages_.Say(std::forward<A>(x)...)}) {
       if (messages_.at().begin() != symbol.name().begin()) {
         evaluate::AttachDeclaration(*msg, symbol);
       }
     }
   }
   bool IsResultOkToDiffer(const FunctionResult &);
+  bool IsScopePDT() const {
+    return scope_ && scope_->IsParameterizedDerivedType();
+  }
 
   SemanticsContext &context_;
   evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
   parser::ContextualMessages &messages_{foldingContext_.messages()};
   const Scope *scope_{nullptr};
   // This symbol is the one attached to the innermost enclosing scope
   // that has a symbol.
   const Symbol *innermostSymbol_{nullptr};
if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
           }
         }
       } else if (!IsIntentInOut(symbol)) { // C1586
         messages_.Say(
             "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
       }
     }
   }
+  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);
     }
   }
   if (symbol.owner().kind() == Scope::Kind::BlockData &&
       IsInitialized(symbol)) {
     if (IsAllocatable(symbol)) {
       messages_.Say(
           "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
     } else if (!FindCommonBlockContaining(symbol)) {
       messages_.Say(
           "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
     }
   }
   if (const DeclTypeSpec * type{details.type()}) { // C708
     if (type->IsPolymorphic() &&
         !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) ||
             IsDummy(symbol))) {
       messages_.Say("CLASS entity '%s' must be a dummy argument or have "
                     "ALLOCATABLE or POINTER attribute"_err_en_US,
           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:
 //   array-spec     -> explicit-shape-list | deferred-shape-list
 //                     | assumed-shape-list | implied-shape-list
 //                     | assumed-size | assumed-rank
 //   explicit-shape -> [ lb : ] ub
 //   deferred-shape -> :

 }
 
 void CheckHelper::Check(const Scope &scope) {
   scope_ = &scope;
   common::Restorer<const Symbol *> restorer{innermostSymbol_};
   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);
   }
   for (const auto &pair : scope) {
     Check(*pair.second);
   }
   for (const Scope &child : scope.children()) {
evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) {
   }
   return result;
 }
 
 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/expression.cpp

if (symbol) {
         } else if (MaybeExpr converted{
                        ConvertToType(*symbol, std::move(*value))}) {
           if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
             if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
               if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
                 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")) {
                 if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0 &&
                     !IsExpandableScalar(*converted)) {
                   AttachDeclaration(
                       Say(expr.source,
                           "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,

flang/lib/Semantics/pointer-assignment.cpp

if (!lhsType_) {
       }
     } else {
       if (!lhsType_->type().IsTypeCompatibleWith(rhsType->type())) {
         msg = MessageFormattedText{
             "Target type %s is not compatible with pointer type %s"_err_en_US,
             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,
               rhsRank};
         }
       }
     }
   }

flang/lib/Semantics/resolve-names.cpp

if (name.symbol) {
     Symbol &ultimate{name.symbol->GetUltimate()};
     if (!context().HasError(ultimate)) {
       if (IsPointer(ultimate)) {
         Say(name,
             "'%s' is a pointer but is not initialized like one"_err_en_US);
       } else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
         CHECK(!details->init());
         Walk(expr);
+        if (inComponentDecl) {
           // TODO: check C762 - all bounds and type parameters of component
           // are colons or constant expressions if component is initialized
-        if (inComponentDecl) {
           // Can't convert to type of component, which might not yet
           // be known; that's done later during instantiation.
           if (MaybeExpr value{EvaluateExpr(expr)}) {
             details->set_init(std::move(*value));
           }
         } else if (MaybeExpr folded{EvaluateConvertedExpr(
                        ultimate, expr, expr.thing.value().source)}) {
           details->set_init(std::move(*folded));

flang/lib/Semantics/type.cpp

 //===-- lib/Semantics/type.cpp --------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Semantics/type.h"
+#include "check-declarations.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Parser/characters.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/raw_ostream.h"
 
 namespace Fortran::semantics {
if (typeScope.find(symbol.name()) != typeScope.end()) {
       }
     }
   }
   // Instantiate every non-parameter symbol from the original derived
   // type's scope into the new instance.
   auto restorer{foldingContext.WithPDTInstance(*this)};
   newScope.AddSourceRange(typeScope.sourceRange());
   InstantiateHelper{context, newScope}.InstantiateComponents(typeScope);
+  CheckInstantiatedDerivedType(context, *this);
 }
 
 void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {
   for (const auto &pair : fromScope) {
     InstantiateComponent(*pair.second);
   }
 }
 

flang/test/Evaluate/folding08.f90

type :: t
       real :: a
     end type
     type(t) :: ta(0:2)
     character(len=2) :: ca(-1:1)
     integer, parameter :: lba1(*) = lbound(a1)
     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])
     integer, parameter :: ubta1(*) = ubound(ta)
     logical, parameter :: test_ubta1 = all(ubta1 == [2])
     integer, parameter :: lbta2(*) = lbound(ta(:))
     logical, parameter :: test_lbta2 = all(lbta2 == [1])
     integer, parameter :: ubta2(*) = ubound(ta(:))

flang/test/Semantics/init01.f90

 ! 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
   real, save :: x3
   real, target :: x4
   real, target, save :: x5(10)
 !ERROR: An initial data target may not be a reference to an ALLOCATABLE 'x1'
   real, pointer :: p1 => x1
 !ERROR: An initial data target may not be a reference to a coarray 'x2'
   real, pointer :: p2 => x2
 !ERROR: An initial data target may not be a reference to an object 'x3' that lacks the TARGET attribute
   real, pointer :: p3 => x3
 !ERROR: An initial data target may not be a reference to an object 'x4' that lacks the SAVE attribute
   real, pointer :: p4 => x4
 !ERROR: An initial data target must be a designator with constant subscripts
   real, pointer :: p5 => x5(j)
 !ERROR: Pointer has rank 0 but target has rank 1
   real, pointer :: p6 => x5
 
 !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

RANK (*)
       print *, "This is Wrong"
       j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1))
     END SELECT
    end subroutine
 
    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
          character(len = 50) :: title
     end type derived
     type(derived) :: obj1
 
     SELECT RANK(x)

flang/test/Semantics/structconst02.f90

 !    call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true._4))
 !    call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true._4))
     call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true.))
     call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true.))
     !ERROR: Value in structure constructor of type CHARACTER(1) is incompatible with component 'ix' of type INTEGER(4)
     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
 end module module1