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