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