aboutsummaryrefslogtreecommitdiff
path: root/flang/lib/Semantics
diff options
context:
space:
mode:
Diffstat (limited to 'flang/lib/Semantics')
-rw-r--r--flang/lib/Semantics/check-call.cpp17
-rw-r--r--flang/lib/Semantics/check-data.cpp12
-rw-r--r--flang/lib/Semantics/check-data.h3
-rw-r--r--flang/lib/Semantics/check-declarations.cpp5
-rw-r--r--flang/lib/Semantics/check-omp-structure.cpp2
-rw-r--r--flang/lib/Semantics/expression.cpp36
-rw-r--r--flang/lib/Semantics/resolve-names.cpp150
-rw-r--r--flang/lib/Semantics/symbol.cpp5
-rw-r--r--flang/lib/Semantics/type.cpp42
9 files changed, 199 insertions, 73 deletions
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 81c53aa..e4d2a0d 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -185,7 +185,8 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
} else if (static_cast<std::size_t>(actualOffset->offset()) >=
actualOffset->symbol().size() ||
!evaluate::IsContiguous(
- actualOffset->symbol(), foldingContext)) {
+ actualOffset->symbol(), foldingContext)
+ .value_or(false)) {
// If substring, take rest of substring
if (*actualLength > 0) {
actualChars -=
@@ -598,7 +599,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
context.IsEnabled(
common::LanguageFeature::ContiguousOkForSeqAssociation) &&
actualLastSymbol &&
- evaluate::IsContiguous(*actualLastSymbol, foldingContext)};
+ evaluate::IsContiguous(*actualLastSymbol, foldingContext)
+ .value_or(false)};
if (actualIsArrayElement && actualLastSymbol &&
!dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
if (IsPointer(*actualLastSymbol)) {
@@ -663,7 +665,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
} else if (static_cast<std::size_t>(actualOffset->offset()) >=
actualOffset->symbol().size() ||
!evaluate::IsContiguous(
- actualOffset->symbol(), foldingContext)) {
+ actualOffset->symbol(), foldingContext)
+ .value_or(false)) {
actualElements = 1;
} else if (auto actualSymType{evaluate::DynamicType::From(
actualOffset->symbol())}) {
@@ -1566,10 +1569,10 @@ static bool CheckElementalConformance(parser::ContextualMessages &messages,
") corresponding to dummy argument #" + std::to_string(index) +
" ('" + dummy.name + "')"};
if (shape) {
- auto tristate{evaluate::CheckConformance(messages, *shape,
- *argShape, evaluate::CheckConformanceFlags::None,
- shapeName.c_str(), argName.c_str())};
- if (tristate && !*tristate) {
+ if (!evaluate::CheckConformance(messages, *shape, *argShape,
+ evaluate::CheckConformanceFlags::None, shapeName.c_str(),
+ argName.c_str())
+ .value_or(true)) {
return false;
}
} else {
diff --git a/flang/lib/Semantics/check-data.cpp b/flang/lib/Semantics/check-data.cpp
index d6f1351..5459290 100644
--- a/flang/lib/Semantics/check-data.cpp
+++ b/flang/lib/Semantics/check-data.cpp
@@ -257,9 +257,7 @@ void DataChecker::Leave(const parser::DataStmtSet &set) {
currentSetHasFatalErrors_ = false;
}
-// Handle legacy DATA-style initialization, e.g. REAL PI/3.14159/, for
-// variables and components (esp. for DEC STRUCTUREs)
-template <typename A> void DataChecker::LegacyDataInit(const A &decl) {
+void DataChecker::Leave(const parser::EntityDecl &decl) {
if (const auto &init{
std::get<std::optional<parser::Initialization>>(decl.t)}) {
const Symbol *name{std::get<parser::Name>(decl.t).symbol};
@@ -272,14 +270,6 @@ template <typename A> void DataChecker::LegacyDataInit(const A &decl) {
}
}
-void DataChecker::Leave(const parser::ComponentDecl &decl) {
- LegacyDataInit(decl);
-}
-
-void DataChecker::Leave(const parser::EntityDecl &decl) {
- LegacyDataInit(decl);
-}
-
void DataChecker::CompileDataInitializationsIntoInitializers() {
ConvertToInitializers(inits_, exprAnalyzer_);
}
diff --git a/flang/lib/Semantics/check-data.h b/flang/lib/Semantics/check-data.h
index 479d325..8cd2ac9 100644
--- a/flang/lib/Semantics/check-data.h
+++ b/flang/lib/Semantics/check-data.h
@@ -37,10 +37,7 @@ public:
void Enter(const parser::DataImpliedDo &);
void Leave(const parser::DataImpliedDo &);
void Leave(const parser::DataStmtSet &);
- // These cases are for legacy DATA-like /initializations/
- void Leave(const parser::ComponentDecl &);
void Leave(const parser::EntityDecl &);
-
// After all DATA statements have been processed, converts their
// initializations into per-symbol static initializers.
void CompileDataInitializationsIntoInitializers();
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 7593424..ea5e2c0 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1984,9 +1984,8 @@ bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,
const Procedure *p1{Characterize(f1)};
const Procedure *p2{Characterize(f2)};
if (p1 && p2) {
- std::optional<bool> areDistinct{characteristics::Distinguishable(
- context_.languageFeatures(), *p1, *p2)};
- if (areDistinct.value_or(false)) {
+ if (characteristics::Distinguishable(context_.languageFeatures(), *p1, *p2)
+ .value_or(false)) {
return true;
}
if (auto *msg{messages_.Say(f1Name,
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index c0c41c1..d65a89e 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -5085,7 +5085,7 @@ void OmpStructureChecker::CheckWorkdistributeBlockStmts(
}
void OmpStructureChecker::CheckIfContiguous(const parser::OmpObject &object) {
- if (auto contig{IsContiguous(context_, object)}; contig && !*contig) {
+ if (!IsContiguous(context_, object).value_or(true)) { // known discontiguous
const parser::Name *name{GetObjectName(object)};
assert(name && "Expecting name component");
context_.Say(name->source,
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index fc26888..2feec98 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2171,17 +2171,29 @@ MaybeExpr ExpressionAnalyzer::CheckStructureConstructor(
// T(1) or T(PT=PT(1)). There may be multiple parent components.
if (nextAnonymous == components.begin() && parentComponent && valueType &&
context().IsEnabled(LanguageFeature::AnonymousParents)) {
- for (auto parent{components.begin()};
- parent != afterLastParentComponentIter; ++parent) {
- if (auto parentType{DynamicType::From(*parent)}; parentType &&
- parent->test(Symbol::Flag::ParentComp) &&
- valueType->IsEquivalentTo(*parentType)) {
- symbol = &*parent;
- nextAnonymous = ++parent;
- Warn(LanguageFeature::AnonymousParents, source,
- "Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
- symbol->name());
- break;
+ auto parent{components.begin()};
+ if (!parent->test(Symbol::Flag::ParentComp)) {
+ // Ensure that the first value can't initialize the first actual
+ // component.
+ if (auto firstComponentType{DynamicType::From(*parent)}) {
+ if (firstComponentType->IsTkCompatibleWith(*valueType) &&
+ value.Rank() == parent->Rank()) {
+ parent = afterLastParentComponentIter; // skip next loop
+ }
+ }
+ }
+ for (; parent != afterLastParentComponentIter; ++parent) {
+ if (auto parentType{DynamicType::From(*parent)}) {
+ if (parent->test(Symbol::Flag::ParentComp) &&
+ valueType->IsEquivalentTo(*parentType) &&
+ value.Rank() == 0 /* scalar only */) {
+ symbol = &*parent;
+ nextAnonymous = ++parent;
+ Warn(LanguageFeature::AnonymousParents, source,
+ "Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
+ symbol->name());
+ break;
+ }
}
}
}
@@ -2317,7 +2329,7 @@ MaybeExpr ExpressionAnalyzer::CheckStructureConstructor(
auto checked{CheckConformance(messages, *componentShape,
*valueShape, CheckConformanceFlags::RightIsExpandableDeferred,
"component", "value")};
- if (checked && *checked && GetRank(*componentShape) > 0 &&
+ if (checked.value_or(false) && GetRank(*componentShape) > 0 &&
GetRank(*valueShape) == 0 &&
(IsDeferredShape(*symbol) ||
!IsExpandableScalar(*converted, foldingContext,
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index b7c7603d..86121880 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -7,6 +7,7 @@
#include "resolve-names.h"
#include "assignment.h"
+#include "data-to-inits.h"
#include "definable.h"
#include "mod-file.h"
#include "pointer-assignment.h"
@@ -357,6 +358,7 @@ protected:
DeclTypeSpec::Category category{DeclTypeSpec::TypeDerived};
} derived;
bool allowForwardReferenceToDerivedType{false};
+ const parser::Expr *originalKindParameter{nullptr};
};
bool allowForwardReferenceToDerivedType() const {
@@ -365,8 +367,10 @@ protected:
void set_allowForwardReferenceToDerivedType(bool yes) {
state_.allowForwardReferenceToDerivedType = yes;
}
+ void set_inPDTDefinition(bool yes) { inPDTDefinition_ = yes; }
- const DeclTypeSpec *GetDeclTypeSpec();
+ const DeclTypeSpec *GetDeclTypeSpec() const;
+ const parser::Expr *GetOriginalKindParameter() const;
void BeginDeclTypeSpec();
void EndDeclTypeSpec();
void SetDeclTypeSpec(const DeclTypeSpec &);
@@ -380,6 +384,7 @@ protected:
private:
State state_;
+ bool inPDTDefinition_{false};
void MakeNumericType(TypeCategory, int kind);
};
@@ -1081,8 +1086,12 @@ public:
const parser::Name &, const parser::InitialDataTarget &);
void PointerInitialization(
const parser::Name &, const parser::ProcPointerInit &);
+ bool CheckNonPointerInitialization(
+ const parser::Name &, bool inLegacyDataInitialization);
void NonPointerInitialization(
const parser::Name &, const parser::ConstantExpr &);
+ void LegacyDataInitialization(const parser::Name &,
+ const std::list<common::Indirection<parser::DataStmtValue>> &values);
void CheckExplicitInterface(const parser::Name &);
void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &);
@@ -2454,9 +2463,12 @@ bool AttrsVisitor::Pre(const common::CUDADataAttr x) {
// DeclTypeSpecVisitor implementation
-const DeclTypeSpec *DeclTypeSpecVisitor::GetDeclTypeSpec() {
+const DeclTypeSpec *DeclTypeSpecVisitor::GetDeclTypeSpec() const {
return state_.declTypeSpec;
}
+const parser::Expr *DeclTypeSpecVisitor::GetOriginalKindParameter() const {
+ return state_.originalKindParameter;
+}
void DeclTypeSpecVisitor::BeginDeclTypeSpec() {
CHECK(!state_.expectDeclTypeSpec);
@@ -2541,6 +2553,21 @@ void DeclTypeSpecVisitor::SetDeclTypeSpec(const DeclTypeSpec &declTypeSpec) {
KindExpr DeclTypeSpecVisitor::GetKindParamExpr(
TypeCategory category, const std::optional<parser::KindSelector> &kind) {
+ if (inPDTDefinition_) {
+ if (category != TypeCategory::Derived && kind) {
+ if (const auto *expr{
+ std::get_if<parser::ScalarIntConstantExpr>(&kind->u)}) {
+ CHECK(!state_.originalKindParameter);
+ // Save a pointer to the KIND= expression in the parse tree
+ // in case we need to reanalyze it during PDT instantiation.
+ state_.originalKindParameter = &expr->thing.thing.thing.value();
+ }
+ }
+ // Inhibit some errors now that will be caught later during instantiations.
+ auto restorer{
+ context().foldingContext().AnalyzingPDTComponentKindSelector()};
+ return AnalyzeKindSelector(context(), category, kind);
+ }
return AnalyzeKindSelector(context(), category, kind);
}
@@ -6410,6 +6437,7 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
details.set_isForwardReferenced(false);
derivedTypeInfo_ = {};
PopScope();
+ set_inPDTDefinition(false);
return false;
}
@@ -6437,6 +6465,10 @@ void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
// component without producing spurious errors about already
// existing.
const Symbol &extendsSymbol{extendsType->typeSymbol()};
+ if (extendsSymbol.scope() &&
+ extendsSymbol.scope()->IsParameterizedDerivedType()) {
+ set_inPDTDefinition(true);
+ }
auto restorer{common::ScopedSet(extendsName->symbol, nullptr)};
if (OkToAddComponent(*extendsName, &extendsSymbol)) {
auto &comp{DeclareEntity<ObjectEntityDetails>(*extendsName, Attrs{})};
@@ -6455,8 +6487,12 @@ void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
}
// Create symbols now for type parameters so that they shadow names
// from the enclosing specification part.
+ const auto &paramNames{std::get<std::list<parser::Name>>(x.t)};
+ if (!paramNames.empty()) {
+ set_inPDTDefinition(true);
+ }
if (auto *details{symbol.detailsIf<DerivedTypeDetails>()}) {
- for (const auto &name : std::get<std::list<parser::Name>>(x.t)) {
+ for (const auto &name : paramNames) {
if (Symbol * symbol{MakeTypeSymbol(name, TypeParamDetails{})}) {
details->add_paramNameOrder(*symbol);
}
@@ -6544,8 +6580,7 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) {
if (const auto *derived{declType->AsDerived()}) {
if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) {
if (derivedTypeInfo_.type == &derived->typeSymbol()) { // C744
- Say("Recursive use of the derived type requires "
- "POINTER or ALLOCATABLE"_err_en_US);
+ Say("Recursive use of the derived type requires POINTER or ALLOCATABLE"_err_en_US);
}
}
}
@@ -6558,7 +6593,11 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) {
Initialization(name, *init, /*inComponentDecl=*/true);
}
}
- currScope().symbol()->get<DerivedTypeDetails>().add_component(symbol);
+ auto &details{currScope().symbol()->get<DerivedTypeDetails>()};
+ details.add_component(symbol);
+ if (const parser::Expr *kindExpr{GetOriginalKindParameter()}) {
+ details.add_originalKindParameter(name.source, kindExpr);
+ }
}
ClearArraySpec();
ClearCoarraySpec();
@@ -8995,6 +9034,14 @@ void DeclarationVisitor::Initialization(const parser::Name &name,
ultimate.set(Symbol::Flag::InDataStmt);
}
},
+ [&](const std::list<Indirection<parser::DataStmtValue>> &values) {
+ Walk(values);
+ if (inComponentDecl) {
+ LegacyDataInitialization(name, values);
+ } else {
+ ultimate.set(Symbol::Flag::InDataStmt);
+ }
+ },
[&](const parser::NullInit &null) { // => NULL()
Walk(null);
if (auto nullInit{EvaluateExpr(null)}) {
@@ -9028,11 +9075,6 @@ void DeclarationVisitor::Initialization(const parser::Name &name,
ultimate.set(Symbol::Flag::InDataStmt);
}
},
- [&](const std::list<Indirection<parser::DataStmtValue>> &values) {
- // Handled later in data-to-inits conversion
- ultimate.set(Symbol::Flag::InDataStmt);
- Walk(values);
- },
},
init.u);
}
@@ -9103,36 +9145,82 @@ void DeclarationVisitor::PointerInitialization(
}
}
-void DeclarationVisitor::NonPointerInitialization(
- const parser::Name &name, const parser::ConstantExpr &expr) {
+bool DeclarationVisitor::CheckNonPointerInitialization(
+ const parser::Name &name, bool inLegacyDataInitialization) {
if (!context().HasError(name.symbol)) {
Symbol &ultimate{name.symbol->GetUltimate()};
if (!context().HasError(ultimate)) {
- if (IsPointer(ultimate)) {
+ if (IsPointer(ultimate) && !inLegacyDataInitialization) {
Say(name,
"'%s' is a pointer but is not initialized like one"_err_en_US);
} else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
if (details->init()) {
SayWithDecl(name, *name.symbol,
"'%s' has already been initialized"_err_en_US);
- } else if (details->isCDefined()) {
- context().Warn(common::UsageWarning::CdefinedInit, name.source,
- "CDEFINED variable should not have an initializer"_warn_en_US);
} else if (IsAllocatable(ultimate)) {
Say(name, "Allocatable object '%s' cannot be initialized"_err_en_US);
- } else if (ultimate.owner().IsParameterizedDerivedType()) {
- // Save the expression for per-instantiation analysis.
- details->set_unanalyzedPDTComponentInit(&expr.thing.value());
- } else if (MaybeExpr folded{EvaluateNonPointerInitializer(
- ultimate, expr, expr.thing.value().source)}) {
- details->set_init(std::move(*folded));
- ultimate.set(Symbol::Flag::InDataStmt, false);
+ } else {
+ if (details->isCDefined()) {
+ context().Warn(common::UsageWarning::CdefinedInit, name.source,
+ "CDEFINED variable should not have an initializer"_warn_en_US);
+ }
+ return true;
}
} else {
Say(name, "'%s' is not an object that can be initialized"_err_en_US);
}
}
}
+ return false;
+}
+
+void DeclarationVisitor::NonPointerInitialization(
+ const parser::Name &name, const parser::ConstantExpr &expr) {
+ if (CheckNonPointerInitialization(
+ name, /*inLegacyDataInitialization=*/false)) {
+ Symbol &ultimate{name.symbol->GetUltimate()};
+ auto &details{ultimate.get<ObjectEntityDetails>()};
+ if (ultimate.owner().IsParameterizedDerivedType()) {
+ // Save the expression for per-instantiation analysis.
+ details.set_unanalyzedPDTComponentInit(&expr.thing.value());
+ } else if (MaybeExpr folded{EvaluateNonPointerInitializer(
+ ultimate, expr, expr.thing.value().source)}) {
+ details.set_init(std::move(*folded));
+ ultimate.set(Symbol::Flag::InDataStmt, false);
+ }
+ }
+}
+
+void DeclarationVisitor::LegacyDataInitialization(const parser::Name &name,
+ const std::list<common::Indirection<parser::DataStmtValue>> &values) {
+ if (CheckNonPointerInitialization(
+ name, /*inLegacyDataInitialization=*/true)) {
+ Symbol &ultimate{name.symbol->GetUltimate()};
+ if (ultimate.owner().IsParameterizedDerivedType()) {
+ Say(name,
+ "Component '%s' in a parameterized data type may not be initialized with a legacy DATA-style value list"_err_en_US,
+ name.source);
+ } else {
+ evaluate::ExpressionAnalyzer exprAnalyzer{context()};
+ for (const auto &value : values) {
+ exprAnalyzer.Analyze(value.value());
+ }
+ DataInitializations inits;
+ auto oldSize{ultimate.size()};
+ if (auto chars{evaluate::characteristics::TypeAndShape::Characterize(
+ ultimate, GetFoldingContext())}) {
+ if (auto size{evaluate::ToInt64(
+ chars->MeasureSizeInBytes(GetFoldingContext()))}) {
+ // Temporarily set the byte size of the component so that we don't
+ // get bogus "initialization out of range" errors below.
+ ultimate.set_size(*size);
+ }
+ }
+ AccumulateDataInitializations(inits, exprAnalyzer, ultimate, values);
+ ConvertToInitializers(inits, exprAnalyzer);
+ ultimate.set_size(oldSize);
+ }
+ }
}
void ResolveNamesVisitor::HandleCall(
@@ -10482,12 +10570,16 @@ private:
if (const auto *target{
std::get_if<parser::InitialDataTarget>(&init->u)}) {
resolver_.PointerInitialization(name, *target);
- } else if (const auto *expr{
- std::get_if<parser::ConstantExpr>(&init->u)}) {
- if (name.symbol) {
- if (const auto *object{name.symbol->detailsIf<ObjectEntityDetails>()};
- !object || !object->init()) {
+ } else if (name.symbol) {
+ if (const auto *object{name.symbol->detailsIf<ObjectEntityDetails>()};
+ !object || !object->init()) {
+ if (const auto *expr{std::get_if<parser::ConstantExpr>(&init->u)}) {
resolver_.NonPointerInitialization(name, *expr);
+ } else {
+ // Don't check legacy DATA /initialization/ here. Component
+ // initializations will have already been handled, and variable
+ // initializations need to be done in DATA checking so that
+ // EQUIVALENCE storage association can be handled.
}
}
}
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 6152f61..69169469 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -769,6 +769,11 @@ void DerivedTypeDetails::add_component(const Symbol &symbol) {
componentNames_.push_back(symbol.name());
}
+void DerivedTypeDetails::add_originalKindParameter(
+ SourceName name, const parser::Expr *expr) {
+ originalKindParameterMap_.emplace(name, expr);
+}
+
const Symbol *DerivedTypeDetails::GetParentComponent(const Scope &scope) const {
if (auto extends{GetParentComponentName()}) {
if (auto iter{scope.find(*extends)}; iter != scope.cend()) {
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 69e6ffa..dba15e6 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -443,9 +443,9 @@ void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {
// Walks a parsed expression to prepare it for (re)analysis;
// clears out the typedExpr analysis results and re-resolves
// symbol table pointers of type parameters.
-class ComponentInitResetHelper {
+class ResetHelper {
public:
- explicit ComponentInitResetHelper(Scope &scope) : scope_{scope} {}
+ explicit ResetHelper(Scope &scope) : scope_{scope} {}
template <typename A> bool Pre(const A &) { return true; }
@@ -498,7 +498,7 @@ void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) {
}
if (const auto *parsedExpr{details->unanalyzedPDTComponentInit()}) {
// Analyze the parsed expression in this PDT instantiation context.
- ComponentInitResetHelper resetter{scope_};
+ ResetHelper resetter{scope_};
parser::Walk(*parsedExpr, resetter);
auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
details->set_init(evaluate::Fold(
@@ -564,16 +564,44 @@ static ParamValue FoldCharacterLength(evaluate::FoldingContext &foldingContext,
// Apply type parameter values to an intrinsic type spec.
const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
SourceName symbolName, const DeclTypeSpec &spec) {
+ const parser::Expr *originalKindExpr{nullptr};
+ if (const DerivedTypeSpec *derived{scope_.derivedTypeSpec()}) {
+ if (const auto *details{derived->originalTypeSymbol()
+ .GetUltimate()
+ .detailsIf<DerivedTypeDetails>()}) {
+ const auto &originalKindMap{details->originalKindParameterMap()};
+ if (auto iter{originalKindMap.find(symbolName)};
+ iter != originalKindMap.end()) {
+ originalKindExpr = iter->second;
+ }
+ }
+ }
const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())};
- if (spec.category() != DeclTypeSpec::Character &&
+ if (spec.category() != DeclTypeSpec::Character && !originalKindExpr &&
evaluate::IsActuallyConstant(intrinsic.kind())) {
return spec; // KIND is already a known constant
}
// The expression was not originally constant, but now it must be so
// in the context of a parameterized derived type instantiation.
- KindExpr copy{Fold(common::Clone(intrinsic.kind()))};
+ std::optional<KindExpr> kindExpr;
+ if (originalKindExpr) {
+ ResetHelper resetter{scope_};
+ parser::Walk(*originalKindExpr, resetter);
+ auto restorer{foldingContext().messages().DiscardMessages()};
+ if (MaybeExpr analyzed{AnalyzeExpr(scope_.context(), *originalKindExpr)}) {
+ if (auto *intExpr{evaluate::UnwrapExpr<SomeIntExpr>(*analyzed)}) {
+ kindExpr = evaluate::ConvertToType<evaluate::SubscriptInteger>(
+ std::move(*intExpr));
+ }
+ }
+ }
+ if (!kindExpr) {
+ kindExpr = KindExpr{intrinsic.kind()};
+ CHECK(kindExpr.has_value());
+ }
+ KindExpr folded{Fold(std::move(*kindExpr))};
int kind{context().GetDefaultKind(intrinsic.category())};
- if (auto value{evaluate::ToInt64(copy)}) {
+ if (auto value{evaluate::ToInt64(folded)}) {
if (foldingContext().targetCharacteristics().IsTypeEnabled(
intrinsic.category(), *value)) {
kind = *value;
@@ -586,7 +614,7 @@ const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
} else {
std::string exprString;
llvm::raw_string_ostream sstream(exprString);
- copy.AsFortran(sstream);
+ folded.AsFortran(sstream);
foldingContext().messages().Say(symbolName,
"KIND parameter expression (%s) of intrinsic type %s did not resolve to a constant value"_err_en_US,
exprString,
generated by cgit v1.1 at 2025-10-11 07:02:09 +0000