[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
GitOrigin-RevId: 8c7bf2f93da9b64b07509f67552d592a86260ff5
diff --git a/lib/Evaluate/fold-integer.cpp b/lib/Evaluate/fold-integer.cpp
index eea7b6e..8b39ee0 100644
--- a/lib/Evaluate/fold-integer.cpp
+++ b/lib/Evaluate/fold-integer.cpp
@@ -658,24 +658,43 @@
// 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/lib/Evaluate/formatting.cpp b/lib/Evaluate/formatting.cpp
index df3671a..f7cfaa3 100644
--- a/lib/Evaluate/formatting.cpp
+++ b/lib/Evaluate/formatting.cpp
@@ -614,7 +614,7 @@
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/lib/Semantics/type.cpp b/lib/Semantics/type.cpp
index 741b253..c548b5c 100644
--- a/lib/Semantics/type.cpp
+++ b/lib/Semantics/type.cpp
@@ -205,7 +205,8 @@
}
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 @@
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 @@
// 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 @@
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/test/Semantics/assign04.f90 b/test/Semantics/assign04.f90
index a88c3a5..7cb30c4 100644
--- a/test/Semantics/assign04.f90
+++ b/test/Semantics/assign04.f90
@@ -8,7 +8,7 @@
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/test/Semantics/resolve104.f90 b/test/Semantics/resolve104.f90
new file mode 100644
index 0000000..176c9d6
--- /dev/null
+++ b/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/test/Semantics/resolve89.f90 b/test/Semantics/resolve89.f90
index f3bf218..eaa902b 100644
--- a/test/Semantics/resolve89.f90
+++ b/test/Semantics/resolve89.f90
@@ -107,7 +107,7 @@
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
