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