1 //===-- lib/Evaluate/variable.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/variable.h"
10 #include "flang/Common/idioms.h"
11 #include "flang/Evaluate/fold.h"
12 #include "flang/Evaluate/tools.h"
13 #include "flang/Parser/char-block.h"
14 #include "flang/Parser/characters.h"
15 #include "flang/Parser/message.h"
16 #include "flang/Semantics/symbol.h"
17 #include <type_traits>
18 
19 using namespace Fortran::parser::literals;
20 
21 namespace Fortran::evaluate {
22 
23 // Constructors, accessors, mutators
24 
25 Triplet::Triplet() : stride_{Expr<SubscriptInteger>{1}} {}
26 
27 Triplet::Triplet(std::optional<Expr<SubscriptInteger>> &&l,
28     std::optional<Expr<SubscriptInteger>> &&u,
29     std::optional<Expr<SubscriptInteger>> &&s)
30     : stride_{s ? std::move(*s) : Expr<SubscriptInteger>{1}} {
31   if (l) {
32     lower_.emplace(std::move(*l));
33   }
34   if (u) {
35     upper_.emplace(std::move(*u));
36   }
37 }
38 
39 std::optional<Expr<SubscriptInteger>> Triplet::lower() const {
40   if (lower_) {
41     return {lower_.value().value()};
42   }
43   return std::nullopt;
44 }
45 
46 Triplet &Triplet::set_lower(Expr<SubscriptInteger> &&expr) {
47   lower_.emplace(std::move(expr));
48   return *this;
49 }
50 
51 std::optional<Expr<SubscriptInteger>> Triplet::upper() const {
52   if (upper_) {
53     return {upper_.value().value()};
54   }
55   return std::nullopt;
56 }
57 
58 Triplet &Triplet::set_upper(Expr<SubscriptInteger> &&expr) {
59   upper_.emplace(std::move(expr));
60   return *this;
61 }
62 
63 Expr<SubscriptInteger> Triplet::stride() const { return stride_.value(); }
64 
65 Triplet &Triplet::set_stride(Expr<SubscriptInteger> &&expr) {
66   stride_.value() = std::move(expr);
67   return *this;
68 }
69 
70 bool Triplet::IsStrideOne() const {
71   if (auto stride{ToInt64(stride_.value())}) {
72     return stride == 1;
73   } else {
74     return false;
75   }
76 }
77 
78 CoarrayRef::CoarrayRef(SymbolVector &&base, std::vector<Subscript> &&ss,
79     std::vector<Expr<SubscriptInteger>> &&css)
80     : base_{std::move(base)}, subscript_(std::move(ss)),
81       cosubscript_(std::move(css)) {
82   CHECK(!base_.empty());
83   CHECK(!cosubscript_.empty());
84 }
85 
86 std::optional<Expr<SomeInteger>> CoarrayRef::stat() const {
87   if (stat_) {
88     return stat_.value().value();
89   } else {
90     return std::nullopt;
91   }
92 }
93 
94 std::optional<Expr<SomeInteger>> CoarrayRef::team() const {
95   if (team_) {
96     return team_.value().value();
97   } else {
98     return std::nullopt;
99   }
100 }
101 
102 CoarrayRef &CoarrayRef::set_stat(Expr<SomeInteger> &&v) {
103   CHECK(IsVariable(v));
104   stat_.emplace(std::move(v));
105   return *this;
106 }
107 
108 CoarrayRef &CoarrayRef::set_team(Expr<SomeInteger> &&v, bool isTeamNumber) {
109   CHECK(IsVariable(v));
110   team_.emplace(std::move(v));
111   teamIsTeamNumber_ = isTeamNumber;
112   return *this;
113 }
114 
115 const Symbol &CoarrayRef::GetFirstSymbol() const { return base_.front(); }
116 
117 const Symbol &CoarrayRef::GetLastSymbol() const { return base_.back(); }
118 
119 void Substring::SetBounds(std::optional<Expr<SubscriptInteger>> &lower,
120     std::optional<Expr<SubscriptInteger>> &upper) {
121   if (lower) {
122     set_lower(std::move(lower.value()));
123   }
124   if (upper) {
125     set_upper(std::move(upper.value()));
126   }
127 }
128 
129 Expr<SubscriptInteger> Substring::lower() const {
130   if (lower_) {
131     return lower_.value().value();
132   } else {
133     return AsExpr(Constant<SubscriptInteger>{1});
134   }
135 }
136 
137 Substring &Substring::set_lower(Expr<SubscriptInteger> &&expr) {
138   lower_.emplace(std::move(expr));
139   return *this;
140 }
141 
142 std::optional<Expr<SubscriptInteger>> Substring::upper() const {
143   if (upper_) {
144     return upper_.value().value();
145   } else {
146     return std::visit(
147         common::visitors{
148             [](const DataRef &dataRef) { return dataRef.LEN(); },
149             [](const StaticDataObject::Pointer &object)
150                 -> std::optional<Expr<SubscriptInteger>> {
151               return AsExpr(Constant<SubscriptInteger>{object->data().size()});
152             },
153         },
154         parent_);
155   }
156 }
157 
158 Substring &Substring::set_upper(Expr<SubscriptInteger> &&expr) {
159   upper_.emplace(std::move(expr));
160   return *this;
161 }
162 
163 std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
164   if (!lower_) {
165     lower_ = AsExpr(Constant<SubscriptInteger>{1});
166   }
167   lower_.value() = evaluate::Fold(context, std::move(lower_.value().value()));
168   std::optional<ConstantSubscript> lbi{ToInt64(lower_.value().value())};
169   if (lbi && *lbi < 1) {
170     context.messages().Say(
171         "Lower bound (%jd) on substring is less than one"_en_US, *lbi);
172     *lbi = 1;
173     lower_ = AsExpr(Constant<SubscriptInteger>{1});
174   }
175   if (!upper_) {
176     upper_ = upper();
177     if (!upper_) {
178       return std::nullopt;
179     }
180   }
181   upper_.value() = evaluate::Fold(context, std::move(upper_.value().value()));
182   if (std::optional<ConstantSubscript> ubi{ToInt64(upper_.value().value())}) {
183     auto *literal{std::get_if<StaticDataObject::Pointer>(&parent_)};
184     std::optional<ConstantSubscript> length;
185     if (literal) {
186       length = (*literal)->data().size();
187     } else if (const Symbol * symbol{GetLastSymbol()}) {
188       if (const semantics::DeclTypeSpec * type{symbol->GetType()}) {
189         if (type->category() == semantics::DeclTypeSpec::Character) {
190           length = ToInt64(type->characterTypeSpec().length().GetExplicit());
191         }
192       }
193     }
194     if (*ubi < 1 || (lbi && *ubi < *lbi)) {
195       // Zero-length string: canonicalize
196       *lbi = 1, *ubi = 0;
197       lower_ = AsExpr(Constant<SubscriptInteger>{*lbi});
198       upper_ = AsExpr(Constant<SubscriptInteger>{*ubi});
199     } else if (length && *ubi > *length) {
200       context.messages().Say("Upper bound (%jd) on substring is greater "
201                              "than character length (%jd)"_en_US,
202           *ubi, *length);
203       *ubi = *length;
204     }
205     if (lbi && literal) {
206       CHECK(*ubi >= *lbi);
207       auto newStaticData{StaticDataObject::Create()};
208       auto items{*ubi - *lbi + 1};
209       auto width{(*literal)->itemBytes()};
210       auto bytes{items * width};
211       auto startByte{(*lbi - 1) * width};
212       const auto *from{&(*literal)->data()[0] + startByte};
213       for (auto j{0}; j < bytes; ++j) {
214         newStaticData->data().push_back(from[j]);
215       }
216       parent_ = newStaticData;
217       lower_ = AsExpr(Constant<SubscriptInteger>{1});
218       ConstantSubscript length = newStaticData->data().size();
219       upper_ = AsExpr(Constant<SubscriptInteger>{length});
220       switch (width) {
221       case 1:
222         return {
223             AsCategoryExpr(AsExpr(Constant<Type<TypeCategory::Character, 1>>{
224                 *newStaticData->AsString()}))};
225       case 2:
226         return {AsCategoryExpr(Constant<Type<TypeCategory::Character, 2>>{
227             *newStaticData->AsU16String()})};
228       case 4:
229         return {AsCategoryExpr(Constant<Type<TypeCategory::Character, 4>>{
230             *newStaticData->AsU32String()})};
231       default:
232         CRASH_NO_CASE;
233       }
234     }
235   }
236   return std::nullopt;
237 }
238 
239 DescriptorInquiry::DescriptorInquiry(
240     const NamedEntity &base, Field field, int dim)
241     : base_{base}, field_{field}, dimension_{dim} {
242   const Symbol &last{base_.GetLastSymbol()};
243   CHECK(IsDescriptor(last));
244   CHECK((field == Field::Len && dim == 0) ||
245       (field != Field::Len && dim >= 0 && dim < last.Rank()));
246 }
247 
248 DescriptorInquiry::DescriptorInquiry(NamedEntity &&base, Field field, int dim)
249     : base_{std::move(base)}, field_{field}, dimension_{dim} {
250   const Symbol &last{base_.GetLastSymbol()};
251   CHECK(IsDescriptor(last));
252   CHECK((field == Field::Len && dim == 0) ||
253       (field != Field::Len && dim >= 0 && dim < last.Rank()));
254 }
255 
256 // LEN()
257 static std::optional<Expr<SubscriptInteger>> SymbolLEN(const Symbol &sym) {
258   if (auto dyType{DynamicType::From(sym)}) {
259     if (const semantics::ParamValue * len{dyType->charLength()}) {
260       if (auto intExpr{len->GetExplicit()}) {
261         return ConvertToType<SubscriptInteger>(*std::move(intExpr));
262       } else {
263         return Expr<SubscriptInteger>{
264             DescriptorInquiry{NamedEntity{sym}, DescriptorInquiry::Field::Len}};
265       }
266     }
267   }
268   return std::nullopt;
269 }
270 
271 std::optional<Expr<SubscriptInteger>> BaseObject::LEN() const {
272   return std::visit(
273       common::visitors{
274           [](const Symbol &symbol) { return SymbolLEN(symbol); },
275           [](const StaticDataObject::Pointer &object)
276               -> std::optional<Expr<SubscriptInteger>> {
277             return AsExpr(Constant<SubscriptInteger>{object->data().size()});
278           },
279       },
280       u);
281 }
282 
283 std::optional<Expr<SubscriptInteger>> Component::LEN() const {
284   return SymbolLEN(GetLastSymbol());
285 }
286 
287 std::optional<Expr<SubscriptInteger>> NamedEntity::LEN() const {
288   return SymbolLEN(GetLastSymbol());
289 }
290 
291 std::optional<Expr<SubscriptInteger>> ArrayRef::LEN() const {
292   return base_.LEN();
293 }
294 
295 std::optional<Expr<SubscriptInteger>> CoarrayRef::LEN() const {
296   return SymbolLEN(GetLastSymbol());
297 }
298 
299 std::optional<Expr<SubscriptInteger>> DataRef::LEN() const {
300   return std::visit(common::visitors{
301                         [](SymbolRef symbol) { return SymbolLEN(symbol); },
302                         [](const auto &x) { return x.LEN(); },
303                     },
304       u);
305 }
306 
307 std::optional<Expr<SubscriptInteger>> Substring::LEN() const {
308   if (auto top{upper()}) {
309     return AsExpr(Extremum<SubscriptInteger>{Ordering::Greater,
310         AsExpr(Constant<SubscriptInteger>{0}),
311         *std::move(top) - lower() + AsExpr(Constant<SubscriptInteger>{1})});
312   } else {
313     return std::nullopt;
314   }
315 }
316 
317 template <typename T>
318 std::optional<Expr<SubscriptInteger>> Designator<T>::LEN() const {
319   if constexpr (T::category == TypeCategory::Character) {
320     return std::visit(common::visitors{
321                           [](SymbolRef symbol) { return SymbolLEN(symbol); },
322                           [](const auto &x) { return x.LEN(); },
323                       },
324         u);
325   } else {
326     common::die("Designator<non-char>::LEN() called");
327     return std::nullopt;
328   }
329 }
330 
331 std::optional<Expr<SubscriptInteger>> ProcedureDesignator::LEN() const {
332   using T = std::optional<Expr<SubscriptInteger>>;
333   return std::visit(
334       common::visitors{
335           [](SymbolRef symbol) -> T { return SymbolLEN(symbol); },
336           [](const common::CopyableIndirection<Component> &c) -> T {
337             return c.value().LEN();
338           },
339           [](const SpecificIntrinsic &i) -> T {
340             if (i.name == "char") {
341               return Expr<SubscriptInteger>{1};
342             }
343             // Some other cases whose results' lengths can be determined
344             // from the lengths of their arguments are handled in
345             // ProcedureRef::LEN().
346             return std::nullopt;
347           },
348       },
349       u);
350 }
351 
352 // Rank()
353 int BaseObject::Rank() const {
354   return std::visit(common::visitors{
355                         [](SymbolRef symbol) { return symbol->Rank(); },
356                         [](const StaticDataObject::Pointer &) { return 0; },
357                     },
358       u);
359 }
360 
361 int Component::Rank() const {
362   if (int rank{symbol_->Rank()}; rank > 0) {
363     return rank;
364   }
365   return base().Rank();
366 }
367 
368 int NamedEntity::Rank() const {
369   return std::visit(common::visitors{
370                         [](const SymbolRef s) { return s->Rank(); },
371                         [](const Component &c) { return c.Rank(); },
372                     },
373       u_);
374 }
375 
376 int Subscript::Rank() const {
377   return std::visit(common::visitors{
378                         [](const IndirectSubscriptIntegerExpr &x) {
379                           return x.value().Rank();
380                         },
381                         [](const Triplet &) { return 1; },
382                     },
383       u);
384 }
385 
386 int ArrayRef::Rank() const {
387   int rank{0};
388   for (const auto &expr : subscript_) {
389     rank += expr.Rank();
390   }
391   if (rank > 0) {
392     return rank;
393   } else if (const Component * component{base_.UnwrapComponent()}) {
394     return component->base().Rank();
395   } else {
396     return 0;
397   }
398 }
399 
400 int CoarrayRef::Rank() const {
401   if (!subscript_.empty()) {
402     int rank{0};
403     for (const auto &expr : subscript_) {
404       rank += expr.Rank();
405     }
406     return rank;
407   } else {
408     return base_.back()->Rank();
409   }
410 }
411 
412 int DataRef::Rank() const {
413   return std::visit(common::visitors{
414                         [](SymbolRef symbol) { return symbol->Rank(); },
415                         [](const auto &x) { return x.Rank(); },
416                     },
417       u);
418 }
419 
420 int Substring::Rank() const {
421   return std::visit(common::visitors{
422                         [](const DataRef &dataRef) { return dataRef.Rank(); },
423                         [](const StaticDataObject::Pointer &) { return 0; },
424                     },
425       parent_);
426 }
427 
428 int ComplexPart::Rank() const { return complex_.Rank(); }
429 
430 template <typename T> int Designator<T>::Rank() const {
431   return std::visit(common::visitors{
432                         [](SymbolRef symbol) { return symbol->Rank(); },
433                         [](const auto &x) { return x.Rank(); },
434                     },
435       u);
436 }
437 
438 // GetBaseObject(), GetFirstSymbol(), GetLastSymbol(), &c.
439 const Symbol &Component::GetFirstSymbol() const {
440   return base_.value().GetFirstSymbol();
441 }
442 
443 const Symbol &NamedEntity::GetFirstSymbol() const {
444   return std::visit(common::visitors{
445                         [](SymbolRef s) -> const Symbol & { return s; },
446                         [](const Component &c) -> const Symbol & {
447                           return c.GetFirstSymbol();
448                         },
449                     },
450       u_);
451 }
452 
453 const Symbol &NamedEntity::GetLastSymbol() const {
454   return std::visit(common::visitors{
455                         [](SymbolRef s) -> const Symbol & { return s; },
456                         [](const Component &c) -> const Symbol & {
457                           return c.GetLastSymbol();
458                         },
459                     },
460       u_);
461 }
462 
463 const Component *NamedEntity::UnwrapComponent() const {
464   return std::visit(common::visitors{
465                         [](SymbolRef) -> const Component * { return nullptr; },
466                         [](const Component &c) { return &c; },
467                     },
468       u_);
469 }
470 
471 Component *NamedEntity::UnwrapComponent() {
472   return std::visit(common::visitors{
473                         [](SymbolRef &) -> Component * { return nullptr; },
474                         [](Component &c) { return &c; },
475                     },
476       u_);
477 }
478 
479 const Symbol &ArrayRef::GetFirstSymbol() const {
480   return base_.GetFirstSymbol();
481 }
482 
483 const Symbol &ArrayRef::GetLastSymbol() const { return base_.GetLastSymbol(); }
484 
485 const Symbol &DataRef::GetFirstSymbol() const {
486   return *std::visit(common::visitors{
487                          [](SymbolRef symbol) { return &*symbol; },
488                          [](const auto &x) { return &x.GetFirstSymbol(); },
489                      },
490       u);
491 }
492 
493 const Symbol &DataRef::GetLastSymbol() const {
494   return *std::visit(common::visitors{
495                          [](SymbolRef symbol) { return &*symbol; },
496                          [](const auto &x) { return &x.GetLastSymbol(); },
497                      },
498       u);
499 }
500 
501 BaseObject Substring::GetBaseObject() const {
502   return std::visit(common::visitors{
503                         [](const DataRef &dataRef) {
504                           return BaseObject{dataRef.GetFirstSymbol()};
505                         },
506                         [](StaticDataObject::Pointer pointer) {
507                           return BaseObject{std::move(pointer)};
508                         },
509                     },
510       parent_);
511 }
512 
513 const Symbol *Substring::GetLastSymbol() const {
514   return std::visit(
515       common::visitors{
516           [](const DataRef &dataRef) { return &dataRef.GetLastSymbol(); },
517           [](const auto &) -> const Symbol * { return nullptr; },
518       },
519       parent_);
520 }
521 
522 template <typename T> BaseObject Designator<T>::GetBaseObject() const {
523   return std::visit(
524       common::visitors{
525           [](SymbolRef symbol) { return BaseObject{symbol}; },
526           [](const Substring &sstring) { return sstring.GetBaseObject(); },
527           [](const auto &x) {
528 #if !__clang__ && __GNUC__ == 7 && __GNUC_MINOR__ == 2
529             if constexpr (std::is_same_v<std::decay_t<decltype(x)>,
530                               Substring>) {
531               return x.GetBaseObject();
532             } else
533 #endif
534               return BaseObject{x.GetFirstSymbol()};
535           },
536       },
537       u);
538 }
539 
540 template <typename T> const Symbol *Designator<T>::GetLastSymbol() const {
541   return std::visit(
542       common::visitors{
543           [](SymbolRef symbol) { return &*symbol; },
544           [](const Substring &sstring) { return sstring.GetLastSymbol(); },
545           [](const auto &x) {
546 #if !__clang__ && __GNUC__ == 7 && __GNUC_MINOR__ == 2
547             if constexpr (std::is_same_v<std::decay_t<decltype(x)>,
548                               Substring>) {
549               return x.GetLastSymbol();
550             } else
551 #endif
552               return &x.GetLastSymbol();
553           },
554       },
555       u);
556 }
557 
558 template <typename T>
559 std::optional<DynamicType> Designator<T>::GetType() const {
560   if constexpr (IsLengthlessIntrinsicType<Result>) {
561     return {Result::GetType()};
562   } else {
563     return DynamicType::From(GetLastSymbol());
564   }
565 }
566 
567 static NamedEntity AsNamedEntity(const SymbolVector &x) {
568   CHECK(!x.empty());
569   NamedEntity result{x.front()};
570   int j{0};
571   for (const Symbol &symbol : x) {
572     if (j++ != 0) {
573       DataRef base{result.IsSymbol() ? DataRef{result.GetLastSymbol()}
574                                      : DataRef{result.GetComponent()}};
575       result = NamedEntity{Component{std::move(base), symbol}};
576     }
577   }
578   return result;
579 }
580 
581 NamedEntity CoarrayRef::GetBase() const { return AsNamedEntity(base_); }
582 
583 // Equality testing
584 
585 // For the purposes of comparing type parameter expressions while
586 // testing the compatibility of procedure characteristics, two
587 // object dummy arguments with the same name are considered equal.
588 static bool AreSameSymbol(const Symbol &x, const Symbol &y) {
589   if (&x == &y) {
590     return true;
591   }
592   if (x.name() == y.name()) {
593     if (const auto *xObject{x.detailsIf<semantics::ObjectEntityDetails>()}) {
594       if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
595         return xObject->isDummy() && yObject->isDummy();
596       }
597     }
598   }
599   return false;
600 }
601 
602 // Implements operator==() for a union type, using special case handling
603 // for Symbol references.
604 template <typename A> static bool TestVariableEquality(const A &x, const A &y) {
605   const SymbolRef *xSymbol{std::get_if<SymbolRef>(&x.u)};
606   if (const SymbolRef * ySymbol{std::get_if<SymbolRef>(&y.u)}) {
607     return xSymbol && AreSameSymbol(*xSymbol, *ySymbol);
608   } else {
609     return x.u == y.u;
610   }
611 }
612 
613 bool BaseObject::operator==(const BaseObject &that) const {
614   return TestVariableEquality(*this, that);
615 }
616 bool Component::operator==(const Component &that) const {
617   return base_ == that.base_ && &*symbol_ == &*that.symbol_;
618 }
619 bool NamedEntity::operator==(const NamedEntity &that) const {
620   if (IsSymbol()) {
621     return that.IsSymbol() &&
622         AreSameSymbol(GetFirstSymbol(), that.GetFirstSymbol());
623   } else {
624     return !that.IsSymbol() && GetComponent() == that.GetComponent();
625   }
626 }
627 template <int KIND>
628 bool TypeParamInquiry<KIND>::operator==(
629     const TypeParamInquiry<KIND> &that) const {
630   return &*parameter_ == &*that.parameter_ && base_ == that.base_;
631 }
632 bool Triplet::operator==(const Triplet &that) const {
633   return lower_ == that.lower_ && upper_ == that.upper_ &&
634       stride_ == that.stride_;
635 }
636 bool Subscript::operator==(const Subscript &that) const { return u == that.u; }
637 bool ArrayRef::operator==(const ArrayRef &that) const {
638   return base_ == that.base_ && subscript_ == that.subscript_;
639 }
640 bool CoarrayRef::operator==(const CoarrayRef &that) const {
641   return base_ == that.base_ && subscript_ == that.subscript_ &&
642       cosubscript_ == that.cosubscript_ && stat_ == that.stat_ &&
643       team_ == that.team_ && teamIsTeamNumber_ == that.teamIsTeamNumber_;
644 }
645 bool DataRef::operator==(const DataRef &that) const {
646   return TestVariableEquality(*this, that);
647 }
648 bool Substring::operator==(const Substring &that) const {
649   return parent_ == that.parent_ && lower_ == that.lower_ &&
650       upper_ == that.upper_;
651 }
652 bool ComplexPart::operator==(const ComplexPart &that) const {
653   return part_ == that.part_ && complex_ == that.complex_;
654 }
655 bool ProcedureRef::operator==(const ProcedureRef &that) const {
656   return proc_ == that.proc_ && arguments_ == that.arguments_;
657 }
658 template <typename T>
659 bool Designator<T>::operator==(const Designator<T> &that) const {
660   return TestVariableEquality(*this, that);
661 }
662 bool DescriptorInquiry::operator==(const DescriptorInquiry &that) const {
663   return field_ == that.field_ && base_ == that.base_ &&
664       dimension_ == that.dimension_;
665 }
666 
667 INSTANTIATE_VARIABLE_TEMPLATES
668 } // namespace Fortran::evaluate
669 
670 template class Fortran::common::Indirection<Fortran::evaluate::Component, true>;
671