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

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