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