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