[flang-commits] [flang] f862d85 - [flang] Check shape conformance on initializers
peter klausler via flang-commits
flang-commits at lists.llvm.org
Mon Aug 31 16:27:19 PDT 2020
Author: peter klausler
Date: 2020-08-31T16:27:06-07:00
New Revision: f862d858076ff861048c8f259fac575c0a4e1a6a
URL: https://github.com/llvm/llvm-project/commit/f862d858076ff861048c8f259fac575c0a4e1a6a
DIFF: https://github.com/llvm/llvm-project/commit/f862d858076ff861048c8f259fac575c0a4e1a6a.diff
LOG: [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
Added:
Modified:
flang/lib/Evaluate/check-expression.cpp
flang/lib/Evaluate/shape.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/check-declarations.h
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/type.cpp
flang/test/Evaluate/folding08.f90
flang/test/Semantics/init01.f90
flang/test/Semantics/select-rank.f90
flang/test/Semantics/structconst02.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 09c14179d256..f4348c5108b5 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -310,7 +310,7 @@ class CheckSpecificationExprHelper
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
index a072f5ef3f96..eb5ec8367670 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/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);
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index e9089f56aa46..128a73ad4c78 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/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));
}
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index d5fa7b9ab370..df7ae6e53b1f 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/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 @@ class CheckHelper {
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 @@ class CheckHelper {
}
}
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
diff erent 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
diff --git a/flang/lib/Semantics/check-declarations.h b/flang/lib/Semantics/check-declarations.h
index 3b50bac4f5e7..f1e4caf794c7 100644
--- 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/expression.cpp b/flang/lib/Semantics/expression.cpp
index ec4dae2d3279..f41aea70de3a 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/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")) {
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index d97eedf37c12..58719deae366 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/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,
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 3efe5899defb..a75c5b6a829e 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/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)}) {
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 6227a447e2b5..5274db649152 100644
--- 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 @@ 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) {
diff --git a/flang/test/Evaluate/folding08.f90 b/flang/test/Evaluate/folding08.f90
index 2a4d58ec4f2d..f7c8c12f2316 100644
--- a/flang/test/Evaluate/folding08.f90
+++ b/flang/test/Evaluate/folding08.f90
@@ -18,9 +18,9 @@ subroutine test(n1,a1,a2)
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
index f14c63cb00df..56df41db6e0d 100644
--- 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 @@ 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
diff --git a/flang/test/Semantics/select-rank.f90 b/flang/test/Semantics/select-rank.f90
index 2478f804bc11..2e5aab3a6b08 100644
--- a/flang/test/Semantics/select-rank.f90
+++ b/flang/test/Semantics/select-rank.f90
@@ -157,7 +157,7 @@ subroutine CALL_ME8(x)
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
index f8a303dc79c2..f65508fbe16d 100644
--- a/flang/test/Semantics/structconst02.f90
+++ b/flang/test/Semantics/structconst02.f90
@@ -35,7 +35,7 @@ subroutine errors
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
More information about the flang-commits
mailing list