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