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