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