1//===-- lib/Semantics/type.cpp --------------------------------------------===//
2//
3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4// See https://llvm.org/LICENSE.txt for license information.
5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6//
7//===----------------------------------------------------------------------===//
8
9#include "flang/Semantics/type.h"
10#include "check-declarations.h"
11#include "compute-offsets.h"
12#include "flang/Common/type-kinds.h"
13#include "flang/Evaluate/fold.h"
14#include "flang/Evaluate/tools.h"
15#include "flang/Evaluate/type.h"
16#include "flang/Parser/characters.h"
17#include "flang/Parser/parse-tree-visitor.h"
18#include "flang/Semantics/scope.h"
19#include "flang/Semantics/symbol.h"
20#include "flang/Semantics/tools.h"
21#include "llvm/Support/raw_ostream.h"
22
23namespace Fortran::semantics {
24
25DerivedTypeSpec::DerivedTypeSpec(SourceName name, const Symbol &typeSymbol)
26 : name_{name}, originalTypeSymbol_{typeSymbol},
27 typeSymbol_{typeSymbol.GetUltimate()} {
28 CHECK(typeSymbol_.has<DerivedTypeDetails>());
29}
30DerivedTypeSpec::DerivedTypeSpec(const DerivedTypeSpec &that) = default;
31DerivedTypeSpec::DerivedTypeSpec(DerivedTypeSpec &&that) = default;
32
33void DerivedTypeSpec::set_scope(const Scope &scope) {
34 CHECK(!scope_);
35 ReplaceScope(scope);
36}
37void DerivedTypeSpec::ReplaceScope(const Scope &scope) {
38 CHECK(scope.IsDerivedType());
39 scope_ = &scope;
40}
41
42const Scope *DerivedTypeSpec::GetScope() const {
43 return scope_ ? scope_ : typeSymbol_.scope();
44}
45
46void DerivedTypeSpec::AddRawParamValue(
47 const parser::Keyword *keyword, ParamValue &&value) {
48 CHECK(parameters_.empty());
49 rawParameters_.emplace_back(keyword, std::move(value));
50}
51
52void DerivedTypeSpec::CookParameters(evaluate::FoldingContext &foldingContext) {
53 if (cooked_) {
54 return;
55 }
56 cooked_ = true;
57 auto &messages{foldingContext.messages()};
58 if (IsForwardReferenced()) {
59 messages.Say(typeSymbol_.name(),
60 "Derived type '%s' was used but never defined"_err_en_US,
61 typeSymbol_.name());
62 return;
63 }
64
65 // Parameters of the most deeply nested "base class" come first when the
66 // derived type is an extension.
67 auto parameterNames{OrderParameterNames(typeSymbol_)};
68 auto nextNameIter{parameterNames.begin()};
69 RawParameters raw{std::move(rawParameters_)};
70 for (auto &[maybeKeyword, value] : raw) {
71 SourceName name;
72 common::TypeParamAttr attr{common::TypeParamAttr::Kind};
73 if (maybeKeyword) {
74 name = maybeKeyword->v.source;
75 auto it{std::find_if(parameterNames.begin(), parameterNames.end(),
76 [&](const Symbol &symbol) { return symbol.name() == name; })};
77 if (it == parameterNames.end()) {
78 messages.Say(name,
79 "'%s' is not the name of a parameter for derived type '%s'"_err_en_US,
80 name, typeSymbol_.name());
81 } else {
82 // Resolve the keyword's symbol
83 maybeKeyword->v.symbol = const_cast<Symbol *>(&it->get());
84 if (const auto *tpd{it->get().detailsIf<TypeParamDetails>()}) {
85 attr = tpd->attr().value_or(attr);
86 }
87 }
88 } else if (nextNameIter != parameterNames.end()) {
89 name = nextNameIter->get().name();
90 if (const auto *tpd{nextNameIter->get().detailsIf<TypeParamDetails>()}) {
91 attr = tpd->attr().value_or(attr);
92 }
93 ++nextNameIter;
94 } else {
95 messages.Say(name_,
96 "Too many type parameters given for derived type '%s'"_err_en_US,
97 typeSymbol_.name());
98 break;
99 }
100 if (FindParameter(name)) {
101 messages.Say(name_,
102 "Multiple values given for type parameter '%s'"_err_en_US, name);
103 } else {
104 value.set_attr(attr);
105 AddParamValue(name, std::move(value));
106 }
107 }
108}
109
110void DerivedTypeSpec::EvaluateParameters(SemanticsContext &context) {
111 evaluate::FoldingContext &foldingContext{context.foldingContext()};
112 CookParameters(foldingContext);
113 if (evaluated_) {
114 return;
115 }
116 evaluated_ = true;
117 auto &messages{foldingContext.messages()};
118 for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {
119 SourceName name{symbol.name()};
120 int parameterKind{evaluate::TypeParamInquiry::Result::kind};
121 // Compute the integer kind value of the type parameter,
122 // which may depend on the values of earlier ones.
123 if (const auto *typeSpec{symbol.GetType()}) {
124 if (const IntrinsicTypeSpec * intrinType{typeSpec->AsIntrinsic()};
125 intrinType && intrinType->category() == TypeCategory::Integer) {
126 auto restorer{foldingContext.WithPDTInstance(*this)};
127 auto folded{Fold(foldingContext, KindExpr{intrinType->kind()})};
128 if (auto k{evaluate::ToInt64(folded)}; k &&
129 common::IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {
130 parameterKind = static_cast<int>(*k);
131 } else {
132 messages.Say(
133 "Type of type parameter '%s' (%s) is not a valid kind of INTEGER"_err_en_US,
134 name, intrinType->kind().AsFortran());
135 }
136 }
137 }
138 bool ok{
139 symbol.get<TypeParamDetails>().attr() == common::TypeParamAttr::Len};
140 if (ParamValue * paramValue{FindParameter(name)}) {
141 // Explicit type parameter value expressions are not folded within
142 // the scope of the derived type being instantiated, as the expressions
143 // themselves are not in that scope and cannot reference its type
144 // parameters.
145 if (const MaybeIntExpr & expr{paramValue->GetExplicit()}) {
146 evaluate::DynamicType dyType{TypeCategory::Integer, parameterKind};
147 if (auto converted{evaluate::ConvertToType(dyType, SomeExpr{*expr})}) {
148 SomeExpr folded{
149 evaluate::Fold(foldingContext, std::move(*converted))};
150 if (auto *intExpr{std::get_if<SomeIntExpr>(&folded.u)}) {
151 ok = ok || evaluate::IsActuallyConstant(*intExpr);
152 paramValue->SetExplicit(std::move(*intExpr));
153 }
154 } else if (!context.HasError(symbol)) {
155 evaluate::SayWithDeclaration(messages, symbol,
156 "Value of type parameter '%s' (%s) is not convertible to its type (%s)"_err_en_US,
157 name, expr->AsFortran(), dyType.AsFortran());
158 }
159 }
160 } else {
161 // Default type parameter value expressions are folded within
162 // the scope of the derived type being instantiated.
163 const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
164 if (details.init() && details.attr()) {
165 evaluate::DynamicType dyType{TypeCategory::Integer, parameterKind};
166 if (auto converted{
167 evaluate::ConvertToType(dyType, SomeExpr{*details.init()})}) {
168 auto restorer{foldingContext.WithPDTInstance(*this)};
169 SomeExpr folded{
170 evaluate::Fold(foldingContext, std::move(*converted))};
171 ok = ok || evaluate::IsActuallyConstant(folded);
172 AddParamValue(name,
173 ParamValue{std::move(std::get<SomeIntExpr>(folded.u)),
174 details.attr().value()});
175 } else {
176 if (!context.HasError(symbol)) {
177 evaluate::SayWithDeclaration(messages, symbol,
178 "Default value of type parameter '%s' (%s) is not convertible to its type (%s)"_err_en_US,
179 name, details.init()->AsFortran(), dyType.AsFortran());
180 }
181 }
182 } else if (!context.HasError(symbol)) {
183 messages.Say(name_,
184 "Type parameter '%s' lacks a value and has no default"_err_en_US,
185 name);
186 }
187 }
188 if (!ok && !context.HasError(symbol)) {
189 messages.Say(
190 "Value of KIND type parameter '%s' must be constant"_err_en_US, name);
191 }
192 }
193}
194
195void DerivedTypeSpec::AddParamValue(SourceName name, ParamValue &&value) {
196 CHECK(cooked_);
197 auto pair{parameters_.insert(std::make_pair(name, std::move(value)))};
198 CHECK(pair.second); // name was not already present
199}
200
201bool DerivedTypeSpec::MightBeParameterized() const {
202 return !cooked_ || !parameters_.empty();
203}
204
205bool DerivedTypeSpec::IsForwardReferenced() const {
206 return typeSymbol_.get<DerivedTypeDetails>().isForwardReferenced();
207}
208
209bool DerivedTypeSpec::HasDefaultInitialization(
210 bool ignoreAllocatable, bool ignorePointer) const {
211 DirectComponentIterator components{*this};
212 return bool{std::find_if(
213 components.begin(), components.end(), [&](const Symbol &component) {
214 return IsInitialized(component, /*ignoreDataStatements=*/true,
215 ignoreAllocatable, ignorePointer);
216 })};
217}
218
219bool DerivedTypeSpec::HasDestruction() const {
220 if (!FinalsForDerivedTypeInstantiation(*this).empty()) {
221 return true;
222 }
223 DirectComponentIterator components{*this};
224 return bool{std::find_if(
225 components.begin(), components.end(), [&](const Symbol &component) {
226 return IsDestructible(component, &typeSymbol());
227 })};
228}
229
230ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
231 return const_cast<ParamValue *>(
232 const_cast<const DerivedTypeSpec *>(this)->FindParameter(target));
233}
234
235static bool MatchKindParams(const Symbol &typeSymbol,
236 const DerivedTypeSpec &thisSpec, const DerivedTypeSpec &thatSpec) {
237 for (auto ref : typeSymbol.get<DerivedTypeDetails>().paramNameOrder()) {
238 if (ref->get<TypeParamDetails>().attr() == common::TypeParamAttr::Kind) {
239 const auto *thisValue{thisSpec.FindParameter(ref->name())};
240 const auto *thatValue{thatSpec.FindParameter(ref->name())};
241 if (!thisValue || !thatValue || *thisValue != *thatValue) {
242 return false;
243 }
244 }
245 }
246 if (const DerivedTypeSpec *
247 parent{typeSymbol.GetParentTypeSpec(typeSymbol.scope())}) {
248 return MatchKindParams(parent->typeSymbol(), thisSpec, thatSpec);
249 } else {
250 return true;
251 }
252}
253
254bool DerivedTypeSpec::MatchesOrExtends(const DerivedTypeSpec &that) const {
255 const Symbol *typeSymbol{&typeSymbol_};
256 while (typeSymbol != &that.typeSymbol_) {
257 if (const DerivedTypeSpec *
258 parent{typeSymbol->GetParentTypeSpec(typeSymbol->scope())}) {
259 typeSymbol = &parent->typeSymbol_;
260 } else {
261 return false;
262 }
263 }
264 return MatchKindParams(*typeSymbol, *this, that);
265}
266
267class InstantiateHelper {
268public:
269 InstantiateHelper(Scope &scope) : scope_{scope} {}
270 // Instantiate components from fromScope into scope_
271 void InstantiateComponents(const Scope &);
272
273private:
274 SemanticsContext &context() const { return scope_.context(); }
275 evaluate::FoldingContext &foldingContext() {
276 return context().foldingContext();
277 }
278 template <typename A> A Fold(A &&expr) {
279 return evaluate::Fold(foldingContext(), std::move(expr));
280 }
281 void InstantiateComponent(const Symbol &);
282 const DeclTypeSpec *InstantiateType(const Symbol &);
283 const DeclTypeSpec &InstantiateIntrinsicType(
284 SourceName, const DeclTypeSpec &);
285 DerivedTypeSpec CreateDerivedTypeSpec(const DerivedTypeSpec &, bool);
286
287 Scope &scope_;
288};
289
290static int PlumbPDTInstantiationDepth(const Scope *scope) {
291 int depth{0};
292 while (scope->IsParameterizedDerivedTypeInstantiation()) {
293 ++depth;
294 scope = &scope->parent();
295 }
296 return depth;
297}
298
299// Completes component derived type instantiation and initializer folding
300// for a non-parameterized derived type Scope.
301static void InstantiateNonPDTScope(Scope &typeScope, Scope &containingScope) {
302 auto &context{containingScope.context()};
303 auto &foldingContext{context.foldingContext()};
304 for (auto &pair : typeScope) {
305 Symbol &symbol{*pair.second};
306 if (DeclTypeSpec * type{symbol.GetType()}) {
307 if (DerivedTypeSpec * derived{type->AsDerived()}) {
308 if (!(derived->IsForwardReferenced() &&
309 IsAllocatableOrPointer(symbol))) {
310 derived->Instantiate(containingScope);
311 }
312 }
313 }
314 if (!IsPointer(symbol)) {
315 if (auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
316 if (MaybeExpr & init{object->init()}) {
317 auto restorer{foldingContext.messages().SetLocation(symbol.name())};
318 init = evaluate::NonPointerInitializationExpr(
319 symbol, std::move(*init), foldingContext);
320 }
321 }
322 }
323 }
324 ComputeOffsets(context, typeScope);
325}
326
327void DerivedTypeSpec::Instantiate(Scope &containingScope) {
328 if (instantiated_) {
329 return;
330 }
331 instantiated_ = true;
332 auto &context{containingScope.context()};
333 auto &foldingContext{context.foldingContext()};
334 if (IsForwardReferenced()) {
335 foldingContext.messages().Say(typeSymbol_.name(),
336 "The derived type '%s' was forward-referenced but not defined"_err_en_US,
337 typeSymbol_.name());
338 context.SetError(typeSymbol_);
339 return;
340 }
341 EvaluateParameters(context);
342 const Scope &typeScope{DEREF(typeSymbol_.scope())};
343 if (!MightBeParameterized()) {
344 scope_ = &typeScope;
345 if (!typeScope.derivedTypeSpec() || *this != *typeScope.derivedTypeSpec()) {
346 Scope &mutableTypeScope{const_cast<Scope &>(typeScope)};
347 mutableTypeScope.set_derivedTypeSpec(*this);
348 InstantiateNonPDTScope(mutableTypeScope, containingScope);
349 }
350 return;
351 }
352 // New PDT instantiation. Create a new scope and populate it
353 // with components that have been specialized for this set of
354 // parameters.
355 Scope &newScope{containingScope.MakeScope(Scope::Kind::DerivedType)};
356 newScope.set_derivedTypeSpec(*this);
357 ReplaceScope(newScope);
358 auto restorer{foldingContext.WithPDTInstance(*this)};
359 std::string desc{typeSymbol_.name().ToString()};
360 char sep{'('};
361 for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {
362 const SourceName &name{symbol.name()};
363 if (typeScope.find(symbol.name()) != typeScope.end()) {
364 // This type parameter belongs to the derived type itself, not to
365 // one of its ancestors. Put the type parameter expression value,
366 // when there is one, into the new scope as the initialization value
367 // for the parameter. And when there is no explicit value, add an
368 // uninitialized type parameter to forestall use of any default.
369 if (ParamValue * paramValue{FindParameter(name)}) {
370 const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
371 TypeParamDetails instanceDetails{};
372 if (details.attr()) {
373 paramValue->set_attr(*details.attr());
374 instanceDetails.set_attr(*details.attr());
375 }
376 desc += sep;
377 desc += name.ToString();
378 desc += '=';
379 sep = ',';
380 if (MaybeIntExpr expr{paramValue->GetExplicit()}) {
381 desc += expr->AsFortran();
382 instanceDetails.set_init(
383 std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*expr))));
384 if (auto dyType{expr->GetType()}) {
385 instanceDetails.set_type(newScope.MakeNumericType(
386 TypeCategory::Integer, KindExpr{dyType->kind()}));
387 }
388 }
389 if (!instanceDetails.type()) {
390 if (const DeclTypeSpec * type{details.type()}) {
391 instanceDetails.set_type(*type);
392 }
393 }
394 if (!instanceDetails.init()) {
395 desc += '*';
396 }
397 newScope.try_emplace(name, std::move(instanceDetails));
398 }
399 }
400 }
401 parser::Message *contextMessage{nullptr};
402 if (sep != '(') {
403 desc += ')';
404 contextMessage = new parser::Message{foldingContext.messages().at(),
405 "instantiation of parameterized derived type '%s'"_en_US, desc};
406 if (auto outer{containingScope.instantiationContext()}) {
407 contextMessage->SetContext(outer.get());
408 }
409 newScope.set_instantiationContext(contextMessage);
410 }
411 // Instantiate nearly every non-parameter symbol from the original derived
412 // type's scope into the new instance.
413 auto restorer2{foldingContext.messages().SetContext(contextMessage)};
414 if (PlumbPDTInstantiationDepth(&containingScope) > 100) {
415 foldingContext.messages().Say(
416 "Too many recursive parameterized derived type instantiations"_err_en_US);
417 } else {
418 InstantiateHelper{newScope}.InstantiateComponents(typeScope);
419 }
420}
421
422void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {
423 // Instantiate symbols in declaration order; this ensures that
424 // parent components and type parameters of ancestor types exist
425 // by the time that they're needed.
426 for (SymbolRef ref : fromScope.GetSymbols()) {
427 InstantiateComponent(*ref);
428 }
429 ComputeOffsets(context(), scope_);
430}
431
432// Walks a parsed expression to prepare it for (re)analysis;
433// clears out the typedExpr analysis results and re-resolves
434// symbol table pointers of type parameters.
435class ComponentInitResetHelper {
436public:
437 explicit ComponentInitResetHelper(Scope &scope) : scope_{scope} {}
438
439 template <typename A> bool Pre(const A &) { return true; }
440
441 template <typename A> void Post(const A &x) {
442 if constexpr (parser::HasTypedExpr<A>()) {
443 x.typedExpr.Reset();
444 }
445 }
446
447 void Post(const parser::Name &name) {
448 if (name.symbol && name.symbol->has<TypeParamDetails>()) {
449 name.symbol = scope_.FindComponent(name.source);
450 }
451 }
452
453private:
454 Scope &scope_;
455};
456
457void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) {
458 auto pair{scope_.try_emplace(
459 oldSymbol.name(), oldSymbol.attrs(), common::Clone(oldSymbol.details()))};
460 Symbol &newSymbol{*pair.first->second};
461 if (!pair.second) {
462 // Symbol was already present in the scope, which can only happen
463 // in the case of type parameters.
464 CHECK(oldSymbol.has<TypeParamDetails>());
465 return;
466 }
467 newSymbol.flags() = oldSymbol.flags();
468 if (auto *details{newSymbol.detailsIf<ObjectEntityDetails>()}) {
469 if (const DeclTypeSpec * newType{InstantiateType(newSymbol)}) {
470 details->ReplaceType(*newType);
471 }
472 for (ShapeSpec &dim : details->shape()) {
473 if (dim.lbound().isExplicit()) {
474 dim.lbound().SetExplicit(Fold(std::move(dim.lbound().GetExplicit())));
475 }
476 if (dim.ubound().isExplicit()) {
477 dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit())));
478 }
479 }
480 for (ShapeSpec &dim : details->coshape()) {
481 if (dim.lbound().isExplicit()) {
482 dim.lbound().SetExplicit(Fold(std::move(dim.lbound().GetExplicit())));
483 }
484 if (dim.ubound().isExplicit()) {
485 dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit())));
486 }
487 }
488 if (const auto *parsedExpr{details->unanalyzedPDTComponentInit()}) {
489 // Analyze the parsed expression in this PDT instantiation context.
490 ComponentInitResetHelper resetter{scope_};
491 parser::Walk(*parsedExpr, resetter);
492 auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
493 details->set_init(evaluate::Fold(
494 foldingContext(), AnalyzeExpr(context(), *parsedExpr)));
495 details->set_unanalyzedPDTComponentInit(nullptr);
496 // Remove analysis results to prevent unparsing or other use of
497 // instantiation-specific expressions.
498 parser::Walk(*parsedExpr, resetter);
499 }
500 if (MaybeExpr & init{details->init()}) {
501 // Non-pointer components with default initializers are
502 // processed now so that those default initializers can be used
503 // in PARAMETER structure constructors.
504 auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
505 init = IsPointer(newSymbol)
506 ? Fold(std::move(*init))
507 : evaluate::NonPointerInitializationExpr(
508 newSymbol, std::move(*init), foldingContext());
509 }
510 } else if (auto *procDetails{newSymbol.detailsIf<ProcEntityDetails>()}) {
511 // We have a procedure pointer. Instantiate its return type
512 if (const DeclTypeSpec * returnType{InstantiateType(newSymbol)}) {
513 if (!procDetails->procInterface()) {
514 procDetails->ReplaceType(*returnType);
515 }
516 }
517 }
518}
519
520const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) {
521 const DeclTypeSpec *type{symbol.GetType()};
522 if (!type) {
523 return nullptr; // error has occurred
524 } else if (const DerivedTypeSpec * spec{type->AsDerived()}) {
525 return &FindOrInstantiateDerivedType(scope_,
526 CreateDerivedTypeSpec(*spec, symbol.test(Symbol::Flag::ParentComp)),
527 type->category());
528 } else if (type->AsIntrinsic()) {
529 return &InstantiateIntrinsicType(symbol.name(), *type);
530 } else if (type->category() == DeclTypeSpec::ClassStar) {
531 return type;
532 } else {
533 common::die("InstantiateType: %s", type->AsFortran().c_str());
534 }
535}
536
537/// Fold explicit length parameters of character components when the explicit
538/// expression is a constant expression (if it only depends on KIND parameters).
539/// Do not fold `character(len=pdt_length)`, even if the length parameter is
540/// constant in the pdt instantiation, in order to avoid losing the information
541/// that the character component is automatic (and must be a descriptor).
542static ParamValue FoldCharacterLength(evaluate::FoldingContext &foldingContext,
543 const CharacterTypeSpec &characterSpec) {
544 if (const auto &len{characterSpec.length().GetExplicit()}) {
545 if (evaluate::IsConstantExpr(*len)) {
546 return ParamValue{evaluate::Fold(foldingContext, common::Clone(*len)),
547 common::TypeParamAttr::Len};
548 }
549 }
550 return characterSpec.length();
551}
552
553// Apply type parameter values to an intrinsic type spec.
554const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
555 SourceName symbolName, const DeclTypeSpec &spec) {
556 const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())};
557 if (spec.category() != DeclTypeSpec::Character &&
558 evaluate::IsActuallyConstant(intrinsic.kind())) {
559 return spec; // KIND is already a known constant
560 }
561 // The expression was not originally constant, but now it must be so
562 // in the context of a parameterized derived type instantiation.
563 KindExpr copy{Fold(common::Clone(intrinsic.kind()))};
564 int kind{context().GetDefaultKind(intrinsic.category())};
565 if (auto value{evaluate::ToInt64(copy)}) {
566 if (foldingContext().targetCharacteristics().IsTypeEnabled(
567 intrinsic.category(), *value)) {
568 kind = *value;
569 } else {
570 foldingContext().messages().Say(symbolName,
571 "KIND parameter value (%jd) of intrinsic type %s did not resolve to a supported value"_err_en_US,
572 *value,
573 parser::ToUpperCaseLetters(EnumToString(intrinsic.category())));
574 }
575 } else {
576 std::string exprString;
577 llvm::raw_string_ostream sstream(exprString);
578 copy.AsFortran(sstream);
579 foldingContext().messages().Say(symbolName,
580 "KIND parameter expression (%s) of intrinsic type %s did not resolve to a constant value"_err_en_US,
581 exprString,
582 parser::ToUpperCaseLetters(EnumToString(intrinsic.category())));
583 }
584 switch (spec.category()) {
585 case DeclTypeSpec::Numeric:
586 return scope_.MakeNumericType(intrinsic.category(), KindExpr{kind});
587 case DeclTypeSpec::Logical:
588 return scope_.MakeLogicalType(KindExpr{kind});
589 case DeclTypeSpec::Character:
590 return scope_.MakeCharacterType(
591 FoldCharacterLength(foldingContext(), spec.characterTypeSpec()),
592 KindExpr{kind});
593 default:
594 CRASH_NO_CASE;
595 }
596}
597
598DerivedTypeSpec InstantiateHelper::CreateDerivedTypeSpec(
599 const DerivedTypeSpec &spec, bool isParentComp) {
600 DerivedTypeSpec result{spec};
601 result.CookParameters(foldingContext()); // enables AddParamValue()
602 if (isParentComp) {
603 // Forward any explicit type parameter values from the
604 // derived type spec under instantiation that define type parameters
605 // of the parent component to the derived type spec of the
606 // parent component.
607 const DerivedTypeSpec &instanceSpec{DEREF(foldingContext().pdtInstance())};
608 for (const auto &[name, value] : instanceSpec.parameters()) {
609 if (scope_.find(name) == scope_.end()) {
610 result.AddParamValue(name, ParamValue{value});
611 }
612 }
613 }
614 return result;
615}
616
617std::string DerivedTypeSpec::VectorTypeAsFortran() const {
618 std::string buf;
619 llvm::raw_string_ostream ss{buf};
620
621 switch (category()) {
622 SWITCH_COVERS_ALL_CASES
623 case (Fortran::semantics::DerivedTypeSpec::Category::IntrinsicVector): {
624 int64_t vecElemKind;
625 int64_t vecElemCategory;
626
627 for (const auto &pair : parameters()) {
628 if (pair.first == "element_category") {
629 vecElemCategory =
630 Fortran::evaluate::ToInt64(pair.second.GetExplicit()).value_or(-1);
631 } else if (pair.first == "element_kind") {
632 vecElemKind =
633 Fortran::evaluate::ToInt64(pair.second.GetExplicit()).value_or(0);
634 }
635 }
636
637 assert((vecElemCategory >= 0 &&
638 static_cast<size_t>(vecElemCategory) <
639 Fortran::common::VectorElementCategory_enumSize) &&
640 "Vector element type is not specified");
641 assert(vecElemKind && "Vector element kind is not specified");
642
643 ss << "vector(";
644 switch (static_cast<common::VectorElementCategory>(vecElemCategory)) {
645 SWITCH_COVERS_ALL_CASES
646 case common::VectorElementCategory::Integer:
647 ss << "integer(" << vecElemKind << ")";
648 break;
649 case common::VectorElementCategory::Unsigned:
650 ss << "unsigned(" << vecElemKind << ")";
651 break;
652 case common::VectorElementCategory::Real:
653 ss << "real(" << vecElemKind << ")";
654 break;
655 }
656 ss << ")";
657 break;
658 }
659 case (Fortran::semantics::DerivedTypeSpec::Category::PairVector):
660 ss << "__vector_pair";
661 break;
662 case (Fortran::semantics::DerivedTypeSpec::Category::QuadVector):
663 ss << "__vector_quad";
664 break;
665 case (Fortran::semantics::DerivedTypeSpec::Category::DerivedType):
666 Fortran::common::die("Vector element type not implemented");
667 }
668 return buf;
669}
670
671std::string DerivedTypeSpec::AsFortran() const {
672 std::string buf;
673 llvm::raw_string_ostream ss{buf};
674 ss << originalTypeSymbol_.name();
675 if (!rawParameters_.empty()) {
676 CHECK(parameters_.empty());
677 ss << '(';
678 bool first = true;
679 for (const auto &[maybeKeyword, value] : rawParameters_) {
680 if (first) {
681 first = false;
682 } else {
683 ss << ',';
684 }
685 if (maybeKeyword) {
686 ss << maybeKeyword->v.source.ToString() << '=';
687 }
688 ss << value.AsFortran();
689 }
690 ss << ')';
691 } else if (!parameters_.empty()) {
692 ss << '(';
693 bool first = true;
694 for (const auto &[name, value] : parameters_) {
695 if (first) {
696 first = false;
697 } else {
698 ss << ',';
699 }
700 ss << name.ToString() << '=' << value.AsFortran();
701 }
702 ss << ')';
703 }
704 return buf;
705}
706
707llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DerivedTypeSpec &x) {
708 return o << x.AsFortran();
709}
710
711Bound::Bound(common::ConstantSubscript bound) : expr_{bound} {}
712
713llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const Bound &x) {
714 if (x.isStar()) {
715 o << '*';
716 } else if (x.isColon()) {
717 o << ':';
718 } else if (x.expr_) {
719 x.expr_->AsFortran(o);
720 } else {
721 o << "<no-expr>";
722 }
723 return o;
724}
725
726llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const ShapeSpec &x) {
727 if (x.lb_.isStar()) {
728 CHECK(x.ub_.isStar());
729 o << "..";
730 } else {
731 if (!x.lb_.isColon()) {
732 o << x.lb_;
733 }
734 o << ':';
735 if (!x.ub_.isColon()) {
736 o << x.ub_;
737 }
738 }
739 return o;
740}
741
742llvm::raw_ostream &operator<<(
743 llvm::raw_ostream &os, const ArraySpec &arraySpec) {
744 char sep{'('};
745 for (auto &shape : arraySpec) {
746 os << sep << shape;
747 sep = ',';
748 }
749 if (sep == ',') {
750 os << ')';
751 }
752 return os;
753}
754
755ParamValue::ParamValue(MaybeIntExpr &&expr, common::TypeParamAttr attr)
756 : attr_{attr}, expr_{std::move(expr)} {}
757ParamValue::ParamValue(SomeIntExpr &&expr, common::TypeParamAttr attr)
758 : attr_{attr}, expr_{std::move(expr)} {}
759ParamValue::ParamValue(
760 common::ConstantSubscript value, common::TypeParamAttr attr)
761 : ParamValue(SomeIntExpr{evaluate::Expr<evaluate::SubscriptInteger>{value}},
762 attr) {}
763
764void ParamValue::SetExplicit(SomeIntExpr &&x) {
765 category_ = Category::Explicit;
766 expr_ = std::move(x);
767}
768
769std::string ParamValue::AsFortran() const {
770 switch (category_) {
771 SWITCH_COVERS_ALL_CASES
772 case Category::Assumed:
773 return "*";
774 case Category::Deferred:
775 return ":";
776 case Category::Explicit:
777 if (expr_) {
778 std::string buf;
779 llvm::raw_string_ostream ss{buf};
780 expr_->AsFortran(ss);
781 return buf;
782 } else {
783 return "";
784 }
785 }
786}
787
788llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const ParamValue &x) {
789 return o << x.AsFortran();
790}
791
792IntrinsicTypeSpec::IntrinsicTypeSpec(TypeCategory category, KindExpr &&kind)
793 : category_{category}, kind_{std::move(kind)} {
794 CHECK(category != TypeCategory::Derived);
795}
796
797static std::string KindAsFortran(const KindExpr &kind) {
798 std::string buf;
799 llvm::raw_string_ostream ss{buf};
800 if (auto k{evaluate::ToInt64(kind)}) {
801 ss << *k; // emit unsuffixed kind code
802 } else {
803 kind.AsFortran(ss);
804 }
805 return buf;
806}
807
808std::string IntrinsicTypeSpec::AsFortran() const {
809 return parser::ToUpperCaseLetters(common::EnumToString(category_)) + '(' +
810 KindAsFortran(kind_) + ')';
811}
812
813llvm::raw_ostream &operator<<(
814 llvm::raw_ostream &os, const IntrinsicTypeSpec &x) {
815 return os << x.AsFortran();
816}
817
818std::string CharacterTypeSpec::AsFortran() const {
819 return "CHARACTER(" + length_.AsFortran() + ',' + KindAsFortran(kind()) + ')';
820}
821
822llvm::raw_ostream &operator<<(
823 llvm::raw_ostream &os, const CharacterTypeSpec &x) {
824 return os << x.AsFortran();
825}
826
827DeclTypeSpec::DeclTypeSpec(NumericTypeSpec &&typeSpec)
828 : category_{Numeric}, typeSpec_{std::move(typeSpec)} {}
829DeclTypeSpec::DeclTypeSpec(LogicalTypeSpec &&typeSpec)
830 : category_{Logical}, typeSpec_{std::move(typeSpec)} {}
831DeclTypeSpec::DeclTypeSpec(const CharacterTypeSpec &typeSpec)
832 : category_{Character}, typeSpec_{typeSpec} {}
833DeclTypeSpec::DeclTypeSpec(CharacterTypeSpec &&typeSpec)
834 : category_{Character}, typeSpec_{std::move(typeSpec)} {}
835DeclTypeSpec::DeclTypeSpec(Category category, const DerivedTypeSpec &typeSpec)
836 : category_{category}, typeSpec_{typeSpec} {
837 CHECK(category == TypeDerived || category == ClassDerived);
838}
839DeclTypeSpec::DeclTypeSpec(Category category, DerivedTypeSpec &&typeSpec)
840 : category_{category}, typeSpec_{std::move(typeSpec)} {
841 CHECK(category == TypeDerived || category == ClassDerived);
842}
843DeclTypeSpec::DeclTypeSpec(Category category) : category_{category} {
844 CHECK(category == TypeStar || category == ClassStar);
845}
846bool DeclTypeSpec::IsNumeric(TypeCategory tc) const {
847 return category_ == Numeric && numericTypeSpec().category() == tc;
848}
849bool DeclTypeSpec::IsSequenceType() const {
850 if (const DerivedTypeSpec * derivedType{AsDerived()}) {
851 const auto *typeDetails{
852 derivedType->typeSymbol().detailsIf<DerivedTypeDetails>()};
853 return typeDetails && typeDetails->sequence();
854 }
855 return false;
856}
857
858const NumericTypeSpec &DeclTypeSpec::numericTypeSpec() const {
859 CHECK(category_ == Numeric);
860 return std::get<NumericTypeSpec>(typeSpec_);
861}
862const LogicalTypeSpec &DeclTypeSpec::logicalTypeSpec() const {
863 CHECK(category_ == Logical);
864 return std::get<LogicalTypeSpec>(typeSpec_);
865}
866bool DeclTypeSpec::operator==(const DeclTypeSpec &that) const {
867 return category_ == that.category_ && typeSpec_ == that.typeSpec_;
868}
869
870std::string DeclTypeSpec::AsFortran() const {
871 switch (category_) {
872 SWITCH_COVERS_ALL_CASES
873 case Numeric:
874 return numericTypeSpec().AsFortran();
875 case Logical:
876 return logicalTypeSpec().AsFortran();
877 case Character:
878 return characterTypeSpec().AsFortran();
879 case TypeDerived:
880 if (derivedTypeSpec()
881 .typeSymbol()
882 .get<DerivedTypeDetails>()
883 .isDECStructure()) {
884 return "RECORD" + derivedTypeSpec().typeSymbol().name().ToString();
885 } else if (derivedTypeSpec().IsVectorType()) {
886 return derivedTypeSpec().VectorTypeAsFortran();
887 } else {
888 return "TYPE(" + derivedTypeSpec().AsFortran() + ')';
889 }
890 case ClassDerived:
891 return "CLASS(" + derivedTypeSpec().AsFortran() + ')';
892 case TypeStar:
893 return "TYPE(*)";
894 case ClassStar:
895 return "CLASS(*)";
896 }
897}
898
899llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DeclTypeSpec &x) {
900 return o << x.AsFortran();
901}
902
903} // namespace Fortran::semantics
904

source code of flang/lib/Semantics/type.cpp