diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -310,7 +310,7 @@ 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"; } diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -684,9 +684,9 @@ 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); diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -661,11 +661,6 @@ std::optional> ConvertToType( const Symbol &symbol, Expr &&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)); } diff --git a/flang/lib/Semantics/check-declarations.h b/flang/lib/Semantics/check-declarations.h --- a/flang/lib/Semantics/check-declarations.h +++ b/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 diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -30,6 +30,7 @@ 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 @@ void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters); void Check(const Symbol &); void Check(const Scope &); + void CheckInitialization(const Symbol &); private: template void CheckSpecExpr(const A &x) { @@ -95,6 +97,9 @@ } } bool IsResultOkToDiffer(const FunctionResult &); + bool IsScopePDT() const { + return scope_ && scope_->IsParameterizedDerivedType(); + } SemanticsContext &context_; evaluate::FoldingContext &foldingContext_{context_.foldingContext()}; @@ -450,15 +455,20 @@ } } } + 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 @@ symbol.name()); } } + if (!badInit && !IsScopePDT()) { + CheckInitialization(symbol); + } +} + +void CheckHelper::CheckInitialization(const Symbol &symbol) { + const auto *details{symbol.detailsIf()}; + 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 @@ 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 @@ 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 diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -1528,7 +1528,7 @@ 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")) { diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -225,8 +225,8 @@ 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, diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -5733,9 +5733,9 @@ } else if (auto *details{ultimate.detailsIf()}) { 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)}) { diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp --- a/flang/lib/Semantics/type.cpp +++ b/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 @@ auto restorer{foldingContext.WithPDTInstance(*this)}; newScope.AddSourceRange(typeScope.sourceRange()); InstantiateHelper{context, newScope}.InstantiateComponents(typeScope); + CheckInstantiatedDerivedType(context, *this); } void InstantiateHelper::InstantiateComponents(const Scope &fromScope) { diff --git a/flang/test/Evaluate/folding08.f90 b/flang/test/Evaluate/folding08.f90 --- a/flang/test/Evaluate/folding08.f90 +++ b/flang/test/Evaluate/folding08.f90 @@ -18,9 +18,9 @@ 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]) diff --git a/flang/test/Semantics/init01.f90 b/flang/test/Semantics/init01.f90 --- a/flang/test/Semantics/init01.f90 +++ b/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 @@ !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 diff --git a/flang/test/Semantics/select-rank.f90 b/flang/test/Semantics/select-rank.f90 --- a/flang/test/Semantics/select-rank.f90 +++ b/flang/test/Semantics/select-rank.f90 @@ -157,7 +157,7 @@ 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 diff --git a/flang/test/Semantics/structconst02.f90 b/flang/test/Semantics/structconst02.f90 --- a/flang/test/Semantics/structconst02.f90 +++ b/flang/test/Semantics/structconst02.f90 @@ -35,7 +35,7 @@ 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