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