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/template.h"
12 #include "flang/Evaluate/expression.h"
13 #include "flang/Evaluate/fold.h"
14 #include "flang/Parser/characters.h"
15 #include "flang/Semantics/scope.h"
16 #include "flang/Semantics/symbol.h"
17 #include "flang/Semantics/tools.h"
18 #include "flang/Semantics/type.h"
19 #include <algorithm>
20 #include <optional>
21 #include <string>
22 
23 // IsDescriptor() predicate: true when a symbol is implemented
24 // at runtime with a descriptor.
25 namespace Fortran::semantics {
26 
27 static bool IsDescriptor(const DeclTypeSpec *type) {
28   if (type) {
29     if (auto dynamicType{evaluate::DynamicType::From(*type)}) {
30       return dynamicType->RequiresDescriptor();
31     }
32   }
33   return false;
34 }
35 
36 static bool IsDescriptor(const ObjectEntityDetails &details) {
37   if (IsDescriptor(details.type())) {
38     return true;
39   }
40   for (const ShapeSpec &shapeSpec : details.shape()) {
41     const auto &lb{shapeSpec.lbound().GetExplicit()};
42     const auto &ub{shapeSpec.ubound().GetExplicit()};
43     if (!lb || !ub || !IsConstantExpr(*lb) || !IsConstantExpr(*ub)) {
44       return true;
45     }
46   }
47   return false;
48 }
49 
50 static bool IsDescriptor(const ProcEntityDetails &details) {
51   // A procedure pointer or dummy procedure must be & is a descriptor if
52   // and only if it requires a static link.
53   // TODO: refine this placeholder
54   return details.HasExplicitInterface();
55 }
56 
57 bool IsDescriptor(const Symbol &symbol) {
58   return common::visit(
59       common::visitors{
60           [&](const ObjectEntityDetails &d) {
61             return IsAllocatableOrPointer(symbol) || IsDescriptor(d);
62           },
63           [&](const ProcEntityDetails &d) {
64             return (symbol.attrs().test(Attr::POINTER) ||
65                        symbol.attrs().test(Attr::EXTERNAL)) &&
66                 IsDescriptor(d);
67           },
68           [&](const EntityDetails &d) { return IsDescriptor(d.type()); },
69           [](const AssocEntityDetails &d) {
70             if (const auto &expr{d.expr()}) {
71               if (expr->Rank() > 0) {
72                 return true;
73               }
74               if (const auto dynamicType{expr->GetType()}) {
75                 if (dynamicType->RequiresDescriptor()) {
76                   return true;
77                 }
78               }
79             }
80             return false;
81           },
82           [](const SubprogramDetails &d) {
83             return d.isFunction() && IsDescriptor(d.result());
84           },
85           [](const UseDetails &d) { return IsDescriptor(d.symbol()); },
86           [](const HostAssocDetails &d) { return IsDescriptor(d.symbol()); },
87           [](const auto &) { return false; },
88       },
89       symbol.details());
90 }
91 } // namespace Fortran::semantics
92 
93 namespace Fortran::evaluate {
94 
95 DynamicType::DynamicType(int k, const semantics::ParamValue &pv)
96     : category_{TypeCategory::Character}, kind_{k} {
97   CHECK(IsValidKindOfIntrinsicType(category_, kind_));
98   if (auto n{ToInt64(pv.GetExplicit())}) {
99     knownLength_ = *n;
100   } else {
101     charLengthParamValue_ = &pv;
102   }
103 }
104 
105 template <typename A> inline bool PointeeComparison(const A *x, const A *y) {
106   return x == y || (x && y && *x == *y);
107 }
108 
109 bool DynamicType::operator==(const DynamicType &that) const {
110   return category_ == that.category_ && kind_ == that.kind_ &&
111       PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) &&
112       knownLength().has_value() == that.knownLength().has_value() &&
113       (!knownLength() || *knownLength() == *that.knownLength()) &&
114       PointeeComparison(derived_, that.derived_);
115 }
116 
117 std::optional<Expr<SubscriptInteger>> DynamicType::GetCharLength() const {
118   if (category_ == TypeCategory::Character) {
119     if (knownLength()) {
120       return AsExpr(Constant<SubscriptInteger>(*knownLength()));
121     } else if (charLengthParamValue_) {
122       if (auto length{charLengthParamValue_->GetExplicit()}) {
123         return ConvertToType<SubscriptInteger>(std::move(*length));
124       }
125     }
126   }
127   return std::nullopt;
128 }
129 
130 static constexpr std::size_t RealKindBytes(int kind) {
131   switch (kind) {
132   case 3: // non-IEEE 16-bit format (truncated 32-bit)
133     return 2;
134   case 10: // 80387 80-bit extended precision
135   case 12: // possible variant spelling
136     return 16;
137   default:
138     return kind;
139   }
140 }
141 
142 std::size_t DynamicType::GetAlignment(const FoldingContext &context) const {
143   switch (category_) {
144   case TypeCategory::Integer:
145   case TypeCategory::Character:
146   case TypeCategory::Logical:
147     return std::min<std::size_t>(kind_, context.maxAlignment());
148   case TypeCategory::Real:
149   case TypeCategory::Complex:
150     return std::min(RealKindBytes(kind_), context.maxAlignment());
151   case TypeCategory::Derived:
152     if (derived_ && derived_->scope()) {
153       return derived_->scope()->alignment().value_or(1);
154     }
155     break;
156   }
157   return 1; // needs to be after switch to dodge a bogus gcc warning
158 }
159 
160 std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
161     FoldingContext &context, bool aligned) const {
162   switch (category_) {
163   case TypeCategory::Integer:
164     return Expr<SubscriptInteger>{kind_};
165   case TypeCategory::Real:
166     return Expr<SubscriptInteger>{RealKindBytes(kind_)};
167   case TypeCategory::Complex:
168     return Expr<SubscriptInteger>{2 * RealKindBytes(kind_)};
169   case TypeCategory::Character:
170     if (auto len{GetCharLength()}) {
171       return Fold(context, Expr<SubscriptInteger>{kind_} * std::move(*len));
172     }
173     break;
174   case TypeCategory::Logical:
175     return Expr<SubscriptInteger>{kind_};
176   case TypeCategory::Derived:
177     if (derived_ && derived_->scope()) {
178       auto size{derived_->scope()->size()};
179       auto align{aligned ? derived_->scope()->alignment().value_or(0) : 0};
180       auto alignedSize{align > 0 ? ((size + align - 1) / align) * align : size};
181       return Expr<SubscriptInteger>{
182           static_cast<ConstantSubscript>(alignedSize)};
183     }
184     break;
185   }
186   return std::nullopt;
187 }
188 
189 bool DynamicType::IsAssumedLengthCharacter() const {
190   return category_ == TypeCategory::Character && charLengthParamValue_ &&
191       charLengthParamValue_->isAssumed();
192 }
193 
194 bool DynamicType::IsNonConstantLengthCharacter() const {
195   if (category_ != TypeCategory::Character) {
196     return false;
197   } else if (knownLength()) {
198     return false;
199   } else if (!charLengthParamValue_) {
200     return true;
201   } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) {
202     return !IsConstantExpr(*expr);
203   } else {
204     return true;
205   }
206 }
207 
208 bool DynamicType::IsTypelessIntrinsicArgument() const {
209   return category_ == TypeCategory::Integer && kind_ == TypelessKind;
210 }
211 
212 const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
213     const std::optional<DynamicType> &type) {
214   return type ? GetDerivedTypeSpec(*type) : nullptr;
215 }
216 
217 const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
218   if (type.category() == TypeCategory::Derived &&
219       !type.IsUnlimitedPolymorphic()) {
220     return &type.GetDerivedTypeSpec();
221   } else {
222     return nullptr;
223   }
224 }
225 
226 static const semantics::Symbol *FindParentComponent(
227     const semantics::DerivedTypeSpec &derived) {
228   const semantics::Symbol &typeSymbol{derived.typeSymbol()};
229   if (const semantics::Scope * scope{typeSymbol.scope()}) {
230     const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
231     if (auto extends{dtDetails.GetParentComponentName()}) {
232       if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
233         if (const Symbol & symbol{*iter->second};
234             symbol.test(Symbol::Flag::ParentComp)) {
235           return &symbol;
236         }
237       }
238     }
239   }
240   return nullptr;
241 }
242 
243 const semantics::DerivedTypeSpec *GetParentTypeSpec(
244     const semantics::DerivedTypeSpec &derived) {
245   if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
246     return &parent->get<semantics::ObjectEntityDetails>()
247                 .type()
248                 ->derivedTypeSpec();
249   } else {
250     return nullptr;
251   }
252 }
253 
254 // Compares two derived type representations to see whether they both
255 // represent the "same type" in the sense of section 7.5.2.4.
256 using SetOfDerivedTypePairs =
257     std::set<std::pair<const semantics::DerivedTypeSpec *,
258         const semantics::DerivedTypeSpec *>>;
259 
260 static bool AreSameComponent(const semantics::Symbol &,
261     const semantics::Symbol &, SetOfDerivedTypePairs &inProgress);
262 
263 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
264     const semantics::DerivedTypeSpec &y, SetOfDerivedTypePairs &inProgress) {
265   const auto &xSymbol{x.typeSymbol()};
266   const auto &ySymbol{y.typeSymbol()};
267   if (&x == &y || xSymbol == ySymbol) {
268     return true;
269   }
270   auto thisQuery{std::make_pair(&x, &y)};
271   if (inProgress.find(thisQuery) != inProgress.end()) {
272     return true; // recursive use of types in components
273   }
274   inProgress.insert(thisQuery);
275   const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
276   const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
277   if (xSymbol.name() != ySymbol.name()) {
278     return false;
279   }
280   if (!(xDetails.sequence() && yDetails.sequence()) &&
281       !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
282           ySymbol.attrs().test(semantics::Attr::BIND_C))) {
283     // PGI does not enforce this requirement; all other Fortran
284     // processors do with a hard error when violations are caught.
285     return false;
286   }
287   // Compare the component lists in their orders of declaration.
288   auto xEnd{xDetails.componentNames().cend()};
289   auto yComponentName{yDetails.componentNames().cbegin()};
290   auto yEnd{yDetails.componentNames().cend()};
291   for (auto xComponentName{xDetails.componentNames().cbegin()};
292        xComponentName != xEnd; ++xComponentName, ++yComponentName) {
293     if (yComponentName == yEnd || *xComponentName != *yComponentName ||
294         !xSymbol.scope() || !ySymbol.scope()) {
295       return false;
296     }
297     const auto xLookup{xSymbol.scope()->find(*xComponentName)};
298     const auto yLookup{ySymbol.scope()->find(*yComponentName)};
299     if (xLookup == xSymbol.scope()->end() ||
300         yLookup == ySymbol.scope()->end() ||
301         !AreSameComponent(*xLookup->second, *yLookup->second, inProgress)) {
302       return false;
303     }
304   }
305   return yComponentName == yEnd;
306 }
307 
308 static bool AreSameComponent(const semantics::Symbol &x,
309     const semantics::Symbol &y,
310     SetOfDerivedTypePairs & /* inProgress - not yet used */) {
311   if (x.attrs() != y.attrs()) {
312     return false;
313   }
314   if (x.attrs().test(semantics::Attr::PRIVATE)) {
315     return false;
316   }
317   // TODO: compare types, parameters, bounds, &c.
318   return x.has<semantics::ObjectEntityDetails>() ==
319       y.has<semantics::ObjectEntityDetails>();
320 }
321 
322 static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
323     const semantics::DerivedTypeSpec *y, bool isPolymorphic) {
324   if (!x || !y) {
325     return false;
326   } else {
327     SetOfDerivedTypePairs inProgress;
328     if (AreSameDerivedType(*x, *y, inProgress)) {
329       return true;
330     } else {
331       return isPolymorphic &&
332           AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true);
333     }
334   }
335 }
336 
337 static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
338     bool ignoreTypeParameterValues) {
339   if (x.IsUnlimitedPolymorphic()) {
340     return true;
341   } else if (y.IsUnlimitedPolymorphic()) {
342     return false;
343   } else if (x.category() != y.category()) {
344     return false;
345   } else if (x.category() != TypeCategory::Derived) {
346     return x.kind() == y.kind();
347   } else {
348     const auto *xdt{GetDerivedTypeSpec(x)};
349     const auto *ydt{GetDerivedTypeSpec(y)};
350     return AreCompatibleDerivedTypes(xdt, ydt, x.IsPolymorphic()) &&
351         (ignoreTypeParameterValues ||
352             (xdt && ydt && AreTypeParamCompatible(*xdt, *ydt)));
353   }
354 }
355 
356 // See 7.3.2.3 (5) & 15.5.2.4
357 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
358   return AreCompatibleTypes(*this, that, false);
359 }
360 
361 // 16.9.165
362 std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
363   bool x{AreCompatibleTypes(*this, that, true)};
364   bool y{AreCompatibleTypes(that, *this, true)};
365   if (x == y) {
366     return x;
367   } else {
368     // If either is unlimited polymorphic, the result is unknown.
369     return std::nullopt;
370   }
371 }
372 
373 // 16.9.76
374 std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
375   if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
376     return std::nullopt; // unknown
377   } else if (!AreCompatibleDerivedTypes(evaluate::GetDerivedTypeSpec(that),
378                  evaluate::GetDerivedTypeSpec(*this), true)) {
379     return false;
380   } else if (that.IsPolymorphic()) {
381     return std::nullopt; // unknown
382   } else {
383     return true;
384   }
385 }
386 
387 std::optional<DynamicType> DynamicType::From(
388     const semantics::DeclTypeSpec &type) {
389   if (const auto *intrinsic{type.AsIntrinsic()}) {
390     if (auto kind{ToInt64(intrinsic->kind())}) {
391       TypeCategory category{intrinsic->category()};
392       if (IsValidKindOfIntrinsicType(category, *kind)) {
393         if (category == TypeCategory::Character) {
394           const auto &charType{type.characterTypeSpec()};
395           return DynamicType{static_cast<int>(*kind), charType.length()};
396         } else {
397           return DynamicType{category, static_cast<int>(*kind)};
398         }
399       }
400     }
401   } else if (const auto *derived{type.AsDerived()}) {
402     return DynamicType{
403         *derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
404   } else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
405     return DynamicType::UnlimitedPolymorphic();
406   } else if (type.category() == semantics::DeclTypeSpec::TypeStar) {
407     return DynamicType::AssumedType();
408   } else {
409     common::die("DynamicType::From(DeclTypeSpec): failed");
410   }
411   return std::nullopt;
412 }
413 
414 std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) {
415   return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType
416 }
417 
418 DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
419   switch (category_) {
420   case TypeCategory::Integer:
421     switch (that.category_) {
422     case TypeCategory::Integer:
423       return DynamicType{TypeCategory::Integer, std::max(kind_, that.kind_)};
424     case TypeCategory::Real:
425     case TypeCategory::Complex:
426       return that;
427     default:
428       CRASH_NO_CASE;
429     }
430     break;
431   case TypeCategory::Real:
432     switch (that.category_) {
433     case TypeCategory::Integer:
434       return *this;
435     case TypeCategory::Real:
436       return DynamicType{TypeCategory::Real, std::max(kind_, that.kind_)};
437     case TypeCategory::Complex:
438       return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)};
439     default:
440       CRASH_NO_CASE;
441     }
442     break;
443   case TypeCategory::Complex:
444     switch (that.category_) {
445     case TypeCategory::Integer:
446       return *this;
447     case TypeCategory::Real:
448     case TypeCategory::Complex:
449       return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)};
450     default:
451       CRASH_NO_CASE;
452     }
453     break;
454   case TypeCategory::Logical:
455     switch (that.category_) {
456     case TypeCategory::Logical:
457       return DynamicType{TypeCategory::Logical, std::max(kind_, that.kind_)};
458     default:
459       CRASH_NO_CASE;
460     }
461     break;
462   default:
463     CRASH_NO_CASE;
464   }
465   return *this;
466 }
467 
468 bool DynamicType::RequiresDescriptor() const {
469   return IsPolymorphic() || IsNonConstantLengthCharacter() ||
470       (derived_ && CountNonConstantLenParameters(*derived_) > 0);
471 }
472 
473 bool DynamicType::HasDeferredTypeParameter() const {
474   if (derived_) {
475     for (const auto &pair : derived_->parameters()) {
476       if (pair.second.isDeferred()) {
477         return true;
478       }
479     }
480   }
481   return charLengthParamValue_ && charLengthParamValue_->isDeferred();
482 }
483 
484 bool SomeKind<TypeCategory::Derived>::operator==(
485     const SomeKind<TypeCategory::Derived> &that) const {
486   return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);
487 }
488 
489 int SelectedCharKind(const std::string &s, int defaultKind) { // 16.9.168
490   auto lower{parser::ToLowerCaseLetters(s)};
491   auto n{lower.size()};
492   while (n > 0 && lower[0] == ' ') {
493     lower.erase(0, 1);
494     --n;
495   }
496   while (n > 0 && lower[n - 1] == ' ') {
497     lower.erase(--n, 1);
498   }
499   if (lower == "ascii") {
500     return 1;
501   } else if (lower == "ucs-2") {
502     return 2;
503   } else if (lower == "iso_10646" || lower == "ucs-4") {
504     return 4;
505   } else if (lower == "default") {
506     return defaultKind;
507   } else {
508     return -1;
509   }
510 }
511 
512 class SelectedIntKindVisitor {
513 public:
514   explicit SelectedIntKindVisitor(std::int64_t p) : precision_{p} {}
515   using Result = std::optional<int>;
516   using Types = IntegerTypes;
517   template <typename T> Result Test() const {
518     if (Scalar<T>::RANGE >= precision_) {
519       return T::kind;
520     } else {
521       return std::nullopt;
522     }
523   }
524 
525 private:
526   std::int64_t precision_;
527 };
528 
529 int SelectedIntKind(std::int64_t precision) {
530   if (auto kind{common::SearchTypes(SelectedIntKindVisitor{precision})}) {
531     return *kind;
532   } else {
533     return -1;
534   }
535 }
536 
537 class SelectedRealKindVisitor {
538 public:
539   explicit SelectedRealKindVisitor(std::int64_t p, std::int64_t r)
540       : precision_{p}, range_{r} {}
541   using Result = std::optional<int>;
542   using Types = RealTypes;
543   template <typename T> Result Test() const {
544     if (Scalar<T>::PRECISION >= precision_ && Scalar<T>::RANGE >= range_) {
545       return {T::kind};
546     } else {
547       return std::nullopt;
548     }
549   }
550 
551 private:
552   std::int64_t precision_, range_;
553 };
554 
555 int SelectedRealKind(
556     std::int64_t precision, std::int64_t range, std::int64_t radix) {
557   if (radix != 2) {
558     return -5;
559   }
560   if (auto kind{
561           common::SearchTypes(SelectedRealKindVisitor{precision, range})}) {
562     return *kind;
563   }
564   // No kind has both sufficient precision and sufficient range.
565   // The negative return value encodes whether any kinds exist that
566   // could satisfy either constraint independently.
567   bool pOK{common::SearchTypes(SelectedRealKindVisitor{precision, 0})};
568   bool rOK{common::SearchTypes(SelectedRealKindVisitor{0, range})};
569   if (pOK) {
570     if (rOK) {
571       return -4;
572     } else {
573       return -2;
574     }
575   } else {
576     if (rOK) {
577       return -1;
578     } else {
579       return -3;
580     }
581   }
582 }
583 
584 std::optional<DynamicType> ComparisonType(
585     const DynamicType &t1, const DynamicType &t2) {
586   switch (t1.category()) {
587   case TypeCategory::Integer:
588     switch (t2.category()) {
589     case TypeCategory::Integer:
590       return DynamicType{TypeCategory::Integer, std::max(t1.kind(), t2.kind())};
591     case TypeCategory::Real:
592     case TypeCategory::Complex:
593       return t2;
594     default:
595       return std::nullopt;
596     }
597   case TypeCategory::Real:
598     switch (t2.category()) {
599     case TypeCategory::Integer:
600       return t1;
601     case TypeCategory::Real:
602     case TypeCategory::Complex:
603       return DynamicType{t2.category(), std::max(t1.kind(), t2.kind())};
604     default:
605       return std::nullopt;
606     }
607   case TypeCategory::Complex:
608     switch (t2.category()) {
609     case TypeCategory::Integer:
610       return t1;
611     case TypeCategory::Real:
612     case TypeCategory::Complex:
613       return DynamicType{TypeCategory::Complex, std::max(t1.kind(), t2.kind())};
614     default:
615       return std::nullopt;
616     }
617   case TypeCategory::Character:
618     switch (t2.category()) {
619     case TypeCategory::Character:
620       return DynamicType{
621           TypeCategory::Character, std::max(t1.kind(), t2.kind())};
622     default:
623       return std::nullopt;
624     }
625   case TypeCategory::Logical:
626     switch (t2.category()) {
627     case TypeCategory::Logical:
628       return DynamicType{TypeCategory::Logical, LogicalResult::kind};
629     default:
630       return std::nullopt;
631     }
632   default:
633     return std::nullopt;
634   }
635 }
636 
637 } // namespace Fortran::evaluate
638