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