1 //===-- include/flang/Evaluate/tools.h --------------------------*- C++ -*-===//
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 #ifndef FORTRAN_EVALUATE_TOOLS_H_
10 #define FORTRAN_EVALUATE_TOOLS_H_
11 
12 #include "traverse.h"
13 #include "flang/Common/idioms.h"
14 #include "flang/Common/template.h"
15 #include "flang/Common/unwrap.h"
16 #include "flang/Evaluate/constant.h"
17 #include "flang/Evaluate/expression.h"
18 #include "flang/Parser/message.h"
19 #include "flang/Semantics/attr.h"
20 #include "flang/Semantics/symbol.h"
21 #include <array>
22 #include <optional>
23 #include <set>
24 #include <type_traits>
25 #include <utility>
26 
27 namespace Fortran::evaluate {
28 
29 // Some expression predicates and extractors.
30 
31 // Predicate: true when an expression is a variable reference, not an
32 // operation.  Be advised: a call to a function that returns an object
33 // pointer is a "variable" in Fortran (it can be the left-hand side of
34 // an assignment).
35 struct IsVariableHelper
36     : public AnyTraverse<IsVariableHelper, std::optional<bool>> {
37   using Result = std::optional<bool>; // effectively tri-state
38   using Base = AnyTraverse<IsVariableHelper, Result>;
IsVariableHelperIsVariableHelper39   IsVariableHelper() : Base{*this} {}
40   using Base::operator();
operatorIsVariableHelper41   Result operator()(const StaticDataObject &) const { return false; }
42   Result operator()(const Symbol &) const;
43   Result operator()(const Component &) const;
44   Result operator()(const ArrayRef &) const;
45   Result operator()(const Substring &) const;
operatorIsVariableHelper46   Result operator()(const CoarrayRef &) const { return true; }
operatorIsVariableHelper47   Result operator()(const ComplexPart &) const { return true; }
48   Result operator()(const ProcedureDesignator &) const;
operatorIsVariableHelper49   template <typename T> Result operator()(const Expr<T> &x) const {
50     if constexpr (common::HasMember<T, AllIntrinsicTypes> ||
51         std::is_same_v<T, SomeDerived>) {
52       // Expression with a specific type
53       if (std::holds_alternative<Designator<T>>(x.u) ||
54           std::holds_alternative<FunctionRef<T>>(x.u)) {
55         if (auto known{(*this)(x.u)}) {
56           return known;
57         }
58       }
59       return false;
60     } else {
61       return (*this)(x.u);
62     }
63   }
64 };
65 
IsVariable(const A & x)66 template <typename A> bool IsVariable(const A &x) {
67   if (auto known{IsVariableHelper{}(x)}) {
68     return *known;
69   } else {
70     return false;
71   }
72 }
73 
74 // Predicate: true when an expression is assumed-rank
75 bool IsAssumedRank(const Symbol &);
76 bool IsAssumedRank(const ActualArgument &);
IsAssumedRank(const A &)77 template <typename A> bool IsAssumedRank(const A &) { return false; }
IsAssumedRank(const Designator<A> & designator)78 template <typename A> bool IsAssumedRank(const Designator<A> &designator) {
79   if (const auto *symbol{std::get_if<SymbolRef>(&designator.u)}) {
80     return IsAssumedRank(symbol->get());
81   } else {
82     return false;
83   }
84 }
IsAssumedRank(const Expr<T> & expr)85 template <typename T> bool IsAssumedRank(const Expr<T> &expr) {
86   return std::visit([](const auto &x) { return IsAssumedRank(x); }, expr.u);
87 }
IsAssumedRank(const std::optional<A> & x)88 template <typename A> bool IsAssumedRank(const std::optional<A> &x) {
89   return x && IsAssumedRank(*x);
90 }
91 
92 // Generalizing packagers: these take operations and expressions of more
93 // specific types and wrap them in Expr<> containers of more abstract types.
94 
AsExpr(A && x)95 template <typename A> common::IfNoLvalue<Expr<ResultType<A>>, A> AsExpr(A &&x) {
96   return Expr<ResultType<A>>{std::move(x)};
97 }
98 
AsExpr(Expr<T> && x)99 template <typename T> Expr<T> AsExpr(Expr<T> &&x) {
100   static_assert(IsSpecificIntrinsicType<T>);
101   return std::move(x);
102 }
103 
104 template <TypeCategory CATEGORY>
AsCategoryExpr(Expr<SomeKind<CATEGORY>> && x)105 Expr<SomeKind<CATEGORY>> AsCategoryExpr(Expr<SomeKind<CATEGORY>> &&x) {
106   return std::move(x);
107 }
108 
109 template <typename A>
AsGenericExpr(A && x)110 common::IfNoLvalue<Expr<SomeType>, A> AsGenericExpr(A &&x) {
111   if constexpr (common::HasMember<A, TypelessExpression>) {
112     return Expr<SomeType>{std::move(x)};
113   } else {
114     return Expr<SomeType>{AsCategoryExpr(std::move(x))};
115   }
116 }
117 
118 template <typename A>
AsCategoryExpr(A && x)119 common::IfNoLvalue<Expr<SomeKind<ResultType<A>::category>>, A> AsCategoryExpr(
120     A &&x) {
121   return Expr<SomeKind<ResultType<A>::category>>{AsExpr(std::move(x))};
122 }
123 
AsGenericExpr(Expr<SomeType> && x)124 inline Expr<SomeType> AsGenericExpr(Expr<SomeType> &&x) { return std::move(x); }
125 
126 Expr<SomeType> Parenthesize(Expr<SomeType> &&);
127 
128 Expr<SomeReal> GetComplexPart(
129     const Expr<SomeComplex> &, bool isImaginary = false);
130 
131 template <int KIND>
MakeComplex(Expr<Type<TypeCategory::Real,KIND>> && re,Expr<Type<TypeCategory::Real,KIND>> && im)132 Expr<SomeComplex> MakeComplex(Expr<Type<TypeCategory::Real, KIND>> &&re,
133     Expr<Type<TypeCategory::Real, KIND>> &&im) {
134   return AsCategoryExpr(ComplexConstructor<KIND>{std::move(re), std::move(im)});
135 }
136 
IsNumericCategoryExpr()137 template <typename A> constexpr bool IsNumericCategoryExpr() {
138   if constexpr (common::HasMember<A, TypelessExpression>) {
139     return false;
140   } else {
141     return common::HasMember<ResultType<A>, NumericCategoryTypes>;
142   }
143 }
144 
145 // Specializing extractor.  If an Expr wraps some type of object, perhaps
146 // in several layers, return a pointer to it; otherwise null.  Also works
147 // with expressions contained in ActualArgument.
148 template <typename A, typename B>
149 auto UnwrapExpr(B &x) -> common::Constify<A, B> * {
150   using Ty = std::decay_t<B>;
151   if constexpr (std::is_same_v<A, Ty>) {
152     return &x;
153   } else if constexpr (std::is_same_v<Ty, ActualArgument>) {
154     if (auto *expr{x.UnwrapExpr()}) {
155       return UnwrapExpr<A>(*expr);
156     }
157   } else if constexpr (std::is_same_v<Ty, Expr<SomeType>>) {
158     return std::visit([](auto &x) { return UnwrapExpr<A>(x); }, x.u);
159   } else if constexpr (!common::HasMember<A, TypelessExpression>) {
160     if constexpr (std::is_same_v<Ty, Expr<ResultType<A>>> ||
161         std::is_same_v<Ty, Expr<SomeKind<ResultType<A>::category>>>) {
162       return std::visit([](auto &x) { return UnwrapExpr<A>(x); }, x.u);
163     }
164   }
165   return nullptr;
166 }
167 
168 template <typename A, typename B>
UnwrapExpr(const std::optional<B> & x)169 const A *UnwrapExpr(const std::optional<B> &x) {
170   if (x) {
171     return UnwrapExpr<A>(*x);
172   } else {
173     return nullptr;
174   }
175 }
176 
UnwrapExpr(std::optional<B> & x)177 template <typename A, typename B> A *UnwrapExpr(std::optional<B> &x) {
178   if (x) {
179     return UnwrapExpr<A>(*x);
180   } else {
181     return nullptr;
182   }
183 }
184 
185 // If an expression simply wraps a DataRef, extract and return it.
186 // The Boolean argument controls the handling of Substring
187 // references: when true (not default), it extracts the base DataRef
188 // of a substring, if it has one.
189 template <typename A>
ExtractDataRef(const A &,bool intoSubstring)190 common::IfNoLvalue<std::optional<DataRef>, A> ExtractDataRef(
191     const A &, bool intoSubstring) {
192   return std::nullopt; // default base case
193 }
194 template <typename T>
195 std::optional<DataRef> ExtractDataRef(
196     const Designator<T> &d, bool intoSubstring = false) {
197   return std::visit(
198       [=](const auto &x) -> std::optional<DataRef> {
199         if constexpr (common::HasMember<decltype(x), decltype(DataRef::u)>) {
200           return DataRef{x};
201         }
202         if constexpr (std::is_same_v<std::decay_t<decltype(x)>, Substring>) {
203           if (intoSubstring) {
204             return ExtractSubstringBase(x);
205           }
206         }
207         return std::nullopt; // w/o "else" to dodge bogus g++ 8.1 warning
208       },
209       d.u);
210 }
211 template <typename T>
212 std::optional<DataRef> ExtractDataRef(
213     const Expr<T> &expr, bool intoSubstring = false) {
214   return std::visit(
215       [=](const auto &x) { return ExtractDataRef(x, intoSubstring); }, expr.u);
216 }
217 template <typename A>
218 std::optional<DataRef> ExtractDataRef(
219     const std::optional<A> &x, bool intoSubstring = false) {
220   if (x) {
221     return ExtractDataRef(*x, intoSubstring);
222   } else {
223     return std::nullopt;
224   }
225 }
226 std::optional<DataRef> ExtractSubstringBase(const Substring &);
227 
228 // Predicate: is an expression is an array element reference?
229 template <typename T>
230 bool IsArrayElement(const Expr<T> &expr, bool intoSubstring = false) {
231   if (auto dataRef{ExtractDataRef(expr, intoSubstring)}) {
232     const DataRef *ref{&*dataRef};
233     while (const Component * component{std::get_if<Component>(&ref->u)}) {
234       ref = &component->base();
235     }
236     if (const auto *coarrayRef{std::get_if<CoarrayRef>(&ref->u)}) {
237       return !coarrayRef->subscript().empty();
238     } else {
239       return std::holds_alternative<ArrayRef>(ref->u);
240     }
241   } else {
242     return false;
243   }
244 }
245 
246 template <typename A>
ExtractNamedEntity(const A & x)247 std::optional<NamedEntity> ExtractNamedEntity(const A &x) {
248   if (auto dataRef{ExtractDataRef(x, true)}) {
249     return std::visit(
250         common::visitors{
251             [](SymbolRef &&symbol) -> std::optional<NamedEntity> {
252               return NamedEntity{symbol};
253             },
254             [](Component &&component) -> std::optional<NamedEntity> {
255               return NamedEntity{std::move(component)};
256             },
257             [](CoarrayRef &&co) -> std::optional<NamedEntity> {
258               return co.GetBase();
259             },
260             [](auto &&) { return std::optional<NamedEntity>{}; },
261         },
262         std::move(dataRef->u));
263   } else {
264     return std::nullopt;
265   }
266 }
267 
268 struct ExtractCoindexedObjectHelper {
operatorExtractCoindexedObjectHelper269   template <typename A> std::optional<CoarrayRef> operator()(const A &) const {
270     return std::nullopt;
271   }
operatorExtractCoindexedObjectHelper272   std::optional<CoarrayRef> operator()(const CoarrayRef &x) const { return x; }
273   template <typename A>
operatorExtractCoindexedObjectHelper274   std::optional<CoarrayRef> operator()(const Expr<A> &expr) const {
275     return std::visit(*this, expr.u);
276   }
operatorExtractCoindexedObjectHelper277   std::optional<CoarrayRef> operator()(const DataRef &dataRef) const {
278     return std::visit(*this, dataRef.u);
279   }
operatorExtractCoindexedObjectHelper280   std::optional<CoarrayRef> operator()(const NamedEntity &named) const {
281     if (const Component * component{named.UnwrapComponent()}) {
282       return (*this)(*component);
283     } else {
284       return std::nullopt;
285     }
286   }
operatorExtractCoindexedObjectHelper287   std::optional<CoarrayRef> operator()(const ProcedureDesignator &des) const {
288     if (const auto *component{
289             std::get_if<common::CopyableIndirection<Component>>(&des.u)}) {
290       return (*this)(component->value());
291     } else {
292       return std::nullopt;
293     }
294   }
operatorExtractCoindexedObjectHelper295   std::optional<CoarrayRef> operator()(const Component &component) const {
296     return (*this)(component.base());
297   }
operatorExtractCoindexedObjectHelper298   std::optional<CoarrayRef> operator()(const ArrayRef &arrayRef) const {
299     return (*this)(arrayRef.base());
300   }
301 };
302 
ExtractCoarrayRef(const A & x)303 template <typename A> std::optional<CoarrayRef> ExtractCoarrayRef(const A &x) {
304   if (auto dataRef{ExtractDataRef(x, true)}) {
305     return ExtractCoindexedObjectHelper{}(*dataRef);
306   } else {
307     return ExtractCoindexedObjectHelper{}(x);
308   }
309 }
310 
311 // If an expression is simply a whole symbol data designator,
312 // extract and return that symbol, else null.
UnwrapWholeSymbolDataRef(const A & x)313 template <typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {
314   if (auto dataRef{ExtractDataRef(x)}) {
315     if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
316       return &p->get();
317     }
318   }
319   return nullptr;
320 }
321 
322 // GetFirstSymbol(A%B%C[I]%D) -> A
GetFirstSymbol(const A & x)323 template <typename A> const Symbol *GetFirstSymbol(const A &x) {
324   if (auto dataRef{ExtractDataRef(x, true)}) {
325     return &dataRef->GetFirstSymbol();
326   } else {
327     return nullptr;
328   }
329 }
330 
331 // Creation of conversion expressions can be done to either a known
332 // specific intrinsic type with ConvertToType<T>(x) or by converting
333 // one arbitrary expression to the type of another with ConvertTo(to, from).
334 
335 template <typename TO, TypeCategory FROMCAT>
ConvertToType(Expr<SomeKind<FROMCAT>> && x)336 Expr<TO> ConvertToType(Expr<SomeKind<FROMCAT>> &&x) {
337   static_assert(IsSpecificIntrinsicType<TO>);
338   if constexpr (FROMCAT == TO::category) {
339     if (auto *already{std::get_if<Expr<TO>>(&x.u)}) {
340       return std::move(*already);
341     } else {
342       return Expr<TO>{Convert<TO, FROMCAT>{std::move(x)}};
343     }
344   } else if constexpr (TO::category == TypeCategory::Complex) {
345     using Part = typename TO::Part;
346     Scalar<Part> zero;
347     return Expr<TO>{ComplexConstructor<TO::kind>{
348         ConvertToType<Part>(std::move(x)), Expr<Part>{Constant<Part>{zero}}}};
349   } else if constexpr (FROMCAT == TypeCategory::Complex) {
350     // Extract and convert the real component of a complex value
351     return std::visit(
352         [&](auto &&z) {
353           using ZType = ResultType<decltype(z)>;
354           using Part = typename ZType::Part;
355           return ConvertToType<TO, TypeCategory::Real>(Expr<SomeReal>{
356               Expr<Part>{ComplexComponent<Part::kind>{false, std::move(z)}}});
357         },
358         std::move(x.u));
359   } else {
360     return Expr<TO>{Convert<TO, FROMCAT>{std::move(x)}};
361   }
362 }
363 
364 template <typename TO, TypeCategory FROMCAT, int FROMKIND>
ConvertToType(Expr<Type<FROMCAT,FROMKIND>> && x)365 Expr<TO> ConvertToType(Expr<Type<FROMCAT, FROMKIND>> &&x) {
366   return ConvertToType<TO, FROMCAT>(Expr<SomeKind<FROMCAT>>{std::move(x)});
367 }
368 
ConvertToType(BOZLiteralConstant && x)369 template <typename TO> Expr<TO> ConvertToType(BOZLiteralConstant &&x) {
370   static_assert(IsSpecificIntrinsicType<TO>);
371   if constexpr (TO::category == TypeCategory::Integer) {
372     return Expr<TO>{
373         Constant<TO>{Scalar<TO>::ConvertUnsigned(std::move(x)).value}};
374   } else {
375     static_assert(TO::category == TypeCategory::Real);
376     using Word = typename Scalar<TO>::Word;
377     return Expr<TO>{
378         Constant<TO>{Scalar<TO>{Word::ConvertUnsigned(std::move(x)).value}}};
379   }
380 }
381 
382 // Conversions to dynamic types
383 std::optional<Expr<SomeType>> ConvertToType(
384     const DynamicType &, Expr<SomeType> &&);
385 std::optional<Expr<SomeType>> ConvertToType(
386     const DynamicType &, std::optional<Expr<SomeType>> &&);
387 std::optional<Expr<SomeType>> ConvertToType(const Symbol &, Expr<SomeType> &&);
388 std::optional<Expr<SomeType>> ConvertToType(
389     const Symbol &, std::optional<Expr<SomeType>> &&);
390 
391 // Conversions to the type of another expression
392 template <TypeCategory TC, int TK, typename FROM>
ConvertTo(const Expr<Type<TC,TK>> &,FROM && x)393 common::IfNoLvalue<Expr<Type<TC, TK>>, FROM> ConvertTo(
394     const Expr<Type<TC, TK>> &, FROM &&x) {
395   return ConvertToType<Type<TC, TK>>(std::move(x));
396 }
397 
398 template <TypeCategory TC, typename FROM>
ConvertTo(const Expr<SomeKind<TC>> & to,FROM && from)399 common::IfNoLvalue<Expr<SomeKind<TC>>, FROM> ConvertTo(
400     const Expr<SomeKind<TC>> &to, FROM &&from) {
401   return std::visit(
402       [&](const auto &toKindExpr) {
403         using KindExpr = std::decay_t<decltype(toKindExpr)>;
404         return AsCategoryExpr(
405             ConvertToType<ResultType<KindExpr>>(std::move(from)));
406       },
407       to.u);
408 }
409 
410 template <typename FROM>
ConvertTo(const Expr<SomeType> & to,FROM && from)411 common::IfNoLvalue<Expr<SomeType>, FROM> ConvertTo(
412     const Expr<SomeType> &to, FROM &&from) {
413   return std::visit(
414       [&](const auto &toCatExpr) {
415         return AsGenericExpr(ConvertTo(toCatExpr, std::move(from)));
416       },
417       to.u);
418 }
419 
420 // Convert an expression of some known category to a dynamically chosen
421 // kind of some category (usually but not necessarily distinct).
422 template <TypeCategory TOCAT, typename VALUE> struct ConvertToKindHelper {
423   using Result = std::optional<Expr<SomeKind<TOCAT>>>;
424   using Types = CategoryTypes<TOCAT>;
ConvertToKindHelperConvertToKindHelper425   ConvertToKindHelper(int k, VALUE &&x) : kind{k}, value{std::move(x)} {}
TestConvertToKindHelper426   template <typename T> Result Test() {
427     if (kind == T::kind) {
428       return std::make_optional(
429           AsCategoryExpr(ConvertToType<T>(std::move(value))));
430     }
431     return std::nullopt;
432   }
433   int kind;
434   VALUE value;
435 };
436 
437 template <TypeCategory TOCAT, typename VALUE>
ConvertToKind(int kind,VALUE && x)438 common::IfNoLvalue<Expr<SomeKind<TOCAT>>, VALUE> ConvertToKind(
439     int kind, VALUE &&x) {
440   return common::SearchTypes(
441       ConvertToKindHelper<TOCAT, VALUE>{kind, std::move(x)})
442       .value();
443 }
444 
445 // Given a type category CAT, SameKindExprs<CAT, N> is a variant that
446 // holds an arrays of expressions of the same supported kind in that
447 // category.
448 template <typename A, int N = 2> using SameExprs = std::array<Expr<A>, N>;
449 template <int N = 2> struct SameKindExprsHelper {
450   template <typename A> using SameExprs = std::array<Expr<A>, N>;
451 };
452 template <TypeCategory CAT, int N = 2>
453 using SameKindExprs =
454     common::MapTemplate<SameKindExprsHelper<N>::template SameExprs,
455         CategoryTypes<CAT>>;
456 
457 // Given references to two expressions of arbitrary kind in the same type
458 // category, convert one to the kind of the other when it has the smaller kind,
459 // then return them in a type-safe package.
460 template <TypeCategory CAT>
AsSameKindExprs(Expr<SomeKind<CAT>> && x,Expr<SomeKind<CAT>> && y)461 SameKindExprs<CAT, 2> AsSameKindExprs(
462     Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
463   return std::visit(
464       [&](auto &&kx, auto &&ky) -> SameKindExprs<CAT, 2> {
465         using XTy = ResultType<decltype(kx)>;
466         using YTy = ResultType<decltype(ky)>;
467         if constexpr (std::is_same_v<XTy, YTy>) {
468           return {SameExprs<XTy>{std::move(kx), std::move(ky)}};
469         } else if constexpr (XTy::kind < YTy::kind) {
470           return {SameExprs<YTy>{ConvertTo(ky, std::move(kx)), std::move(ky)}};
471         } else {
472           return {SameExprs<XTy>{std::move(kx), ConvertTo(kx, std::move(ky))}};
473         }
474 #if !__clang__ && 100 * __GNUC__ + __GNUC_MINOR__ == 801
475         // Silence a bogus warning about a missing return with G++ 8.1.0.
476         // Doesn't execute, but must be correctly typed.
477         CHECK(!"can't happen");
478         return {SameExprs<XTy>{std::move(kx), std::move(kx)}};
479 #endif
480       },
481       std::move(x.u), std::move(y.u));
482 }
483 
484 // Ensure that both operands of an intrinsic REAL operation (or CMPLX()
485 // constructor) are INTEGER or REAL, then convert them as necessary to the
486 // same kind of REAL.
487 using ConvertRealOperandsResult =
488     std::optional<SameKindExprs<TypeCategory::Real, 2>>;
489 ConvertRealOperandsResult ConvertRealOperands(parser::ContextualMessages &,
490     Expr<SomeType> &&, Expr<SomeType> &&, int defaultRealKind);
491 
492 // Per F'2018 R718, if both components are INTEGER, they are both converted
493 // to default REAL and the result is default COMPLEX.  Otherwise, the
494 // kind of the result is the kind of most precise REAL component, and the other
495 // component is converted if necessary to its type.
496 std::optional<Expr<SomeComplex>> ConstructComplex(parser::ContextualMessages &,
497     Expr<SomeType> &&, Expr<SomeType> &&, int defaultRealKind);
498 std::optional<Expr<SomeComplex>> ConstructComplex(parser::ContextualMessages &,
499     std::optional<Expr<SomeType>> &&, std::optional<Expr<SomeType>> &&,
500     int defaultRealKind);
501 
ScalarConstantToExpr(const A & x)502 template <typename A> Expr<TypeOf<A>> ScalarConstantToExpr(const A &x) {
503   using Ty = TypeOf<A>;
504   static_assert(
505       std::is_same_v<Scalar<Ty>, std::decay_t<A>>, "TypeOf<> is broken");
506   return Expr<TypeOf<A>>{Constant<Ty>{x}};
507 }
508 
509 // Combine two expressions of the same specific numeric type with an operation
510 // to produce a new expression.
511 template <template <typename> class OPR, typename SPECIFIC>
Combine(Expr<SPECIFIC> && x,Expr<SPECIFIC> && y)512 Expr<SPECIFIC> Combine(Expr<SPECIFIC> &&x, Expr<SPECIFIC> &&y) {
513   static_assert(IsSpecificIntrinsicType<SPECIFIC>);
514   return AsExpr(OPR<SPECIFIC>{std::move(x), std::move(y)});
515 }
516 
517 // Given two expressions of arbitrary kind in the same intrinsic type
518 // category, convert one of them if necessary to the larger kind of the
519 // other, then combine the resulting homogenized operands with a given
520 // operation, returning a new expression in the same type category.
521 template <template <typename> class OPR, TypeCategory CAT>
PromoteAndCombine(Expr<SomeKind<CAT>> && x,Expr<SomeKind<CAT>> && y)522 Expr<SomeKind<CAT>> PromoteAndCombine(
523     Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
524   return std::visit(
525       [](auto &&xy) {
526         using Ty = ResultType<decltype(xy[0])>;
527         return AsCategoryExpr(
528             Combine<OPR, Ty>(std::move(xy[0]), std::move(xy[1])));
529       },
530       AsSameKindExprs(std::move(x), std::move(y)));
531 }
532 
533 // Given two expressions of arbitrary type, try to combine them with a
534 // binary numeric operation (e.g., Add), possibly with data type conversion of
535 // one of the operands to the type of the other.  Handles special cases with
536 // typeless literal operands and with REAL/COMPLEX exponentiation to INTEGER
537 // powers.
538 template <template <typename> class OPR>
539 std::optional<Expr<SomeType>> NumericOperation(parser::ContextualMessages &,
540     Expr<SomeType> &&, Expr<SomeType> &&, int defaultRealKind);
541 
542 extern template std::optional<Expr<SomeType>> NumericOperation<Power>(
543     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
544     int defaultRealKind);
545 extern template std::optional<Expr<SomeType>> NumericOperation<Multiply>(
546     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
547     int defaultRealKind);
548 extern template std::optional<Expr<SomeType>> NumericOperation<Divide>(
549     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
550     int defaultRealKind);
551 extern template std::optional<Expr<SomeType>> NumericOperation<Add>(
552     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
553     int defaultRealKind);
554 extern template std::optional<Expr<SomeType>> NumericOperation<Subtract>(
555     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
556     int defaultRealKind);
557 
558 std::optional<Expr<SomeType>> Negation(
559     parser::ContextualMessages &, Expr<SomeType> &&);
560 
561 // Given two expressions of arbitrary type, try to combine them with a
562 // relational operator (e.g., .LT.), possibly with data type conversion.
563 std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &,
564     RelationalOperator, Expr<SomeType> &&, Expr<SomeType> &&);
565 
566 template <int K>
LogicalNegation(Expr<Type<TypeCategory::Logical,K>> && x)567 Expr<Type<TypeCategory::Logical, K>> LogicalNegation(
568     Expr<Type<TypeCategory::Logical, K>> &&x) {
569   return AsExpr(Not<K>{std::move(x)});
570 }
571 
572 Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&);
573 
574 template <int K>
BinaryLogicalOperation(LogicalOperator opr,Expr<Type<TypeCategory::Logical,K>> && x,Expr<Type<TypeCategory::Logical,K>> && y)575 Expr<Type<TypeCategory::Logical, K>> BinaryLogicalOperation(LogicalOperator opr,
576     Expr<Type<TypeCategory::Logical, K>> &&x,
577     Expr<Type<TypeCategory::Logical, K>> &&y) {
578   return AsExpr(LogicalOperation<K>{opr, std::move(x), std::move(y)});
579 }
580 
581 Expr<SomeLogical> BinaryLogicalOperation(
582     LogicalOperator, Expr<SomeLogical> &&, Expr<SomeLogical> &&);
583 
584 // Convenience functions and operator overloadings for expression construction.
585 // These interfaces are defined only for those situations that can never
586 // emit any message.  Use the more general templates (above) in other
587 // situations.
588 
589 template <TypeCategory C, int K>
590 Expr<Type<C, K>> operator-(Expr<Type<C, K>> &&x) {
591   return AsExpr(Negate<Type<C, K>>{std::move(x)});
592 }
593 
594 template <TypeCategory C, int K>
595 Expr<Type<C, K>> operator+(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
596   return AsExpr(Combine<Add, Type<C, K>>(std::move(x), std::move(y)));
597 }
598 
599 template <TypeCategory C, int K>
600 Expr<Type<C, K>> operator-(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
601   return AsExpr(Combine<Subtract, Type<C, K>>(std::move(x), std::move(y)));
602 }
603 
604 template <TypeCategory C, int K>
605 Expr<Type<C, K>> operator*(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
606   return AsExpr(Combine<Multiply, Type<C, K>>(std::move(x), std::move(y)));
607 }
608 
609 template <TypeCategory C, int K>
610 Expr<Type<C, K>> operator/(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
611   return AsExpr(Combine<Divide, Type<C, K>>(std::move(x), std::move(y)));
612 }
613 
614 template <TypeCategory C> Expr<SomeKind<C>> operator-(Expr<SomeKind<C>> &&x) {
615   return std::visit(
616       [](auto &xk) { return Expr<SomeKind<C>>{-std::move(xk)}; }, x.u);
617 }
618 
619 template <TypeCategory CAT>
620 Expr<SomeKind<CAT>> operator+(
621     Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
622   return PromoteAndCombine<Add, CAT>(std::move(x), std::move(y));
623 }
624 
625 template <TypeCategory CAT>
626 Expr<SomeKind<CAT>> operator-(
627     Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
628   return PromoteAndCombine<Subtract, CAT>(std::move(x), std::move(y));
629 }
630 
631 template <TypeCategory CAT>
632 Expr<SomeKind<CAT>> operator*(
633     Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
634   return PromoteAndCombine<Multiply, CAT>(std::move(x), std::move(y));
635 }
636 
637 template <TypeCategory CAT>
638 Expr<SomeKind<CAT>> operator/(
639     Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
640   return PromoteAndCombine<Divide, CAT>(std::move(x), std::move(y));
641 }
642 
643 // A utility for use with common::SearchTypes to create generic expressions
644 // when an intrinsic type category for (say) a variable is known
645 // but the kind parameter value is not.
646 template <TypeCategory CAT, template <typename> class TEMPLATE, typename VALUE>
647 struct TypeKindVisitor {
648   using Result = std::optional<Expr<SomeType>>;
649   using Types = CategoryTypes<CAT>;
650 
TypeKindVisitorTypeKindVisitor651   TypeKindVisitor(int k, VALUE &&x) : kind{k}, value{std::move(x)} {}
TypeKindVisitorTypeKindVisitor652   TypeKindVisitor(int k, const VALUE &x) : kind{k}, value{x} {}
653 
TestTypeKindVisitor654   template <typename T> Result Test() {
655     if (kind == T::kind) {
656       return AsGenericExpr(TEMPLATE<T>{std::move(value)});
657     }
658     return std::nullopt;
659   }
660 
661   int kind;
662   VALUE value;
663 };
664 
665 // TypedWrapper() wraps a object in an explicitly typed representation
666 // (e.g., Designator<> or FunctionRef<>) that has been instantiated on
667 // a dynamically chosen Fortran type.
668 template <TypeCategory CATEGORY, template <typename> typename WRAPPER,
669     typename WRAPPED>
WrapperHelper(int kind,WRAPPED && x)670 common::IfNoLvalue<std::optional<Expr<SomeType>>, WRAPPED> WrapperHelper(
671     int kind, WRAPPED &&x) {
672   return common::SearchTypes(
673       TypeKindVisitor<CATEGORY, WRAPPER, WRAPPED>{kind, std::move(x)});
674 }
675 
676 template <template <typename> typename WRAPPER, typename WRAPPED>
TypedWrapper(const DynamicType & dyType,WRAPPED && x)677 common::IfNoLvalue<std::optional<Expr<SomeType>>, WRAPPED> TypedWrapper(
678     const DynamicType &dyType, WRAPPED &&x) {
679   switch (dyType.category()) {
680     SWITCH_COVERS_ALL_CASES
681   case TypeCategory::Integer:
682     return WrapperHelper<TypeCategory::Integer, WRAPPER, WRAPPED>(
683         dyType.kind(), std::move(x));
684   case TypeCategory::Real:
685     return WrapperHelper<TypeCategory::Real, WRAPPER, WRAPPED>(
686         dyType.kind(), std::move(x));
687   case TypeCategory::Complex:
688     return WrapperHelper<TypeCategory::Complex, WRAPPER, WRAPPED>(
689         dyType.kind(), std::move(x));
690   case TypeCategory::Character:
691     return WrapperHelper<TypeCategory::Character, WRAPPER, WRAPPED>(
692         dyType.kind(), std::move(x));
693   case TypeCategory::Logical:
694     return WrapperHelper<TypeCategory::Logical, WRAPPER, WRAPPED>(
695         dyType.kind(), std::move(x));
696   case TypeCategory::Derived:
697     return AsGenericExpr(Expr<SomeDerived>{WRAPPER<SomeDerived>{std::move(x)}});
698   }
699 }
700 
701 // GetLastSymbol() returns the rightmost symbol in an object or procedure
702 // designator (which has perhaps been wrapped in an Expr<>), or a null pointer
703 // when none is found.
704 struct GetLastSymbolHelper
705     : public AnyTraverse<GetLastSymbolHelper, std::optional<const Symbol *>> {
706   using Result = std::optional<const Symbol *>;
707   using Base = AnyTraverse<GetLastSymbolHelper, Result>;
GetLastSymbolHelperGetLastSymbolHelper708   GetLastSymbolHelper() : Base{*this} {}
709   using Base::operator();
operatorGetLastSymbolHelper710   Result operator()(const Symbol &x) const { return &x; }
operatorGetLastSymbolHelper711   Result operator()(const Component &x) const { return &x.GetLastSymbol(); }
operatorGetLastSymbolHelper712   Result operator()(const NamedEntity &x) const { return &x.GetLastSymbol(); }
operatorGetLastSymbolHelper713   Result operator()(const ProcedureDesignator &x) const {
714     return x.GetSymbol();
715   }
operatorGetLastSymbolHelper716   template <typename T> Result operator()(const Expr<T> &x) const {
717     if constexpr (common::HasMember<T, AllIntrinsicTypes> ||
718         std::is_same_v<T, SomeDerived>) {
719       if (const auto *designator{std::get_if<Designator<T>>(&x.u)}) {
720         if (auto known{(*this)(*designator)}) {
721           return known;
722         }
723       }
724       return nullptr;
725     } else {
726       return (*this)(x.u);
727     }
728   }
729 };
730 
GetLastSymbol(const A & x)731 template <typename A> const Symbol *GetLastSymbol(const A &x) {
732   if (auto known{GetLastSymbolHelper{}(x)}) {
733     return *known;
734   } else {
735     return nullptr;
736   }
737 }
738 
739 // Convenience: If GetLastSymbol() succeeds on the argument, return its
740 // set of attributes, otherwise the empty set.
GetAttrs(const A & x)741 template <typename A> semantics::Attrs GetAttrs(const A &x) {
742   if (const Symbol * symbol{GetLastSymbol(x)}) {
743     return symbol->attrs();
744   } else {
745     return {};
746   }
747 }
748 
749 // GetBaseObject()
GetBaseObject(const A &)750 template <typename A> std::optional<BaseObject> GetBaseObject(const A &) {
751   return std::nullopt;
752 }
753 template <typename T>
GetBaseObject(const Designator<T> & x)754 std::optional<BaseObject> GetBaseObject(const Designator<T> &x) {
755   return x.GetBaseObject();
756 }
757 template <typename T>
GetBaseObject(const Expr<T> & x)758 std::optional<BaseObject> GetBaseObject(const Expr<T> &x) {
759   return std::visit([](const auto &y) { return GetBaseObject(y); }, x.u);
760 }
761 template <typename A>
GetBaseObject(const std::optional<A> & x)762 std::optional<BaseObject> GetBaseObject(const std::optional<A> &x) {
763   if (x) {
764     return GetBaseObject(*x);
765   } else {
766     return std::nullopt;
767   }
768 }
769 
770 // Predicate: IsAllocatableOrPointer()
IsAllocatableOrPointer(const A & x)771 template <typename A> bool IsAllocatableOrPointer(const A &x) {
772   return GetAttrs(x).HasAny(
773       semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
774 }
775 
776 // Procedure and pointer detection predicates
777 bool IsProcedure(const Expr<SomeType> &);
778 bool IsFunction(const Expr<SomeType> &);
779 bool IsProcedurePointer(const Expr<SomeType> &);
780 bool IsNullPointer(const Expr<SomeType> &);
781 
782 // Extracts the chain of symbols from a designator, which has perhaps been
783 // wrapped in an Expr<>, removing all of the (co)subscripts.  The
784 // base object will be the first symbol in the result vector.
785 struct GetSymbolVectorHelper
786     : public Traverse<GetSymbolVectorHelper, SymbolVector> {
787   using Result = SymbolVector;
788   using Base = Traverse<GetSymbolVectorHelper, Result>;
789   using Base::operator();
GetSymbolVectorHelperGetSymbolVectorHelper790   GetSymbolVectorHelper() : Base{*this} {}
DefaultGetSymbolVectorHelper791   Result Default() { return {}; }
CombineGetSymbolVectorHelper792   Result Combine(Result &&a, Result &&b) {
793     a.insert(a.end(), b.begin(), b.end());
794     return std::move(a);
795   }
796   Result operator()(const Symbol &) const;
797   Result operator()(const Component &) const;
798   Result operator()(const ArrayRef &) const;
799   Result operator()(const CoarrayRef &) const;
800 };
GetSymbolVector(const A & x)801 template <typename A> SymbolVector GetSymbolVector(const A &x) {
802   return GetSymbolVectorHelper{}(x);
803 }
804 
805 // GetLastTarget() returns the rightmost symbol in an object designator's
806 // SymbolVector that has the POINTER or TARGET attribute, or a null pointer
807 // when none is found.
808 const Symbol *GetLastTarget(const SymbolVector &);
809 
810 // Resolves any whole ASSOCIATE(B=>A) associations, then returns GetUltimate()
811 const Symbol &ResolveAssociations(const Symbol &);
812 
813 // Collects all of the Symbols in an expression
814 template <typename A> semantics::SymbolSet CollectSymbols(const A &);
815 extern template semantics::SymbolSet CollectSymbols(const Expr<SomeType> &);
816 extern template semantics::SymbolSet CollectSymbols(const Expr<SomeInteger> &);
817 extern template semantics::SymbolSet CollectSymbols(
818     const Expr<SubscriptInteger> &);
819 
820 // Predicate: does a variable contain a vector-valued subscript (not a triplet)?
821 bool HasVectorSubscript(const Expr<SomeType> &);
822 
823 // Utilities for attaching the location of the declaration of a symbol
824 // of interest to a message, if both pointers are non-null.  Handles
825 // the case of USE association gracefully.
826 parser::Message *AttachDeclaration(parser::Message &, const Symbol &);
827 parser::Message *AttachDeclaration(parser::Message *, const Symbol &);
828 template <typename MESSAGES, typename... A>
SayWithDeclaration(MESSAGES & messages,const Symbol & symbol,A &&...x)829 parser::Message *SayWithDeclaration(
830     MESSAGES &messages, const Symbol &symbol, A &&...x) {
831   return AttachDeclaration(messages.Say(std::forward<A>(x)...), symbol);
832 }
833 
834 // Check for references to impure procedures; returns the name
835 // of one to complain about, if any exist.
836 std::optional<std::string> FindImpureCall(
837     FoldingContext &, const Expr<SomeType> &);
838 std::optional<std::string> FindImpureCall(
839     FoldingContext &, const ProcedureRef &);
840 
841 // Predicate: is a scalar expression suitable for naive scalar expansion
842 // in the flattening of an array expression?
843 // TODO: capture such scalar expansions in temporaries, flatten everything
844 struct UnexpandabilityFindingVisitor
845     : public AnyTraverse<UnexpandabilityFindingVisitor> {
846   using Base = AnyTraverse<UnexpandabilityFindingVisitor>;
847   using Base::operator();
UnexpandabilityFindingVisitorUnexpandabilityFindingVisitor848   UnexpandabilityFindingVisitor() : Base{*this} {}
operatorUnexpandabilityFindingVisitor849   template <typename T> bool operator()(const FunctionRef<T> &) { return true; }
operatorUnexpandabilityFindingVisitor850   bool operator()(const CoarrayRef &) { return true; }
851 };
852 
IsExpandableScalar(const Expr<T> & expr)853 template <typename T> bool IsExpandableScalar(const Expr<T> &expr) {
854   return !UnexpandabilityFindingVisitor{}(expr);
855 }
856 
857 // Common handling for procedure pointer compatibility of left- and right-hand
858 // sides.  Returns nullopt if they're compatible.  Otherwise, it returns a
859 // message that needs to be augmented by the names of the left and right sides
860 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
861     const std::optional<characteristics::Procedure> &lhsProcedure,
862     const characteristics::Procedure *rhsProcedure);
863 
864 // Scalar constant expansion
865 class ScalarConstantExpander {
866 public:
ScalarConstantExpander(ConstantSubscripts && extents)867   explicit ScalarConstantExpander(ConstantSubscripts &&extents)
868       : extents_{std::move(extents)} {}
ScalarConstantExpander(ConstantSubscripts && extents,std::optional<ConstantSubscripts> && lbounds)869   ScalarConstantExpander(
870       ConstantSubscripts &&extents, std::optional<ConstantSubscripts> &&lbounds)
871       : extents_{std::move(extents)}, lbounds_{std::move(lbounds)} {}
ScalarConstantExpander(ConstantSubscripts && extents,ConstantSubscripts && lbounds)872   ScalarConstantExpander(
873       ConstantSubscripts &&extents, ConstantSubscripts &&lbounds)
874       : extents_{std::move(extents)}, lbounds_{std::move(lbounds)} {}
875 
Expand(A && x)876   template <typename A> A Expand(A &&x) const {
877     return std::move(x); // default case
878   }
Expand(Constant<T> && x)879   template <typename T> Constant<T> Expand(Constant<T> &&x) {
880     auto expanded{x.Reshape(std::move(extents_))};
881     if (lbounds_) {
882       expanded.set_lbounds(std::move(*lbounds_));
883     }
884     return expanded;
885   }
Expand(Parentheses<T> && x)886   template <typename T> Constant<T> Expand(Parentheses<T> &&x) {
887     return Expand(std::move(x)); // Constant<> can be parenthesized
888   }
Expand(Expr<T> && x)889   template <typename T> Expr<T> Expand(Expr<T> &&x) {
890     return std::visit([&](auto &&x) { return Expr<T>{Expand(std::move(x))}; },
891         std::move(x.u));
892   }
893 
894 private:
895   ConstantSubscripts extents_;
896   std::optional<ConstantSubscripts> lbounds_;
897 };
898 
899 } // namespace Fortran::evaluate
900 
901 namespace Fortran::semantics {
902 
903 class Scope;
904 
905 // These functions are used in Evaluate so they are defined here rather than in
906 // Semantics to avoid a link-time dependency on Semantics.
907 
908 bool IsVariableName(const Symbol &);
909 bool IsPureProcedure(const Symbol &);
910 bool IsPureProcedure(const Scope &);
911 bool IsFunction(const Symbol &);
912 bool IsProcedure(const Symbol &);
913 bool IsProcedurePointer(const Symbol &);
914 bool IsSaved(const Symbol &); // saved implicitly or explicitly
915 bool IsDummy(const Symbol &);
916 bool IsFunctionResult(const Symbol &);
917 bool IsKindTypeParameter(const Symbol &);
918 bool IsLenTypeParameter(const Symbol &);
919 
920 // Follow use, host, and construct assocations to a variable, if any.
921 const Symbol *GetAssociationRoot(const Symbol &);
922 const Symbol *FindCommonBlockContaining(const Symbol &);
923 int CountLenParameters(const DerivedTypeSpec &);
924 int CountNonConstantLenParameters(const DerivedTypeSpec &);
925 const Symbol &GetUsedModule(const UseDetails &);
926 
927 } // namespace Fortran::semantics
928 
929 #endif // FORTRAN_EVALUATE_TOOLS_H_
930