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