[flang-commits] [flang] 8c7bf2f - [flang] Improve constant folding for type parameter inquiries
Peter Steinfeld via flang-commits
flang-commits at lists.llvm.org
Mon Apr 5 16:07:05 PDT 2021
Author: Peter Steinfeld
Date: 2021-04-05T16:04:15-07:00
New Revision: 8c7bf2f93da9b64b07509f67552d592a86260ff5
URL: https://github.com/llvm/llvm-project/commit/8c7bf2f93da9b64b07509f67552d592a86260ff5
DIFF: https://github.com/llvm/llvm-project/commit/8c7bf2f93da9b64b07509f67552d592a86260ff5.diff
LOG: [flang] Improve constant folding for type parameter inquiries
We were not folding type parameter inquiries for the form 'var%typeParam'
where 'typeParam' was a KIND or LEN type parameter of a derived type and 'var'
was a designator of the derived type. I fixed this by adding code to the
function 'FoldOperation()' for 'TypeParamInquiry's to handle this case. I also
cleaned up the code for the case where there is no designator.
In order to make the error messages correctly refer to both the points of
declaration and instantiation, I needed to add an argument to the function
'InstantiateIntrinsicType()' for the location of the instantiation.
I also changed the formatting of 'TypeParamInquiry' to correctly format this
case. I also added tests for both KIND and LEN type parameter inquiries in
resolve104.f90.
Making these changes revealed an error in resolve89.f90 and caused one of the
error messages in assign04.f90 to be different.
Differential Revision: https://reviews.llvm.org/D99892
Added:
flang/test/Semantics/resolve104.f90
Modified:
flang/lib/Evaluate/fold-integer.cpp
flang/lib/Evaluate/formatting.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/assign04.f90
flang/test/Semantics/resolve89.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp
index eea7b6ee7a952..8b39ee028b3c9 100644
--- a/flang/lib/Evaluate/fold-integer.cpp
+++ b/flang/lib/Evaluate/fold-integer.cpp
@@ -658,24 +658,43 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
// Substitute a bare type parameter reference with its value if it has one now
Expr<TypeParamInquiry::Result> FoldOperation(
FoldingContext &context, TypeParamInquiry &&inquiry) {
- if (!inquiry.base()) {
+ std::optional<NamedEntity> base{inquiry.base()};
+ parser::CharBlock parameterName{inquiry.parameter().name()};
+ if (base) {
+ // Handling "designator%typeParam". Get the value of the type parameter
+ // from the instantiation of the base
+ if (const semantics::DeclTypeSpec *
+ declType{base->GetLastSymbol().GetType()}) {
+ const semantics::DerivedTypeSpec dType{declType->derivedTypeSpec()};
+ if (const semantics::ParamValue *
+ paramValue{dType.FindParameter(parameterName)}) {
+ const semantics::MaybeIntExpr ¶mExpr{paramValue->GetExplicit()};
+ if (paramExpr && IsConstantExpr(*paramExpr)) {
+ Expr<SomeInteger> intExpr{*paramExpr};
+ return Fold(context,
+ ConvertToType<TypeParamInquiry::Result>(std::move(intExpr)));
+ }
+ }
+ }
+ } else {
// A "bare" type parameter: replace with its value, if that's now known.
if (const auto *pdt{context.pdtInstance()}) {
if (const semantics::Scope * scope{context.pdtInstance()->scope()}) {
- auto iter{scope->find(inquiry.parameter().name())};
+ auto iter{scope->find(parameterName)};
if (iter != scope->end()) {
const Symbol &symbol{*iter->second};
const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
- if (details && details->init() &&
- (details->attr() == common::TypeParamAttr::Kind ||
- IsConstantExpr(*details->init()))) {
- Expr<SomeInteger> expr{*details->init()};
- return Fold(context,
- ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
+ if (details) {
+ const semantics::MaybeIntExpr &initExpr{details->init()};
+ if (initExpr && IsConstantExpr(*initExpr)) {
+ Expr<SomeInteger> expr{*initExpr};
+ return Fold(context,
+ ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
+ }
}
}
}
- if (const auto *value{pdt->FindParameter(inquiry.parameter().name())}) {
+ if (const auto *value{pdt->FindParameter(parameterName)}) {
if (value->isExplicit()) {
return Fold(context,
AsExpr(ConvertToType<TypeParamInquiry::Result>(
diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp
index df3671a919b59..f7cfaa3e6dff3 100644
--- a/flang/lib/Evaluate/formatting.cpp
+++ b/flang/lib/Evaluate/formatting.cpp
@@ -614,7 +614,7 @@ llvm::raw_ostream &BaseObject::AsFortran(llvm::raw_ostream &o) const {
llvm::raw_ostream &TypeParamInquiry::AsFortran(llvm::raw_ostream &o) const {
if (base_) {
- return base_->AsFortran(o) << '%';
+ base_.value().AsFortran(o) << '%';
}
return EmitVar(o, parameter_);
}
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 741b253322977..c548b5cbd1998 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -205,7 +205,8 @@ class InstantiateHelper {
}
void InstantiateComponent(const Symbol &);
const DeclTypeSpec *InstantiateType(const Symbol &);
- const DeclTypeSpec &InstantiateIntrinsicType(const DeclTypeSpec &);
+ const DeclTypeSpec &InstantiateIntrinsicType(
+ SourceName, const DeclTypeSpec &);
DerivedTypeSpec CreateDerivedTypeSpec(const DerivedTypeSpec &, bool);
SemanticsContext &context_;
@@ -364,7 +365,7 @@ const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) {
CreateDerivedTypeSpec(*spec, symbol.test(Symbol::Flag::ParentComp)),
context_, type->category());
} else if (type->AsIntrinsic()) {
- return &InstantiateIntrinsicType(*type);
+ return &InstantiateIntrinsicType(symbol.name(), *type);
} else if (type->category() == DeclTypeSpec::ClassStar) {
return type;
} else {
@@ -374,7 +375,7 @@ const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) {
// Apply type parameter values to an intrinsic type spec.
const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
- const DeclTypeSpec &spec) {
+ SourceName symbolName, const DeclTypeSpec &spec) {
const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())};
if (evaluate::ToInt64(intrinsic.kind())) {
return spec; // KIND is already a known constant
@@ -387,7 +388,7 @@ const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
if (evaluate::IsValidKindOfIntrinsicType(intrinsic.category(), *value)) {
kind = *value;
} else {
- foldingContext().messages().Say(
+ foldingContext().messages().Say(symbolName,
"KIND parameter value (%jd) of intrinsic type %s "
"did not resolve to a supported value"_err_en_US,
*value,
diff --git a/flang/test/Semantics/assign04.f90 b/flang/test/Semantics/assign04.f90
index a88c3a5b69f47..7cb30c49d7cd5 100644
--- a/flang/test/Semantics/assign04.f90
+++ b/flang/test/Semantics/assign04.f90
@@ -8,7 +8,7 @@ subroutine s1
type(t(1, 2)) :: x
!ERROR: Assignment to constant 'x%k' is not allowed
x%k = 4
- !ERROR: Left-hand side of assignment is not modifiable
+ !ERROR: Assignment to constant 'x%l' is not allowed
x%l = 3
end
diff --git a/flang/test/Semantics/resolve104.f90 b/flang/test/Semantics/resolve104.f90
new file mode 100644
index 0000000000000..176c9d68d9e93
--- /dev/null
+++ b/flang/test/Semantics/resolve104.f90
@@ -0,0 +1,64 @@
+! RUN: %S/test_errors.sh %s %t %f18
+! Test constant folding of type parameter values both a base value and a
+! parameter name are supplied.
+!
+! Type parameters are described in 7.5.3 and constant expressions are described
+! in 10.1.12. 10.1.12, paragraph 4 defines whether a specification inquiry is
+! a constant expression. Section 10.1.11, paragraph 3, item (2) states that a
+! type parameter inquiry is a specification inquiry.
+
+module m1
+ type dtype(goodDefaultKind, badDefaultKind)
+ integer, kind :: goodDefaultKind = 4
+ integer, kind :: badDefaultKind = 343
+ ! next field OK only if instantiated with a good value of goodDefaultKind
+ !ERROR: KIND parameter value (99) of intrinsic type REAL did not resolve to a supported value
+ real(goodDefaultKind) :: goodDefaultField
+ ! next field OK only if instantiated with a good value of goodDefaultKind
+ !ERROR: KIND parameter value (343) of intrinsic type REAL did not resolve to a supported value
+ !ERROR: KIND parameter value (99) of intrinsic type REAL did not resolve to a supported value
+ real(badDefaultKind) :: badDefaultField
+ end type dtype
+ type(dtype) :: v1
+ type(dtype(4, 4)) :: v2
+ type(dtype(99, 4)) :: v3
+ type(dtype(4, 99)) :: v4
+end module m1
+
+module m2
+ type baseType(baseParam)
+ integer, kind :: baseParam = 4
+ end type baseType
+ type dtype(dtypeParam)
+ integer, kind :: dtypeParam = 4
+ type(baseType(dtypeParam)) :: baseField
+ !ERROR: KIND parameter value (343) of intrinsic type REAL did not resolve to a supported value
+ real(baseField%baseParam) :: realField
+ end type dtype
+
+ type(dtype) :: v1
+ type(dtype(8)) :: v2
+ type(dtype(343)) :: v3
+end module m2
+
+module m3
+ type dtype(goodDefaultLen, badDefaultLen)
+ integer, len :: goodDefaultLen = 4
+ integer, len :: badDefaultLen = 343
+ end type dtype
+ type(dtype) :: v1
+ type(dtype(4, 4)) :: v2
+ type(dtype(99, 4)) :: v3
+ type(dtype(4, 99)) :: v4
+ real(v1%goodDefaultLen), pointer :: pGood1
+ !ERROR: REAL(KIND=343) is not a supported type
+ real(v1%badDefaultLen), pointer :: pBad1
+ real(v2%goodDefaultLen), pointer :: pGood2
+ real(v2%badDefaultLen), pointer :: pBad2
+ !ERROR: REAL(KIND=99) is not a supported type
+ real(v3%goodDefaultLen), pointer :: pGood3
+ real(v3%badDefaultLen), pointer :: pBad3
+ real(v4%goodDefaultLen), pointer :: pGood4
+ !ERROR: REAL(KIND=99) is not a supported type
+ real(v4%badDefaultLen), pointer :: pBad4
+end module m3
diff --git a/flang/test/Semantics/resolve89.f90 b/flang/test/Semantics/resolve89.f90
index f3bf218fdce7b..eaa902bf54ebc 100644
--- a/flang/test/Semantics/resolve89.f90
+++ b/flang/test/Semantics/resolve89.f90
@@ -107,7 +107,7 @@ subroutine inner (derivedArg)
type localDerivedType
! OK because the specification inquiry is a constant
integer, dimension(localDerived%kindParam) :: goodField
- !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components or type parameter values
+ ! OK because the value of lenParam is constant in this context
integer, dimension(derivedArg%lenParam) :: badField
end type localDerivedType
More information about the flang-commits
mailing list