1//===-- lib/Evaluate/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/Evaluate/type.h"
10#include "flang/Common/idioms.h"
11#include "flang/Common/type-kinds.h"
12#include "flang/Evaluate/expression.h"
13#include "flang/Evaluate/fold.h"
14#include "flang/Evaluate/target.h"
15#include "flang/Parser/characters.h"
16#include "flang/Semantics/scope.h"
17#include "flang/Semantics/symbol.h"
18#include "flang/Semantics/tools.h"
19#include "flang/Semantics/type.h"
20#include <algorithm>
21#include <optional>
22#include <string>
23
24// IsDescriptor() predicate: true when a symbol is implemented
25// at runtime with a descriptor.
26namespace Fortran::semantics {
27
28static bool IsDescriptor(const DeclTypeSpec *type) {
29 if (type) {
30 if (auto dynamicType{evaluate::DynamicType::From(*type)}) {
31 return dynamicType->RequiresDescriptor();
32 }
33 }
34 return false;
35}
36
37static bool IsDescriptor(const ObjectEntityDetails &details) {
38 if (IsDescriptor(details.type()) || details.IsAssumedRank()) {
39 return true;
40 }
41 for (const ShapeSpec &shapeSpec : details.shape()) {
42 if (const auto &ub{shapeSpec.ubound().GetExplicit()}) {
43 if (!IsConstantExpr(*ub)) {
44 return true;
45 }
46 } else {
47 return shapeSpec.ubound().isColon();
48 }
49 }
50 return false;
51}
52
53bool IsDescriptor(const Symbol &symbol) {
54 return common::visit(
55 common::visitors{
56 [&](const ObjectEntityDetails &d) {
57 return IsAllocatableOrPointer(symbol) || IsDescriptor(d);
58 },
59 [&](const ProcEntityDetails &d) { return false; },
60 [&](const EntityDetails &d) { return IsDescriptor(d.type()); },
61 [](const AssocEntityDetails &d) {
62 if (const auto &expr{d.expr()}) {
63 if (expr->Rank() > 0) {
64 return true;
65 }
66 if (const auto dynamicType{expr->GetType()}) {
67 if (dynamicType->RequiresDescriptor()) {
68 return true;
69 }
70 }
71 }
72 return false;
73 },
74 [](const SubprogramDetails &d) {
75 return d.isFunction() && IsDescriptor(d.result());
76 },
77 [](const UseDetails &d) { return IsDescriptor(d.symbol()); },
78 [](const HostAssocDetails &d) { return IsDescriptor(d.symbol()); },
79 [](const auto &) { return false; },
80 },
81 symbol.details());
82}
83
84bool IsPassedViaDescriptor(const Symbol &symbol) {
85 if (!IsDescriptor(symbol)) {
86 return false;
87 }
88 if (IsAllocatableOrPointer(symbol)) {
89 return true;
90 }
91 if (semantics::IsAssumedSizeArray(symbol)) {
92 return false;
93 }
94 if (const auto *object{
95 symbol.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
96 if (object->isDummy()) {
97 if (object->type() &&
98 object->type()->category() == DeclTypeSpec::Character) {
99 return false;
100 }
101 bool isExplicitShape{true};
102 for (const ShapeSpec &shapeSpec : object->shape()) {
103 if (!shapeSpec.lbound().GetExplicit() ||
104 !shapeSpec.ubound().GetExplicit()) {
105 isExplicitShape = false;
106 break;
107 }
108 }
109 if (isExplicitShape) {
110 return false; // explicit shape but non-constant bounds
111 }
112 }
113 }
114 return true;
115}
116} // namespace Fortran::semantics
117
118namespace Fortran::evaluate {
119
120DynamicType::DynamicType(int k, const semantics::ParamValue &pv)
121 : category_{TypeCategory::Character}, kind_{k} {
122 CHECK(common::IsValidKindOfIntrinsicType(category_, kind_));
123 if (auto n{ToInt64(pv.GetExplicit())}) {
124 knownLength_ = *n > 0 ? *n : 0;
125 } else {
126 charLengthParamValue_ = &pv;
127 }
128}
129
130template <typename A> inline bool PointeeComparison(const A *x, const A *y) {
131 return x == y || (x && y && *x == *y);
132}
133
134bool DynamicType::operator==(const DynamicType &that) const {
135 return category_ == that.category_ && kind_ == that.kind_ &&
136 PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) &&
137 knownLength().has_value() == that.knownLength().has_value() &&
138 (!knownLength() || *knownLength() == *that.knownLength()) &&
139 PointeeComparison(derived_, that.derived_);
140}
141
142std::optional<Expr<SubscriptInteger>> DynamicType::GetCharLength() const {
143 if (category_ == TypeCategory::Character) {
144 if (knownLength()) {
145 return AsExpr(Constant<SubscriptInteger>(*knownLength()));
146 } else if (charLengthParamValue_) {
147 if (auto length{charLengthParamValue_->GetExplicit()}) {
148 return ConvertToType<SubscriptInteger>(std::move(*length));
149 }
150 }
151 }
152 return std::nullopt;
153}
154
155std::size_t DynamicType::GetAlignment(
156 const TargetCharacteristics &targetCharacteristics) const {
157 if (category_ == TypeCategory::Derived) {
158 switch (GetDerivedTypeSpec().category()) {
159 SWITCH_COVERS_ALL_CASES
160 case semantics::DerivedTypeSpec::Category::DerivedType:
161 if (derived_ && derived_->scope()) {
162 return derived_->scope()->alignment().value_or(1);
163 }
164 break;
165 case semantics::DerivedTypeSpec::Category::IntrinsicVector:
166 case semantics::DerivedTypeSpec::Category::PairVector:
167 case semantics::DerivedTypeSpec::Category::QuadVector:
168 if (derived_ && derived_->scope()) {
169 return derived_->scope()->size();
170 } else {
171 common::die("Missing scope for Vector type.");
172 }
173 }
174 } else {
175 return targetCharacteristics.GetAlignment(category_, kind());
176 }
177 return 1; // needs to be after switch to dodge a bogus gcc warning
178}
179
180std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
181 FoldingContext &context, bool aligned,
182 std::optional<std::int64_t> charLength) const {
183 switch (category_) {
184 case TypeCategory::Integer:
185 case TypeCategory::Unsigned:
186 case TypeCategory::Real:
187 case TypeCategory::Complex:
188 case TypeCategory::Logical:
189 return Expr<SubscriptInteger>{
190 context.targetCharacteristics().GetByteSize(category_, kind())};
191 case TypeCategory::Character:
192 if (auto len{charLength ? Expr<SubscriptInteger>{Constant<SubscriptInteger>{
193 *charLength}}
194 : GetCharLength()}) {
195 return Fold(context,
196 Expr<SubscriptInteger>{
197 context.targetCharacteristics().GetByteSize(category_, kind())} *
198 std::move(*len));
199 }
200 break;
201 case TypeCategory::Derived:
202 if (!IsPolymorphic() && derived_ && derived_->scope()) {
203 auto size{derived_->scope()->size()};
204 auto align{aligned ? derived_->scope()->alignment().value_or(0) : 0};
205 auto alignedSize{align > 0 ? ((size + align - 1) / align) * align : size};
206 return Expr<SubscriptInteger>{
207 static_cast<ConstantSubscript>(alignedSize)};
208 }
209 break;
210 }
211 return std::nullopt;
212}
213
214bool DynamicType::IsAssumedLengthCharacter() const {
215 return category_ == TypeCategory::Character && charLengthParamValue_ &&
216 charLengthParamValue_->isAssumed();
217}
218
219bool DynamicType::IsNonConstantLengthCharacter() const {
220 if (category_ != TypeCategory::Character) {
221 return false;
222 } else if (knownLength()) {
223 return false;
224 } else if (!charLengthParamValue_) {
225 return true;
226 } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) {
227 return !IsConstantExpr(*expr);
228 } else {
229 return true;
230 }
231}
232
233bool DynamicType::IsTypelessIntrinsicArgument() const {
234 return category_ == TypeCategory::Integer && kind_ == TypelessKind;
235}
236
237bool DynamicType::IsLengthlessIntrinsicType() const {
238 return common::IsNumericTypeCategory(category_) ||
239 category_ == TypeCategory::Logical;
240}
241
242const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
243 const std::optional<DynamicType> &type) {
244 return type ? GetDerivedTypeSpec(*type) : nullptr;
245}
246
247const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
248 if (type.category() == TypeCategory::Derived &&
249 !type.IsUnlimitedPolymorphic()) {
250 return &type.GetDerivedTypeSpec();
251 } else {
252 return nullptr;
253 }
254}
255
256static const semantics::Symbol *FindParentComponent(
257 const semantics::DerivedTypeSpec &derived) {
258 const semantics::Symbol &typeSymbol{derived.typeSymbol()};
259 const semantics::Scope *scope{derived.scope()};
260 if (!scope) {
261 scope = typeSymbol.scope();
262 }
263 if (scope) {
264 const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
265 // TODO: Combine with semantics::DerivedTypeDetails::GetParentComponent
266 if (auto extends{dtDetails.GetParentComponentName()}) {
267 if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
268 if (const semantics::Symbol & symbol{*iter->second};
269 symbol.test(semantics::Symbol::Flag::ParentComp)) {
270 return &symbol;
271 }
272 }
273 }
274 }
275 return nullptr;
276}
277
278const semantics::DerivedTypeSpec *GetParentTypeSpec(
279 const semantics::DerivedTypeSpec &derived) {
280 if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
281 return &parent->get<semantics::ObjectEntityDetails>()
282 .type()
283 ->derivedTypeSpec();
284 } else {
285 return nullptr;
286 }
287}
288
289// Compares two derived type representations to see whether they both
290// represent the "same type" in the sense of section F'2023 7.5.2.4.
291using SetOfDerivedTypePairs =
292 std::set<std::pair<const semantics::DerivedTypeSpec *,
293 const semantics::DerivedTypeSpec *>>;
294
295static bool AreSameDerivedType(const semantics::DerivedTypeSpec &,
296 const semantics::DerivedTypeSpec &, bool ignoreTypeParameterValues,
297 bool ignoreLenParameters, bool ignoreSequence,
298 SetOfDerivedTypePairs &inProgress);
299
300// F2023 7.5.3.2
301static bool AreSameComponent(const semantics::Symbol &x,
302 const semantics::Symbol &y, bool ignoreSequence, bool sameModuleName,
303 SetOfDerivedTypePairs &inProgress) {
304 if (x.attrs() != y.attrs()) {
305 return false;
306 }
307 if (x.attrs().test(semantics::Attr::PRIVATE) ||
308 y.attrs().test(semantics::Attr::PRIVATE)) {
309 if (!sameModuleName ||
310 x.attrs().test(semantics::Attr::PRIVATE) !=
311 y.attrs().test(semantics::Attr::PRIVATE)) {
312 return false;
313 }
314 }
315 if (x.size() && y.size()) {
316 if (x.offset() != y.offset() || x.size() != y.size()) {
317 return false;
318 }
319 }
320 const auto *xObj{x.detailsIf<semantics::ObjectEntityDetails>()};
321 const auto *yObj{y.detailsIf<semantics::ObjectEntityDetails>()};
322 const auto *xProc{x.detailsIf<semantics::ProcEntityDetails>()};
323 const auto *yProc{y.detailsIf<semantics::ProcEntityDetails>()};
324 if (!xObj != !yObj || !xProc != !yProc) {
325 return false;
326 }
327 auto xType{DynamicType::From(x)};
328 auto yType{DynamicType::From(y)};
329 if (xType && yType) {
330 if (xType->category() == TypeCategory::Derived) {
331 if (yType->category() != TypeCategory::Derived ||
332 !xType->IsUnlimitedPolymorphic() !=
333 !yType->IsUnlimitedPolymorphic() ||
334 (!xType->IsUnlimitedPolymorphic() &&
335 !AreSameDerivedType(xType->GetDerivedTypeSpec(),
336 yType->GetDerivedTypeSpec(), false, false, ignoreSequence,
337 inProgress))) {
338 return false;
339 }
340 } else if (!xType->IsTkLenCompatibleWith(*yType)) {
341 return false;
342 }
343 } else if (xType || yType || !(xProc && yProc)) {
344 return false;
345 }
346 if (xProc) {
347 // TODO: compare argument types, &c.
348 }
349 return true;
350}
351
352// TODO: These utilities were cloned out of Semantics to avoid a cyclic
353// dependency and should be repackaged into then "namespace semantics"
354// part of Evaluate/tools.cpp.
355
356static const semantics::Symbol *GetParentComponent(
357 const semantics::DerivedTypeDetails &details,
358 const semantics::Scope &scope) {
359 if (auto extends{details.GetParentComponentName()}) {
360 if (auto iter{scope.find(*extends)}; iter != scope.cend()) {
361 if (const Symbol & symbol{*iter->second};
362 symbol.test(semantics::Symbol::Flag::ParentComp)) {
363 return &symbol;
364 }
365 }
366 }
367 return nullptr;
368}
369
370static const semantics::Symbol *GetParentComponent(
371 const semantics::Symbol *symbol, const semantics::Scope &scope) {
372 if (symbol) {
373 if (const auto *dtDetails{
374 symbol->detailsIf<semantics::DerivedTypeDetails>()}) {
375 return GetParentComponent(*dtDetails, scope);
376 }
377 }
378 return nullptr;
379}
380
381static const semantics::DerivedTypeSpec *GetParentTypeSpec(
382 const semantics::Symbol *symbol, const semantics::Scope &scope) {
383 if (const Symbol * parentComponent{GetParentComponent(symbol, scope)}) {
384 return &parentComponent->get<semantics::ObjectEntityDetails>()
385 .type()
386 ->derivedTypeSpec();
387 } else {
388 return nullptr;
389 }
390}
391
392static const semantics::Scope *GetDerivedTypeParent(
393 const semantics::Scope *scope) {
394 if (scope) {
395 CHECK(scope->IsDerivedType());
396 if (const auto *parent{GetParentTypeSpec(scope->GetSymbol(), *scope)}) {
397 return parent->scope();
398 }
399 }
400 return nullptr;
401}
402
403static const semantics::Symbol *FindComponent(
404 const semantics::Scope *scope, parser::CharBlock name) {
405 if (!scope) {
406 return nullptr;
407 }
408 CHECK(scope->IsDerivedType());
409 auto found{scope->find(name)};
410 if (found != scope->end()) {
411 return &*found->second;
412 } else {
413 return FindComponent(GetDerivedTypeParent(scope), name);
414 }
415}
416
417static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x,
418 const semantics::DerivedTypeSpec &y, bool ignoreLenParameters) {
419 const auto *xScope{x.typeSymbol().scope()};
420 const auto *yScope{y.typeSymbol().scope()};
421 for (const auto &[paramName, value] : x.parameters()) {
422 const auto *yValue{y.FindParameter(paramName)};
423 if (!yValue) {
424 return false;
425 }
426 const auto *xParm{FindComponent(xScope, paramName)};
427 const auto *yParm{FindComponent(yScope, paramName)};
428 if (xParm && yParm) {
429 const auto *xTPD{xParm->detailsIf<semantics::TypeParamDetails>()};
430 const auto *yTPD{yParm->detailsIf<semantics::TypeParamDetails>()};
431 if (xTPD && yTPD) {
432 if (xTPD->attr() != yTPD->attr()) {
433 return false;
434 }
435 if (!ignoreLenParameters ||
436 xTPD->attr() != common::TypeParamAttr::Len) {
437 auto xExpr{value.GetExplicit()};
438 auto yExpr{yValue->GetExplicit()};
439 if (xExpr && yExpr) {
440 auto xVal{ToInt64(*xExpr)};
441 auto yVal{ToInt64(*yExpr)};
442 if (xVal && yVal && *xVal != *yVal) {
443 return false;
444 }
445 }
446 }
447 }
448 }
449 }
450 for (const auto &[paramName, _] : y.parameters()) {
451 if (!x.FindParameter(paramName)) {
452 return false; // y has more parameters than x
453 }
454 }
455 return true;
456}
457
458// F2023 7.5.3.2
459static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
460 const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
461 bool ignoreLenParameters, bool ignoreSequence,
462 SetOfDerivedTypePairs &inProgress) {
463 if (&x == &y) {
464 return true;
465 }
466 if (!ignoreTypeParameterValues &&
467 !AreTypeParamCompatible(x, y, ignoreLenParameters)) {
468 return false;
469 }
470 const auto &xSymbol{x.typeSymbol().GetUltimate()};
471 const auto &ySymbol{y.typeSymbol().GetUltimate()};
472 if (xSymbol == ySymbol) {
473 return true;
474 }
475 if (xSymbol.name() != ySymbol.name()) {
476 return false;
477 }
478 auto thisQuery{std::make_pair(&x, &y)};
479 if (inProgress.find(thisQuery) != inProgress.end()) {
480 return true; // recursive use of types in components
481 }
482 inProgress.insert(thisQuery);
483 const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
484 const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
485 if (xDetails.sequence() != yDetails.sequence() ||
486 xSymbol.attrs().test(semantics::Attr::BIND_C) !=
487 ySymbol.attrs().test(semantics::Attr::BIND_C)) {
488 return false;
489 }
490 bool sameModuleName{false};
491 const semantics::Scope &xOwner{xSymbol.owner()};
492 const semantics::Scope &yOwner{ySymbol.owner()};
493 if (xOwner.IsModule() && yOwner.IsModule()) {
494 if (auto xModuleName{xOwner.GetName()}) {
495 if (auto yModuleName{yOwner.GetName()}) {
496 if (*xModuleName == *yModuleName) {
497 sameModuleName = true;
498 }
499 }
500 }
501 }
502 if (!sameModuleName && !ignoreSequence && !xDetails.sequence() &&
503 !xSymbol.attrs().test(semantics::Attr::BIND_C)) {
504 // PGI does not enforce this requirement; all other Fortran
505 // compilers do with a hard error when violations are caught.
506 return false;
507 }
508 // Compare the component lists in their orders of declaration.
509 auto xEnd{xDetails.componentNames().cend()};
510 auto yComponentName{yDetails.componentNames().cbegin()};
511 auto yEnd{yDetails.componentNames().cend()};
512 for (auto xComponentName{xDetails.componentNames().cbegin()};
513 xComponentName != xEnd; ++xComponentName, ++yComponentName) {
514 if (yComponentName == yEnd || *xComponentName != *yComponentName ||
515 !xSymbol.scope() || !ySymbol.scope()) {
516 return false;
517 }
518 const auto xLookup{xSymbol.scope()->find(*xComponentName)};
519 const auto yLookup{ySymbol.scope()->find(*yComponentName)};
520 if (xLookup == xSymbol.scope()->end() ||
521 yLookup == ySymbol.scope()->end()) {
522 return false;
523 } else if (!AreSameComponent(*xLookup->second, *yLookup->second,
524 ignoreSequence, sameModuleName, inProgress)) {
525 return false;
526 }
527 }
528 return yComponentName == yEnd;
529}
530
531bool AreSameDerivedType(
532 const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
533 SetOfDerivedTypePairs inProgress;
534 return AreSameDerivedType(x, y, false, false, false, inProgress);
535}
536
537bool AreSameDerivedTypeIgnoringTypeParameters(
538 const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
539 SetOfDerivedTypePairs inProgress;
540 return AreSameDerivedType(x, y, true, true, false, inProgress);
541}
542
543bool AreSameDerivedTypeIgnoringSequence(
544 const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
545 SetOfDerivedTypePairs inProgress;
546 return AreSameDerivedType(x, y, false, false, true, inProgress);
547}
548
549static bool AreSameDerivedType(
550 const semantics::DerivedTypeSpec *x, const semantics::DerivedTypeSpec *y) {
551 return x == y || (x && y && AreSameDerivedType(*x, *y));
552}
553
554bool DynamicType::IsEquivalentTo(const DynamicType &that) const {
555 return category_ == that.category_ && kind_ == that.kind_ &&
556 (charLengthParamValue_ == that.charLengthParamValue_ ||
557 (charLengthParamValue_ && that.charLengthParamValue_ &&
558 charLengthParamValue_->IsEquivalentInInterface(
559 *that.charLengthParamValue_))) &&
560 knownLength().has_value() == that.knownLength().has_value() &&
561 (!knownLength() || *knownLength() == *that.knownLength()) &&
562 AreSameDerivedType(derived_, that.derived_);
563}
564
565static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
566 const semantics::DerivedTypeSpec *y, bool isPolymorphic,
567 bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) {
568 if (!x || !y) {
569 return false;
570 } else {
571 SetOfDerivedTypePairs inProgress;
572 if (AreSameDerivedType(*x, *y, ignoreTypeParameterValues,
573 ignoreLenTypeParameters, false, inProgress)) {
574 return true;
575 } else {
576 return isPolymorphic &&
577 AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true,
578 ignoreTypeParameterValues, ignoreLenTypeParameters);
579 }
580 }
581}
582
583static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
584 bool ignoreTypeParameterValues, bool ignoreLengths) {
585 if (x.IsUnlimitedPolymorphic()) {
586 return true;
587 } else if (y.IsUnlimitedPolymorphic()) {
588 return false;
589 } else if (x.category() != y.category()) {
590 return false;
591 } else if (x.category() == TypeCategory::Character) {
592 const auto xLen{x.knownLength()};
593 const auto yLen{y.knownLength()};
594 return x.kind() == y.kind() &&
595 (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
596 } else if (x.category() == TypeCategory::Derived) {
597 const auto *xdt{GetDerivedTypeSpec(x)};
598 const auto *ydt{GetDerivedTypeSpec(y)};
599 return AreCompatibleDerivedTypes(
600 xdt, ydt, x.IsPolymorphic(), ignoreTypeParameterValues, false);
601 } else if (x.IsTypelessIntrinsicArgument()) {
602 return y.IsTypelessIntrinsicArgument();
603 } else {
604 return !y.IsTypelessIntrinsicArgument() && x.kind() == y.kind();
605 }
606}
607
608// See 7.3.2.3 (5) & 15.5.2.4
609bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
610 return AreCompatibleTypes(*this, that, false, true);
611}
612
613bool DynamicType::IsTkCompatibleWith(
614 const DynamicType &that, common::IgnoreTKRSet ignoreTKR) const {
615 if (ignoreTKR.test(common::IgnoreTKR::Type) &&
616 (category() == TypeCategory::Derived ||
617 that.category() == TypeCategory::Derived ||
618 category() != that.category())) {
619 return true;
620 } else if (ignoreTKR.test(common::IgnoreTKR::Kind) &&
621 category() == that.category()) {
622 return true;
623 } else {
624 return AreCompatibleTypes(*this, that, false, true);
625 }
626}
627
628bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const {
629 return AreCompatibleTypes(*this, that, false, false);
630}
631
632// 16.9.165
633std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
634 bool x{AreCompatibleTypes(*this, that, true, true)};
635 bool y{AreCompatibleTypes(that, *this, true, true)};
636 if (!x && !y) {
637 return false;
638 } else if (x && y && !IsPolymorphic() && !that.IsPolymorphic()) {
639 return true;
640 } else {
641 return std::nullopt;
642 }
643}
644
645// 16.9.76
646std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
647 if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
648 return std::nullopt; // unknown
649 }
650 const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)};
651 const auto *thatDts{evaluate::GetDerivedTypeSpec(that)};
652 if (!thisDts || !thatDts) {
653 return std::nullopt;
654 } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true, true, true)) {
655 // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF()
656 // is .true. when they are the same type. This is technically
657 // an implementation-defined case in the standard, but every other
658 // compiler works this way.
659 if (IsPolymorphic() &&
660 AreCompatibleDerivedTypes(thisDts, thatDts, true, true, true)) {
661 // 'that' is *this or an extension of *this, and so runtime *this
662 // could be an extension of 'that'
663 return std::nullopt;
664 } else {
665 return false;
666 }
667 } else if (that.IsPolymorphic()) {
668 return std::nullopt; // unknown
669 } else {
670 return true;
671 }
672}
673
674std::optional<DynamicType> DynamicType::From(
675 const semantics::DeclTypeSpec &type) {
676 if (const auto *intrinsic{type.AsIntrinsic()}) {
677 if (auto kind{ToInt64(intrinsic->kind())}) {
678 TypeCategory category{intrinsic->category()};
679 if (common::IsValidKindOfIntrinsicType(category, *kind)) {
680 if (category == TypeCategory::Character) {
681 const auto &charType{type.characterTypeSpec()};
682 return DynamicType{static_cast<int>(*kind), charType.length()};
683 } else {
684 return DynamicType{category, static_cast<int>(*kind)};
685 }
686 }
687 }
688 } else if (const auto *derived{type.AsDerived()}) {
689 return DynamicType{
690 *derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
691 } else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
692 return DynamicType::UnlimitedPolymorphic();
693 } else if (type.category() == semantics::DeclTypeSpec::TypeStar) {
694 return DynamicType::AssumedType();
695 } else {
696 common::die("DynamicType::From(DeclTypeSpec): failed");
697 }
698 return std::nullopt;
699}
700
701std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) {
702 return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType
703}
704
705DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
706 switch (category_) {
707 case TypeCategory::Integer:
708 switch (that.category_) {
709 case TypeCategory::Integer:
710 return DynamicType{TypeCategory::Integer, std::max(kind(), that.kind())};
711 case TypeCategory::Real:
712 case TypeCategory::Complex:
713 return that;
714 default:
715 CRASH_NO_CASE;
716 }
717 break;
718 case TypeCategory::Unsigned:
719 switch (that.category_) {
720 case TypeCategory::Unsigned:
721 return DynamicType{TypeCategory::Unsigned, std::max(kind(), that.kind())};
722 default:
723 CRASH_NO_CASE;
724 }
725 break;
726 case TypeCategory::Real:
727 switch (that.category_) {
728 case TypeCategory::Integer:
729 return *this;
730 case TypeCategory::Real:
731 return DynamicType{TypeCategory::Real, std::max(kind(), that.kind())};
732 case TypeCategory::Complex:
733 return DynamicType{TypeCategory::Complex, std::max(kind(), that.kind())};
734 default:
735 CRASH_NO_CASE;
736 }
737 break;
738 case TypeCategory::Complex:
739 switch (that.category_) {
740 case TypeCategory::Integer:
741 return *this;
742 case TypeCategory::Real:
743 case TypeCategory::Complex:
744 return DynamicType{TypeCategory::Complex, std::max(kind(), that.kind())};
745 default:
746 CRASH_NO_CASE;
747 }
748 break;
749 case TypeCategory::Logical:
750 switch (that.category_) {
751 case TypeCategory::Logical:
752 return DynamicType{TypeCategory::Logical, std::max(kind(), that.kind())};
753 default:
754 CRASH_NO_CASE;
755 }
756 break;
757 default:
758 CRASH_NO_CASE;
759 }
760 return *this;
761}
762
763bool DynamicType::RequiresDescriptor() const {
764 return IsPolymorphic() || IsNonConstantLengthCharacter() ||
765 (derived_ && CountNonConstantLenParameters(*derived_) > 0);
766}
767
768bool DynamicType::HasDeferredTypeParameter() const {
769 if (derived_) {
770 for (const auto &pair : derived_->parameters()) {
771 if (pair.second.isDeferred()) {
772 return true;
773 }
774 }
775 }
776 return charLengthParamValue_ && charLengthParamValue_->isDeferred();
777}
778
779bool SomeKind<TypeCategory::Derived>::operator==(
780 const SomeKind<TypeCategory::Derived> &that) const {
781 return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);
782}
783
784int SelectedCharKind(const std::string &s, int defaultKind) { // F'2023 16.9.180
785 auto lower{parser::ToLowerCaseLetters(s)};
786 auto n{lower.size()};
787 while (n > 0 && lower[0] == ' ') {
788 lower.erase(0, 1);
789 --n;
790 }
791 while (n > 0 && lower[n - 1] == ' ') {
792 lower.erase(--n, 1);
793 }
794 if (lower == "ascii") {
795 return 1;
796 } else if (lower == "ucs-2") {
797 return 2;
798 } else if (lower == "iso_10646" || lower == "ucs-4") {
799 return 4;
800 } else if (lower == "default") {
801 return defaultKind;
802 } else {
803 return -1;
804 }
805}
806
807std::optional<DynamicType> ComparisonType(
808 const DynamicType &t1, const DynamicType &t2) {
809 switch (t1.category()) {
810 case TypeCategory::Integer:
811 switch (t2.category()) {
812 case TypeCategory::Integer:
813 return DynamicType{TypeCategory::Integer, std::max(t1.kind(), t2.kind())};
814 case TypeCategory::Real:
815 case TypeCategory::Complex:
816 return t2;
817 default:
818 return std::nullopt;
819 }
820 case TypeCategory::Real:
821 switch (t2.category()) {
822 case TypeCategory::Integer:
823 return t1;
824 case TypeCategory::Real:
825 case TypeCategory::Complex:
826 return DynamicType{t2.category(), std::max(t1.kind(), t2.kind())};
827 default:
828 return std::nullopt;
829 }
830 case TypeCategory::Complex:
831 switch (t2.category()) {
832 case TypeCategory::Integer:
833 return t1;
834 case TypeCategory::Real:
835 case TypeCategory::Complex:
836 return DynamicType{TypeCategory::Complex, std::max(t1.kind(), t2.kind())};
837 default:
838 return std::nullopt;
839 }
840 case TypeCategory::Character:
841 switch (t2.category()) {
842 case TypeCategory::Character:
843 return DynamicType{
844 TypeCategory::Character, std::max(t1.kind(), t2.kind())};
845 default:
846 return std::nullopt;
847 }
848 case TypeCategory::Logical:
849 switch (t2.category()) {
850 case TypeCategory::Logical:
851 return DynamicType{TypeCategory::Logical, LogicalResult::kind};
852 default:
853 return std::nullopt;
854 }
855 default:
856 return std::nullopt;
857 }
858}
859
860std::optional<bool> IsInteroperableIntrinsicType(const DynamicType &type,
861 const common::LanguageFeatureControl *features, bool checkCharLength) {
862 switch (type.category()) {
863 case TypeCategory::Integer:
864 case TypeCategory::Unsigned:
865 return true;
866 case TypeCategory::Real:
867 case TypeCategory::Complex:
868 return type.kind() >= 4 /* not a short or half float */ || !features ||
869 features->IsEnabled(common::LanguageFeature::CUDA);
870 case TypeCategory::Logical:
871 return type.kind() == 1; // C_BOOL
872 case TypeCategory::Character:
873 if (type.kind() != 1) { // C_CHAR
874 return false;
875 } else if (checkCharLength) {
876 if (type.knownLength()) {
877 return *type.knownLength() == 1;
878 } else {
879 return std::nullopt;
880 }
881 } else {
882 return true;
883 }
884 default:
885 // Derived types are tested in Semantics/check-declarations.cpp
886 return false;
887 }
888}
889
890bool IsCUDAIntrinsicType(const DynamicType &type) {
891 switch (type.category()) {
892 case TypeCategory::Integer:
893 case TypeCategory::Logical:
894 return type.kind() <= 8;
895 case TypeCategory::Real:
896 return type.kind() >= 2 && type.kind() <= 8;
897 case TypeCategory::Complex:
898 return type.kind() == 2 || type.kind() == 4 || type.kind() == 8;
899 case TypeCategory::Character:
900 return type.kind() == 1;
901 default:
902 // Derived types are tested in Semantics/check-declarations.cpp
903 return false;
904 }
905}
906
907DynamicType DynamicType::DropNonConstantCharacterLength() const {
908 if (charLengthParamValue_ && charLengthParamValue_->isExplicit()) {
909 if (std::optional<std::int64_t> len{knownLength()}) {
910 return DynamicType(kind_, *len);
911 } else {
912 return DynamicType(category_, kind_);
913 }
914 }
915 return *this;
916}
917
918} // namespace Fortran::evaluate
919

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