FLANG
tools.h
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/enum-set.h"
14#include "flang/Common/idioms.h"
15#include "flang/Common/template.h"
16#include "flang/Common/unwrap.h"
17#include "flang/Evaluate/constant.h"
18#include "flang/Evaluate/expression.h"
19#include "flang/Evaluate/shape.h"
20#include "flang/Evaluate/type.h"
21#include "flang/Parser/message.h"
22#include "flang/Semantics/attr.h"
23#include "flang/Semantics/scope.h"
24#include "flang/Semantics/symbol.h"
25#include <array>
26#include <optional>
27#include <set>
28#include <type_traits>
29#include <utility>
30
31namespace Fortran::evaluate {
32
33// Some expression predicates and extractors.
34
35// Predicate: true when an expression is a variable reference, not an
36// operation. Be advised: a call to a function that returns an object
37// pointer is a "variable" in Fortran (it can be the left-hand side of
38// an assignment).
39struct IsVariableHelper
40 : public AnyTraverse<IsVariableHelper, std::optional<bool>> {
41 using Result = std::optional<bool>; // effectively tri-state
42 using Base = AnyTraverse<IsVariableHelper, Result>;
43 IsVariableHelper() : Base{*this} {}
44 using Base::operator();
45 Result operator()(const StaticDataObject &) const { return false; }
46 Result operator()(const Symbol &) const;
47 Result operator()(const Component &) const;
48 Result operator()(const ArrayRef &) const;
49 Result operator()(const Substring &) const;
50 Result operator()(const CoarrayRef &) const { return true; }
51 Result operator()(const ComplexPart &) const { return true; }
52 Result operator()(const ProcedureDesignator &) const;
53 template <typename T> Result operator()(const Expr<T> &x) const {
54 if constexpr (common::HasMember<T, AllIntrinsicTypes> ||
55 std::is_same_v<T, SomeDerived>) {
56 // Expression with a specific type
57 if (std::holds_alternative<Designator<T>>(x.u) ||
58 std::holds_alternative<FunctionRef<T>>(x.u)) {
59 if (auto known{(*this)(x.u)}) {
60 return known;
61 }
62 }
63 return false;
64 } else if constexpr (std::is_same_v<T, SomeType>) {
65 if (std::holds_alternative<ProcedureDesignator>(x.u) ||
66 std::holds_alternative<ProcedureRef>(x.u)) {
67 return false; // procedure pointer
68 } else {
69 return (*this)(x.u);
70 }
71 } else {
72 return (*this)(x.u);
73 }
74 }
75};
76
77template <typename A> bool IsVariable(const A &x) {
78 if (auto known{IsVariableHelper{}(x)}) {
79 return *known;
80 } else {
81 return false;
82 }
83}
84
85// Finds the corank of an entity, possibly packaged in various ways.
86// Unlike rank, only data references have corank > 0.
87int GetCorank(const ActualArgument &);
88static inline int GetCorank(const Symbol &symbol) { return symbol.Corank(); }
89template <typename A> int GetCorank(const A &) { return 0; }
90template <typename T> int GetCorank(const Designator<T> &designator) {
91 return designator.Corank();
92}
93template <typename T> int GetCorank(const Expr<T> &expr) {
94 return common::visit([](const auto &x) { return GetCorank(x); }, expr.u);
95}
96template <typename A> int GetCorank(const std::optional<A> &x) {
97 return x ? GetCorank(*x) : 0;
98}
99template <typename A> int GetCorank(const A *x) {
100 return x ? GetCorank(*x) : 0;
101}
102
103// Predicate: true when an expression is a coarray (corank > 0)
104template <typename A> bool IsCoarray(const A &x) { return GetCorank(x) > 0; }
105
106// Generalizing packagers: these take operations and expressions of more
107// specific types and wrap them in Expr<> containers of more abstract types.
108
109template <typename A> common::IfNoLvalue<Expr<ResultType<A>>, A> AsExpr(A &&x) {
110 return Expr<ResultType<A>>{std::move(x)};
111}
112
113template <typename T, typename U = typename Relational<T>::Result>
114Expr<U> AsExpr(Relational<T> &&x) {
115 // The variant in Expr<Type<TypeCategory::Logical, KIND>> only contains
116 // Relational<SomeType>, not other Relational<T>s. Wrap the Relational<T>
117 // in Relational<SomeType> before creating Expr<>.
118 return Expr<U>(Relational<SomeType>{std::move(x)});
119}
120
121template <typename T> Expr<T> AsExpr(Expr<T> &&x) {
122 static_assert(IsSpecificIntrinsicType<T>);
123 return std::move(x);
124}
125
126template <TypeCategory CATEGORY>
127Expr<SomeKind<CATEGORY>> AsCategoryExpr(Expr<SomeKind<CATEGORY>> &&x) {
128 return std::move(x);
129}
130
131template <typename A>
132common::IfNoLvalue<Expr<SomeType>, A> AsGenericExpr(A &&x) {
133 if constexpr (common::HasMember<A, TypelessExpression>) {
134 return Expr<SomeType>{std::move(x)};
135 } else {
136 return Expr<SomeType>{AsCategoryExpr(std::move(x))};
137 }
138}
139
140inline Expr<SomeType> AsGenericExpr(Expr<SomeType> &&x) { return std::move(x); }
141
142// These overloads wrap DataRefs and simple whole variables up into
143// generic expressions if they have a known type.
144std::optional<Expr<SomeType>> AsGenericExpr(DataRef &&);
145std::optional<Expr<SomeType>> AsGenericExpr(const Symbol &);
146
147// Propagate std::optional from input to output.
148template <typename A>
149std::optional<Expr<SomeType>> AsGenericExpr(std::optional<A> &&x) {
150 if (x) {
151 return AsGenericExpr(std::move(*x));
152 } else {
153 return std::nullopt;
154 }
155}
156
157template <typename A>
158common::IfNoLvalue<Expr<SomeKind<ResultType<A>::category>>, A> AsCategoryExpr(
159 A &&x) {
160 return Expr<SomeKind<ResultType<A>::category>>{AsExpr(std::move(x))};
161}
162
163Expr<SomeType> Parenthesize(Expr<SomeType> &&);
164
165template <typename A> constexpr bool IsNumericCategoryExpr() {
166 if constexpr (common::HasMember<A, TypelessExpression>) {
167 return false;
168 } else {
169 return common::HasMember<ResultType<A>, NumericCategoryTypes>;
170 }
171}
172
173// Specializing extractor. If an Expr wraps some type of object, perhaps
174// in several layers, return a pointer to it; otherwise null. Also works
175// with expressions contained in ActualArgument.
176template <typename A, typename B>
177auto UnwrapExpr(B &x) -> common::Constify<A, B> * {
178 using Ty = std::decay_t<B>;
179 if constexpr (std::is_same_v<A, Ty>) {
180 return &x;
181 } else if constexpr (std::is_same_v<Ty, ActualArgument>) {
182 if (auto *expr{x.UnwrapExpr()}) {
183 return UnwrapExpr<A>(*expr);
184 }
185 } else if constexpr (std::is_same_v<Ty, Expr<SomeType>>) {
186 return common::visit([](auto &x) { return UnwrapExpr<A>(x); }, x.u);
187 } else if constexpr (!common::HasMember<A, TypelessExpression>) {
188 if constexpr (std::is_same_v<Ty, Expr<ResultType<A>>> ||
189 std::is_same_v<Ty, Expr<SomeKind<ResultType<A>::category>>>) {
190 return common::visit([](auto &x) { return UnwrapExpr<A>(x); }, x.u);
191 }
192 }
193 return nullptr;
194}
195
196template <typename A, typename B>
197const A *UnwrapExpr(const std::optional<B> &x) {
198 if (x) {
199 return UnwrapExpr<A>(*x);
200 } else {
201 return nullptr;
202 }
203}
204
205template <typename A, typename B> A *UnwrapExpr(std::optional<B> &x) {
206 if (x) {
207 return UnwrapExpr<A>(*x);
208 } else {
209 return nullptr;
210 }
211}
212
213template <typename A, typename B> const A *UnwrapExpr(const B *x) {
214 if (x) {
215 return UnwrapExpr<A>(*x);
216 } else {
217 return nullptr;
218 }
219}
220
221template <typename A, typename B> A *UnwrapExpr(B *x) {
222 if (x) {
223 return UnwrapExpr<A>(*x);
224 } else {
225 return nullptr;
226 }
227}
228
229// A variant of UnwrapExpr above that also skips through (parentheses)
230// and conversions of kinds within a category. Useful for extracting LEN
231// type parameter inquiries, at least.
232template <typename A, typename B>
233auto UnwrapConvertedExpr(B &x) -> common::Constify<A, B> * {
234 using Ty = std::decay_t<B>;
235 if constexpr (std::is_same_v<A, Ty>) {
236 return &x;
237 } else if constexpr (std::is_same_v<Ty, ActualArgument>) {
238 if (auto *expr{x.UnwrapExpr()}) {
239 return UnwrapConvertedExpr<A>(*expr);
240 }
241 } else if constexpr (std::is_same_v<Ty, Expr<SomeType>>) {
242 return common::visit(
243 [](auto &x) { return UnwrapConvertedExpr<A>(x); }, x.u);
244 } else {
245 using DesiredResult = ResultType<A>;
246 if constexpr (std::is_same_v<Ty, Expr<DesiredResult>> ||
247 std::is_same_v<Ty, Expr<SomeKind<DesiredResult::category>>>) {
248 return common::visit(
249 [](auto &x) { return UnwrapConvertedExpr<A>(x); }, x.u);
250 } else {
251 using ThisResult = ResultType<B>;
252 if constexpr (std::is_same_v<Ty, Expr<ThisResult>>) {
253 return common::visit(
254 [](auto &x) { return UnwrapConvertedExpr<A>(x); }, x.u);
255 } else if constexpr (std::is_same_v<Ty, Parentheses<ThisResult>> ||
256 std::is_same_v<Ty, Convert<ThisResult, DesiredResult::category>>) {
257 return common::visit(
258 [](auto &x) { return UnwrapConvertedExpr<A>(x); }, x.left().u);
259 }
260 }
261 }
262 return nullptr;
263}
264
265// UnwrapProcedureRef() returns a pointer to a ProcedureRef when the whole
266// expression is a reference to a procedure.
267template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
268 return nullptr;
269}
270
271inline const ProcedureRef *UnwrapProcedureRef(const ProcedureRef &proc) {
272 // Reference to subroutine or to a function that returns
273 // an object pointer or procedure pointer
274 return &proc;
275}
276
277template <typename T>
278inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
279 return &func; // reference to a function returning a non-pointer
280}
281
282template <typename T>
283inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
284 return common::visit(
285 [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
286}
287
288// When an expression is a "bare" LEN= derived type parameter inquiry,
289// possibly wrapped in integer kind conversions &/or parentheses, return
290// a pointer to the Symbol with TypeParamDetails.
291template <typename A> const Symbol *ExtractBareLenParameter(const A &expr) {
292 if (const auto *typeParam{
293 UnwrapConvertedExpr<evaluate::TypeParamInquiry>(expr)}) {
294 if (!typeParam->base()) {
295 const Symbol &symbol{typeParam->parameter()};
296 if (const auto *tpd{symbol.detailsIf<semantics::TypeParamDetails>()}) {
297 if (tpd->attr() == common::TypeParamAttr::Len) {
298 return &symbol;
299 }
300 }
301 }
302 }
303 return nullptr;
304}
305
306// If an expression simply wraps a DataRef, extract and return it.
307// The Boolean arguments control the handling of Substring and ComplexPart
308// references: when true (not default), it extracts the base DataRef
309// of a substring or complex part.
310template <typename A>
311common::IfNoLvalue<std::optional<DataRef>, A> ExtractDataRef(
312 const A &x, bool intoSubstring, bool intoComplexPart) {
313 if constexpr (common::HasMember<decltype(x), decltype(DataRef::u)>) {
314 return DataRef{x};
315 } else {
316 return std::nullopt; // default base case
317 }
318}
319
320std::optional<DataRef> ExtractSubstringBase(const Substring &);
321
322inline std::optional<DataRef> ExtractDataRef(const Substring &x,
323 bool intoSubstring = false, bool intoComplexPart = false) {
324 if (intoSubstring) {
325 return ExtractSubstringBase(x);
326 } else {
327 return std::nullopt;
328 }
329}
330inline std::optional<DataRef> ExtractDataRef(const ComplexPart &x,
331 bool intoSubstring = false, bool intoComplexPart = false) {
332 if (intoComplexPart) {
333 return x.complex();
334 } else {
335 return std::nullopt;
336 }
337}
338template <typename T>
339std::optional<DataRef> ExtractDataRef(const Designator<T> &d,
340 bool intoSubstring = false, bool intoComplexPart = false) {
341 return common::visit(
342 [=](const auto &x) -> std::optional<DataRef> {
343 return ExtractDataRef(x, intoSubstring, intoComplexPart);
344 },
345 d.u);
346}
347template <typename T>
348std::optional<DataRef> ExtractDataRef(const Expr<T> &expr,
349 bool intoSubstring = false, bool intoComplexPart = false) {
350 return common::visit(
351 [=](const auto &x) {
352 return ExtractDataRef(x, intoSubstring, intoComplexPart);
353 },
354 expr.u);
355}
356template <typename A>
357std::optional<DataRef> ExtractDataRef(const std::optional<A> &x,
358 bool intoSubstring = false, bool intoComplexPart = false) {
359 if (x) {
360 return ExtractDataRef(*x, intoSubstring, intoComplexPart);
361 } else {
362 return std::nullopt;
363 }
364}
365template <typename A>
366std::optional<DataRef> ExtractDataRef(
367 A *p, bool intoSubstring = false, bool intoComplexPart = false) {
368 if (p) {
369 return ExtractDataRef(std::as_const(*p), intoSubstring, intoComplexPart);
370 } else {
371 return std::nullopt;
372 }
373}
374std::optional<DataRef> ExtractDataRef(const ActualArgument &,
375 bool intoSubstring = false, bool intoComplexPart = false);
376
377// Predicate: is an expression is an array element reference?
378template <typename T>
379const Symbol *IsArrayElement(const Expr<T> &expr, bool intoSubstring = true,
380 bool skipComponents = false) {
381 if (auto dataRef{ExtractDataRef(expr, intoSubstring)}) {
382 for (const DataRef *ref{&*dataRef}; ref;) {
383 if (const Component * component{std::get_if<Component>(&ref->u)}) {
384 ref = skipComponents ? &component->base() : nullptr;
385 } else if (const auto *coarrayRef{std::get_if<CoarrayRef>(&ref->u)}) {
386 ref = &coarrayRef->base();
387 } else if (const auto *arrayRef{std::get_if<ArrayRef>(&ref->u)}) {
388 return &arrayRef->GetLastSymbol();
389 } else {
390 break;
391 }
392 }
393 }
394 return nullptr;
395}
396
397template <typename T>
398bool isStructureComponent(const Fortran::evaluate::Expr<T> &expr) {
399 if (auto dataRef{ExtractDataRef(expr, /*intoSubstring=*/false)}) {
400 const Fortran::evaluate::DataRef *ref{&*dataRef};
401 return std::holds_alternative<Fortran::evaluate::Component>(ref->u);
402 }
403
404 return false;
405}
406
407template <typename A>
408std::optional<NamedEntity> ExtractNamedEntity(const A &x) {
409 if (auto dataRef{ExtractDataRef(x)}) {
410 return common::visit(
411 common::visitors{
412 [](SymbolRef &&symbol) -> std::optional<NamedEntity> {
413 return NamedEntity{symbol};
414 },
415 [](Component &&component) -> std::optional<NamedEntity> {
416 return NamedEntity{std::move(component)};
417 },
418 [](auto &&) { return std::optional<NamedEntity>{}; },
419 },
420 std::move(dataRef->u));
421 } else {
422 return std::nullopt;
423 }
424}
425
427 template <typename A> std::optional<CoarrayRef> operator()(const A &) const {
428 return std::nullopt;
429 }
430 std::optional<CoarrayRef> operator()(const CoarrayRef &x) const { return x; }
431 template <typename A>
432 std::optional<CoarrayRef> operator()(const Expr<A> &expr) const {
433 return common::visit(*this, expr.u);
434 }
435 std::optional<CoarrayRef> operator()(const DataRef &dataRef) const {
436 return common::visit(*this, dataRef.u);
437 }
438 std::optional<CoarrayRef> operator()(const NamedEntity &named) const {
439 if (const Component * component{named.UnwrapComponent()}) {
440 return (*this)(*component);
441 } else {
442 return std::nullopt;
443 }
444 }
445 std::optional<CoarrayRef> operator()(const ProcedureDesignator &des) const {
446 if (const auto *component{
447 std::get_if<common::CopyableIndirection<Component>>(&des.u)}) {
448 return (*this)(component->value());
449 } else {
450 return std::nullopt;
451 }
452 }
453 std::optional<CoarrayRef> operator()(const Component &component) const {
454 return (*this)(component.base());
455 }
456 std::optional<CoarrayRef> operator()(const ArrayRef &arrayRef) const {
457 return (*this)(arrayRef.base());
458 }
459};
460
461static inline std::optional<CoarrayRef> ExtractCoarrayRef(const DataRef &x) {
463}
464
465template <typename A> std::optional<CoarrayRef> ExtractCoarrayRef(const A &x) {
466 if (auto dataRef{ExtractDataRef(x, true)}) {
467 return ExtractCoarrayRef(*dataRef);
468 } else {
470 }
471}
472
473template <typename TARGET> struct ExtractFromExprDesignatorHelper {
474 template <typename T> static std::optional<TARGET> visit(T &&) {
475 return std::nullopt;
476 }
477
478 static std::optional<TARGET> visit(const TARGET &t) { return t; }
479
480 template <typename T>
481 static std::optional<TARGET> visit(const Designator<T> &e) {
482 return common::visit([](auto &&s) { return visit(s); }, e.u);
483 }
484
485 template <typename T> static std::optional<TARGET> visit(const Expr<T> &e) {
486 return common::visit([](auto &&s) { return visit(s); }, e.u);
487 }
488};
489
490template <typename A> std::optional<Substring> ExtractSubstring(const A &x) {
491 return ExtractFromExprDesignatorHelper<Substring>::visit(x);
492}
493
494template <typename A>
495std::optional<ComplexPart> ExtractComplexPart(const A &x) {
496 return ExtractFromExprDesignatorHelper<ComplexPart>::visit(x);
497}
498
499// If an expression is simply a whole symbol data designator,
500// extract and return that symbol, else null.
501const Symbol *UnwrapWholeSymbolDataRef(const DataRef &);
502const Symbol *UnwrapWholeSymbolDataRef(const std::optional<DataRef> &);
503template <typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {
504 return UnwrapWholeSymbolDataRef(ExtractDataRef(x));
505}
506
507// If an expression is a whole symbol or a whole component desginator,
508// extract and return that symbol, else null.
509const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &);
510const Symbol *UnwrapWholeSymbolOrComponentDataRef(
511 const std::optional<DataRef> &);
512template <typename A>
513const Symbol *UnwrapWholeSymbolOrComponentDataRef(const A &x) {
514 return UnwrapWholeSymbolOrComponentDataRef(ExtractDataRef(x));
515}
516
517// If an expression is a whole symbol or a whole component designator,
518// potentially followed by an image selector, extract and return that symbol,
519// else null.
520const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &);
521const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(
522 const std::optional<DataRef> &);
523template <typename A>
524const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const A &x) {
525 return UnwrapWholeSymbolOrComponentOrCoarrayRef(ExtractDataRef(x));
526}
527
528// GetFirstSymbol(A%B%C[I]%D) -> A
529template <typename A> const Symbol *GetFirstSymbol(const A &x) {
530 if (auto dataRef{ExtractDataRef(x, true)}) {
531 return &dataRef->GetFirstSymbol();
532 } else {
533 return nullptr;
534 }
535}
536
537// GetLastPointerSymbol(A%PTR1%B%PTR2%C) -> PTR2
538const Symbol *GetLastPointerSymbol(const evaluate::DataRef &);
539
540// Creation of conversion expressions can be done to either a known
541// specific intrinsic type with ConvertToType<T>(x) or by converting
542// one arbitrary expression to the type of another with ConvertTo(to, from).
543
544template <typename TO, TypeCategory FROMCAT>
545Expr<TO> ConvertToType(Expr<SomeKind<FROMCAT>> &&x) {
546 static_assert(IsSpecificIntrinsicType<TO>);
547 if constexpr (FROMCAT == TO::category) {
548 if (auto *already{std::get_if<Expr<TO>>(&x.u)}) {
549 return std::move(*already);
550 } else {
551 return Expr<TO>{Convert<TO, FROMCAT>{std::move(x)}};
552 }
553 } else if constexpr (TO::category == TypeCategory::Complex) {
554 using Part = typename TO::Part;
555 Scalar<Part> zero;
557 ConvertToType<Part>(std::move(x)), Expr<Part>{Constant<Part>{zero}}}};
558 } else if constexpr (FROMCAT == TypeCategory::Complex) {
559 // Extract and convert the real component of a complex value
560 return common::visit(
561 [&](auto &&z) {
562 using ZType = ResultType<decltype(z)>;
563 using Part = typename ZType::Part;
564 return ConvertToType<TO, TypeCategory::Real>(Expr<SomeReal>{
565 Expr<Part>{ComplexComponent<Part::kind>{false, std::move(z)}}});
566 },
567 std::move(x.u));
568 } else {
569 return Expr<TO>{Convert<TO, FROMCAT>{std::move(x)}};
570 }
571}
572
573template <typename TO, TypeCategory FROMCAT, int FROMKIND>
574Expr<TO> ConvertToType(Expr<Type<FROMCAT, FROMKIND>> &&x) {
575 return ConvertToType<TO, FROMCAT>(Expr<SomeKind<FROMCAT>>{std::move(x)});
576}
577
578template <typename TO> Expr<TO> ConvertToType(BOZLiteralConstant &&x) {
579 static_assert(IsSpecificIntrinsicType<TO>);
580 if constexpr (TO::category == TypeCategory::Integer ||
581 TO::category == TypeCategory::Unsigned) {
582 return Expr<TO>{
583 Constant<TO>{Scalar<TO>::ConvertUnsigned(std::move(x)).value}};
584 } else {
585 static_assert(TO::category == TypeCategory::Real);
586 using Word = typename Scalar<TO>::Word;
587 return Expr<TO>{
588 Constant<TO>{Scalar<TO>{Word::ConvertUnsigned(std::move(x)).value}}};
589 }
590}
591
592template <typename T> bool IsBOZLiteral(const Expr<T> &expr) {
593 return std::holds_alternative<BOZLiteralConstant>(expr.u);
594}
595
596// Conversions to dynamic types
597std::optional<Expr<SomeType>> ConvertToType(
598 const DynamicType &, Expr<SomeType> &&);
599std::optional<Expr<SomeType>> ConvertToType(
600 const DynamicType &, std::optional<Expr<SomeType>> &&);
601std::optional<Expr<SomeType>> ConvertToType(const Symbol &, Expr<SomeType> &&);
602std::optional<Expr<SomeType>> ConvertToType(
603 const Symbol &, std::optional<Expr<SomeType>> &&);
604
605// Conversions to the type of another expression
606template <TypeCategory TC, int TK, typename FROM>
607common::IfNoLvalue<Expr<Type<TC, TK>>, FROM> ConvertTo(
608 const Expr<Type<TC, TK>> &, FROM &&x) {
609 return ConvertToType<Type<TC, TK>>(std::move(x));
610}
611
612template <TypeCategory TC, typename FROM>
613common::IfNoLvalue<Expr<SomeKind<TC>>, FROM> ConvertTo(
614 const Expr<SomeKind<TC>> &to, FROM &&from) {
615 return common::visit(
616 [&](const auto &toKindExpr) {
617 using KindExpr = std::decay_t<decltype(toKindExpr)>;
618 return AsCategoryExpr(
619 ConvertToType<ResultType<KindExpr>>(std::move(from)));
620 },
621 to.u);
622}
623
624template <typename FROM>
625common::IfNoLvalue<Expr<SomeType>, FROM> ConvertTo(
626 const Expr<SomeType> &to, FROM &&from) {
627 return common::visit(
628 [&](const auto &toCatExpr) {
629 return AsGenericExpr(ConvertTo(toCatExpr, std::move(from)));
630 },
631 to.u);
632}
633
634// Convert an expression of some known category to a dynamically chosen
635// kind of some category (usually but not necessarily distinct).
636template <TypeCategory TOCAT, typename VALUE> struct ConvertToKindHelper {
637 using Result = std::optional<Expr<SomeKind<TOCAT>>>;
638 using Types = CategoryTypes<TOCAT>;
639 ConvertToKindHelper(int k, VALUE &&x) : kind{k}, value{std::move(x)} {}
640 template <typename T> Result Test() {
641 if (kind == T::kind) {
642 return std::make_optional(
643 AsCategoryExpr(ConvertToType<T>(std::move(value))));
644 }
645 return std::nullopt;
646 }
647 int kind;
648 VALUE value;
649};
650
651template <TypeCategory TOCAT, typename VALUE>
652common::IfNoLvalue<Expr<SomeKind<TOCAT>>, VALUE> ConvertToKind(
653 int kind, VALUE &&x) {
654 auto result{common::SearchTypes(
655 ConvertToKindHelper<TOCAT, VALUE>{kind, std::move(x)})};
656 CHECK(result.has_value());
657 return *result;
658}
659
660// Given a type category CAT, SameKindExprs<CAT, N> is a variant that
661// holds an arrays of expressions of the same supported kind in that
662// category.
663template <typename A, int N = 2> using SameExprs = std::array<Expr<A>, N>;
664template <int N = 2> struct SameKindExprsHelper {
665 template <typename A> using SameExprs = std::array<Expr<A>, N>;
666};
667template <TypeCategory CAT, int N = 2>
668using SameKindExprs =
669 common::MapTemplate<SameKindExprsHelper<N>::template SameExprs,
670 CategoryTypes<CAT>>;
671
672// Given references to two expressions of arbitrary kind in the same type
673// category, convert one to the kind of the other when it has the smaller kind,
674// then return them in a type-safe package.
675template <TypeCategory CAT>
676SameKindExprs<CAT, 2> AsSameKindExprs(
678 return common::visit(
679 [&](auto &&kx, auto &&ky) -> SameKindExprs<CAT, 2> {
680 using XTy = ResultType<decltype(kx)>;
681 using YTy = ResultType<decltype(ky)>;
682 if constexpr (std::is_same_v<XTy, YTy>) {
683 return {SameExprs<XTy>{std::move(kx), std::move(ky)}};
684 } else if constexpr (XTy::kind < YTy::kind) {
685 return {SameExprs<YTy>{ConvertTo(ky, std::move(kx)), std::move(ky)}};
686 } else {
687 return {SameExprs<XTy>{std::move(kx), ConvertTo(kx, std::move(ky))}};
688 }
689#if !__clang__ && 100 * __GNUC__ + __GNUC_MINOR__ == 801
690 // Silence a bogus warning about a missing return with G++ 8.1.0.
691 // Doesn't execute, but must be correctly typed.
692 CHECK(!"can't happen");
693 return {SameExprs<XTy>{std::move(kx), std::move(kx)}};
694#endif
695 },
696 std::move(x.u), std::move(y.u));
697}
698
699// Ensure that both operands of an intrinsic REAL operation (or CMPLX()
700// constructor) are INTEGER or REAL, then convert them as necessary to the
701// same kind of REAL.
702using ConvertRealOperandsResult =
703 std::optional<SameKindExprs<TypeCategory::Real, 2>>;
704ConvertRealOperandsResult ConvertRealOperands(parser::ContextualMessages &,
705 Expr<SomeType> &&, Expr<SomeType> &&, int defaultRealKind);
706
707// Per F'2018 R718, if both components are INTEGER, they are both converted
708// to default REAL and the result is default COMPLEX. Otherwise, the
709// kind of the result is the kind of most precise REAL component, and the other
710// component is converted if necessary to its type.
711std::optional<Expr<SomeComplex>> ConstructComplex(parser::ContextualMessages &,
712 Expr<SomeType> &&, Expr<SomeType> &&, int defaultRealKind);
713std::optional<Expr<SomeComplex>> ConstructComplex(parser::ContextualMessages &,
714 std::optional<Expr<SomeType>> &&, std::optional<Expr<SomeType>> &&,
715 int defaultRealKind);
716
717template <typename A> Expr<TypeOf<A>> ScalarConstantToExpr(const A &x) {
718 using Ty = TypeOf<A>;
719 static_assert(
720 std::is_same_v<Scalar<Ty>, std::decay_t<A>>, "TypeOf<> is broken");
721 return Expr<TypeOf<A>>{Constant<Ty>{x}};
722}
723
724// Combine two expressions of the same specific numeric type with an operation
725// to produce a new expression.
726template <template <typename> class OPR, typename SPECIFIC>
728 static_assert(IsSpecificIntrinsicType<SPECIFIC>);
729 return AsExpr(OPR<SPECIFIC>{std::move(x), std::move(y)});
730}
731
732// Given two expressions of arbitrary kind in the same intrinsic type
733// category, convert one of them if necessary to the larger kind of the
734// other, then combine the resulting homogenized operands with a given
735// operation, returning a new expression in the same type category.
736template <template <typename> class OPR, TypeCategory CAT>
737Expr<SomeKind<CAT>> PromoteAndCombine(
739 return common::visit(
740 [](auto &&xy) {
741 using Ty = ResultType<decltype(xy[0])>;
742 return AsCategoryExpr(
743 Combine<OPR, Ty>(std::move(xy[0]), std::move(xy[1])));
744 },
745 AsSameKindExprs(std::move(x), std::move(y)));
746}
747
748// Given two expressions of arbitrary type, try to combine them with a
749// binary numeric operation (e.g., Add), possibly with data type conversion of
750// one of the operands to the type of the other. Handles special cases with
751// typeless literal operands and with REAL/COMPLEX exponentiation to INTEGER
752// powers.
753template <template <typename> class OPR>
754std::optional<Expr<SomeType>> NumericOperation(parser::ContextualMessages &,
755 Expr<SomeType> &&, Expr<SomeType> &&, int defaultRealKind);
756
757extern template std::optional<Expr<SomeType>> NumericOperation<Power>(
758 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
759 int defaultRealKind);
760extern template std::optional<Expr<SomeType>> NumericOperation<Multiply>(
761 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
762 int defaultRealKind);
763extern template std::optional<Expr<SomeType>> NumericOperation<Divide>(
764 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
765 int defaultRealKind);
766extern template std::optional<Expr<SomeType>> NumericOperation<Add>(
767 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
768 int defaultRealKind);
769extern template std::optional<Expr<SomeType>> NumericOperation<Subtract>(
770 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
771 int defaultRealKind);
772
773std::optional<Expr<SomeType>> Negation(
774 parser::ContextualMessages &, Expr<SomeType> &&);
775
776// Given two expressions of arbitrary type, try to combine them with a
777// relational operator (e.g., .LT.), possibly with data type conversion.
778std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &,
779 RelationalOperator, Expr<SomeType> &&, Expr<SomeType> &&);
780
781// Create a relational operation between two identically-typed operands
782// and wrap it up in an Expr<LogicalResult>.
783template <typename T>
784Expr<LogicalResult> PackageRelation(
785 RelationalOperator opr, Expr<T> &&x, Expr<T> &&y) {
786 static_assert(IsSpecificIntrinsicType<T>);
787 return Expr<LogicalResult>{
788 Relational<SomeType>{Relational<T>{opr, std::move(x), std::move(y)}}};
789}
790
791template <int K>
794 return AsExpr(Not<K>{std::move(x)});
795}
796
797Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&);
798
799template <int K>
800Expr<Type<TypeCategory::Logical, K>> BinaryLogicalOperation(LogicalOperator opr,
803 return AsExpr(LogicalOperation<K>{opr, std::move(x), std::move(y)});
804}
805
806Expr<SomeLogical> BinaryLogicalOperation(
807 LogicalOperator, Expr<SomeLogical> &&, Expr<SomeLogical> &&);
808
809// Convenience functions and operator overloadings for expression construction.
810// These interfaces are defined only for those situations that can never
811// emit any message. Use the more general templates (above) in other
812// situations.
813
814template <TypeCategory C, int K>
815Expr<Type<C, K>> operator-(Expr<Type<C, K>> &&x) {
816 return AsExpr(Negate<Type<C, K>>{std::move(x)});
817}
818
819template <TypeCategory C, int K>
820Expr<Type<C, K>> operator+(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
821 return AsExpr(Combine<Add, Type<C, K>>(std::move(x), std::move(y)));
822}
823
824template <TypeCategory C, int K>
825Expr<Type<C, K>> operator-(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
826 return AsExpr(Combine<Subtract, Type<C, K>>(std::move(x), std::move(y)));
827}
828
829template <TypeCategory C, int K>
830Expr<Type<C, K>> operator*(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
831 return AsExpr(Combine<Multiply, Type<C, K>>(std::move(x), std::move(y)));
832}
833
834template <TypeCategory C, int K>
835Expr<Type<C, K>> operator/(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
836 return AsExpr(Combine<Divide, Type<C, K>>(std::move(x), std::move(y)));
837}
838
839template <TypeCategory C> Expr<SomeKind<C>> operator-(Expr<SomeKind<C>> &&x) {
840 return common::visit(
841 [](auto &xk) { return Expr<SomeKind<C>>{-std::move(xk)}; }, x.u);
842}
843
844template <TypeCategory CAT>
845Expr<SomeKind<CAT>> operator+(
847 return PromoteAndCombine<Add, CAT>(std::move(x), std::move(y));
848}
849
850template <TypeCategory CAT>
851Expr<SomeKind<CAT>> operator-(
853 return PromoteAndCombine<Subtract, CAT>(std::move(x), std::move(y));
854}
855
856template <TypeCategory CAT>
857Expr<SomeKind<CAT>> operator*(
859 return PromoteAndCombine<Multiply, CAT>(std::move(x), std::move(y));
860}
861
862template <TypeCategory CAT>
863Expr<SomeKind<CAT>> operator/(
865 return PromoteAndCombine<Divide, CAT>(std::move(x), std::move(y));
866}
867
868// A utility for use with common::SearchTypes to create generic expressions
869// when an intrinsic type category for (say) a variable is known
870// but the kind parameter value is not.
871template <TypeCategory CAT, template <typename> class TEMPLATE, typename VALUE>
872struct TypeKindVisitor {
873 using Result = std::optional<Expr<SomeType>>;
874 using Types = CategoryTypes<CAT>;
875
876 TypeKindVisitor(int k, VALUE &&x) : kind{k}, value{std::move(x)} {}
877 TypeKindVisitor(int k, const VALUE &x) : kind{k}, value{x} {}
878
879 template <typename T> Result Test() {
880 if (kind == T::kind) {
881 return AsGenericExpr(TEMPLATE<T>{std::move(value)});
882 }
883 return std::nullopt;
884 }
885
886 int kind;
887 VALUE value;
888};
889
890// TypedWrapper() wraps a object in an explicitly typed representation
891// (e.g., Designator<> or FunctionRef<>) that has been instantiated on
892// a dynamically chosen Fortran type.
893template <TypeCategory CATEGORY, template <typename> typename WRAPPER,
894 typename WRAPPED>
895common::IfNoLvalue<std::optional<Expr<SomeType>>, WRAPPED> WrapperHelper(
896 int kind, WRAPPED &&x) {
897 return common::SearchTypes(
899}
900
901template <template <typename> typename WRAPPER, typename WRAPPED>
902common::IfNoLvalue<std::optional<Expr<SomeType>>, WRAPPED> TypedWrapper(
903 const DynamicType &dyType, WRAPPED &&x) {
904 switch (dyType.category()) {
905 SWITCH_COVERS_ALL_CASES
906 case TypeCategory::Integer:
907 return WrapperHelper<TypeCategory::Integer, WRAPPER, WRAPPED>(
908 dyType.kind(), std::move(x));
909 case TypeCategory::Unsigned:
910 return WrapperHelper<TypeCategory::Unsigned, WRAPPER, WRAPPED>(
911 dyType.kind(), std::move(x));
912 case TypeCategory::Real:
913 return WrapperHelper<TypeCategory::Real, WRAPPER, WRAPPED>(
914 dyType.kind(), std::move(x));
915 case TypeCategory::Complex:
916 return WrapperHelper<TypeCategory::Complex, WRAPPER, WRAPPED>(
917 dyType.kind(), std::move(x));
918 case TypeCategory::Character:
919 return WrapperHelper<TypeCategory::Character, WRAPPER, WRAPPED>(
920 dyType.kind(), std::move(x));
921 case TypeCategory::Logical:
922 return WrapperHelper<TypeCategory::Logical, WRAPPER, WRAPPED>(
923 dyType.kind(), std::move(x));
924 case TypeCategory::Derived:
925 return AsGenericExpr(Expr<SomeDerived>{WRAPPER<SomeDerived>{std::move(x)}});
926 }
927}
928
929// GetLastSymbol() returns the rightmost symbol in an object or procedure
930// designator (which has perhaps been wrapped in an Expr<>), or a null pointer
931// when none is found. It will return an ASSOCIATE construct entity's symbol
932// rather than descending into its expression.
933struct GetLastSymbolHelper
934 : public AnyTraverse<GetLastSymbolHelper, std::optional<const Symbol *>> {
935 using Result = std::optional<const Symbol *>;
936 using Base = AnyTraverse<GetLastSymbolHelper, Result>;
937 GetLastSymbolHelper() : Base{*this} {}
938 using Base::operator();
939 Result operator()(const Symbol &x) const { return &x; }
940 Result operator()(const Component &x) const { return &x.GetLastSymbol(); }
941 Result operator()(const NamedEntity &x) const { return &x.GetLastSymbol(); }
942 Result operator()(const ProcedureDesignator &x) const {
943 return x.GetSymbol();
944 }
945 template <typename T> Result operator()(const Expr<T> &x) const {
946 if constexpr (common::HasMember<T, AllIntrinsicTypes> ||
947 std::is_same_v<T, SomeDerived>) {
948 if (const auto *designator{std::get_if<Designator<T>>(&x.u)}) {
949 if (auto known{(*this)(*designator)}) {
950 return known;
951 }
952 }
953 return nullptr;
954 } else {
955 return (*this)(x.u);
956 }
957 }
958};
959
960template <typename A> const Symbol *GetLastSymbol(const A &x) {
961 if (auto known{GetLastSymbolHelper{}(x)}) {
962 return *known;
963 } else {
964 return nullptr;
965 }
966}
967
968// For everyday variables: if GetLastSymbol() succeeds on the argument, return
969// its set of attributes, otherwise the empty set. Also works on variables that
970// are pointer results of functions.
971template <typename A> semantics::Attrs GetAttrs(const A &x) {
972 if (const Symbol * symbol{GetLastSymbol(x)}) {
973 return symbol->attrs();
974 } else {
975 return {};
976 }
977}
978
979template <>
980inline semantics::Attrs GetAttrs<Expr<SomeType>>(const Expr<SomeType> &x) {
981 if (IsVariable(x)) {
982 if (const auto *procRef{UnwrapProcedureRef(x)}) {
983 if (const Symbol * interface{procRef->proc().GetInterfaceSymbol()}) {
984 if (const auto *details{
985 interface->detailsIf<semantics::SubprogramDetails>()}) {
986 if (details->isFunction() &&
987 details->result().attrs().test(semantics::Attr::POINTER)) {
988 // N.B.: POINTER becomes TARGET in SetAttrsFromAssociation()
989 return details->result().attrs();
990 }
991 }
992 }
993 }
994 }
995 if (const Symbol * symbol{GetLastSymbol(x)}) {
996 return symbol->attrs();
997 } else {
998 return {};
999 }
1000}
1001
1002template <typename A> semantics::Attrs GetAttrs(const std::optional<A> &x) {
1003 if (x) {
1004 return GetAttrs(*x);
1005 } else {
1006 return {};
1007 }
1008}
1009
1010// GetBaseObject()
1011template <typename A> std::optional<BaseObject> GetBaseObject(const A &) {
1012 return std::nullopt;
1013}
1014template <typename T>
1015std::optional<BaseObject> GetBaseObject(const Designator<T> &x) {
1016 return x.GetBaseObject();
1017}
1018template <typename T>
1019std::optional<BaseObject> GetBaseObject(const Expr<T> &x) {
1020 return common::visit([](const auto &y) { return GetBaseObject(y); }, x.u);
1021}
1022template <typename A>
1023std::optional<BaseObject> GetBaseObject(const std::optional<A> &x) {
1024 if (x) {
1025 return GetBaseObject(*x);
1026 } else {
1027 return std::nullopt;
1028 }
1029}
1030
1031// Like IsAllocatableOrPointer, but accepts pointer function results as being
1032// pointers too.
1033bool IsAllocatableOrPointerObject(const Expr<SomeType> &);
1034
1035bool IsAllocatableDesignator(const Expr<SomeType> &);
1036
1037// Procedure and pointer detection predicates
1038bool IsProcedureDesignator(const Expr<SomeType> &);
1039bool IsFunctionDesignator(const Expr<SomeType> &);
1040bool IsPointer(const Expr<SomeType> &);
1041bool IsProcedurePointer(const Expr<SomeType> &);
1042bool IsProcedure(const Expr<SomeType> &);
1043bool IsProcedurePointerTarget(const Expr<SomeType> &);
1044bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD= or type
1045bool IsNullObjectPointer(const Expr<SomeType> *); // NULL() or NULL(objptr)
1046bool IsNullProcedurePointer(const Expr<SomeType> *); // NULL() or NULL(procptr)
1047bool IsNullPointer(const Expr<SomeType> *); // NULL() or NULL(pointer)
1048bool IsNullAllocatable(const Expr<SomeType> *); // NULL(allocatable)
1049bool IsNullPointerOrAllocatable(const Expr<SomeType> *); // NULL of any form
1050bool IsObjectPointer(const Expr<SomeType> &);
1051
1052// Can Expr be passed as absent to an optional dummy argument.
1053// See 15.5.2.12 point 1 for more details.
1054bool MayBePassedAsAbsentOptional(const Expr<SomeType> &);
1055
1056// Extracts the chain of symbols from a designator, which has perhaps been
1057// wrapped in an Expr<>, removing all of the (co)subscripts. The
1058// base object will be the first symbol in the result vector.
1059struct GetSymbolVectorHelper
1060 : public Traverse<GetSymbolVectorHelper, SymbolVector> {
1061 using Result = SymbolVector;
1062 using Base = Traverse<GetSymbolVectorHelper, Result>;
1063 using Base::operator();
1064 GetSymbolVectorHelper() : Base{*this} {}
1065 Result Default() { return {}; }
1066 Result Combine(Result &&a, Result &&b) {
1067 a.insert(a.end(), b.begin(), b.end());
1068 return std::move(a);
1069 }
1070 Result operator()(const Symbol &) const;
1071 Result operator()(const Component &) const;
1072 Result operator()(const ArrayRef &) const;
1073 Result operator()(const CoarrayRef &) const;
1074};
1075template <typename A> SymbolVector GetSymbolVector(const A &x) {
1076 return GetSymbolVectorHelper{}(x);
1077}
1078
1079// GetLastTarget() returns the rightmost symbol in an object designator's
1080// SymbolVector that has the POINTER or TARGET attribute, or a null pointer
1081// when none is found.
1082const Symbol *GetLastTarget(const SymbolVector &);
1083
1084// Collects all of the Symbols in an expression
1085template <typename A> semantics::UnorderedSymbolSet CollectSymbols(const A &);
1086extern template semantics::UnorderedSymbolSet CollectSymbols(
1087 const Expr<SomeType> &);
1088extern template semantics::UnorderedSymbolSet CollectSymbols(
1089 const Expr<SomeInteger> &);
1090extern template semantics::UnorderedSymbolSet CollectSymbols(
1091 const Expr<SubscriptInteger> &);
1092
1093// Collects Symbols of interest for the CUDA data transfer in an expression
1094template <typename A>
1095semantics::UnorderedSymbolSet CollectCudaSymbols(const A &);
1096extern template semantics::UnorderedSymbolSet CollectCudaSymbols(
1097 const Expr<SomeType> &);
1098extern template semantics::UnorderedSymbolSet CollectCudaSymbols(
1099 const Expr<SomeInteger> &);
1100extern template semantics::UnorderedSymbolSet CollectCudaSymbols(
1101 const Expr<SubscriptInteger> &);
1102
1103// Predicate: does a variable contain a vector-valued subscript (not a triplet)?
1104bool HasVectorSubscript(const Expr<SomeType> &);
1105bool HasVectorSubscript(const ActualArgument &);
1106
1107// Predicate: is an expression a section of an array?
1108bool IsArraySection(const Expr<SomeType> &expr);
1109
1110// Predicate: does an expression contain constant?
1111bool HasConstant(const Expr<SomeType> &);
1112
1113// Utilities for attaching the location of the declaration of a symbol
1114// of interest to a message. Handles the case of USE association gracefully.
1115parser::Message *AttachDeclaration(parser::Message &, const Symbol &);
1116parser::Message *AttachDeclaration(parser::Message *, const Symbol &);
1117template <typename MESSAGES, typename... A>
1118parser::Message *SayWithDeclaration(
1119 MESSAGES &messages, const Symbol &symbol, A &&...x) {
1120 return AttachDeclaration(messages.Say(std::forward<A>(x)...), symbol);
1121}
1122template <typename... A>
1123parser::Message *WarnWithDeclaration(FoldingContext context,
1124 const Symbol &symbol, common::LanguageFeature feature, A &&...x) {
1125 return AttachDeclaration(
1126 context.Warn(feature, std::forward<A>(x)...), symbol);
1127}
1128template <typename... A>
1129parser::Message *WarnWithDeclaration(FoldingContext &context,
1130 const Symbol &symbol, common::UsageWarning warning, A &&...x) {
1131 return AttachDeclaration(
1132 context.Warn(warning, std::forward<A>(x)...), symbol);
1133}
1134
1135// Check for references to impure procedures; returns the name
1136// of one to complain about, if any exist.
1137std::optional<std::string> FindImpureCall(
1138 FoldingContext &, const Expr<SomeType> &);
1139std::optional<std::string> FindImpureCall(
1140 FoldingContext &, const ProcedureRef &);
1141
1142// Predicate: does an expression contain anything that would prevent it from
1143// being duplicated so that two instances of it then appear in the same
1144// expression?
1145class UnsafeToCopyVisitor : public AnyTraverse<UnsafeToCopyVisitor> {
1146public:
1147 using Base = AnyTraverse<UnsafeToCopyVisitor>;
1148 using Base::operator();
1149 explicit UnsafeToCopyVisitor(bool admitPureCall)
1150 : Base{*this}, admitPureCall_{admitPureCall} {}
1151 template <typename T> bool operator()(const FunctionRef<T> &procRef) {
1152 return !admitPureCall_ || !procRef.proc().IsPure();
1153 }
1154 bool operator()(const CoarrayRef &) { return true; }
1155
1156private:
1157 bool admitPureCall_{false};
1158};
1159
1160template <typename A>
1161bool IsSafelyCopyable(const A &x, bool admitPureCall = false) {
1162 return !UnsafeToCopyVisitor{admitPureCall}(x);
1163}
1164
1165// Predicate: is a scalar expression suitable for naive scalar expansion
1166// in the flattening of an array expression?
1167// TODO: capture such scalar expansions in temporaries, flatten everything
1168template <typename T>
1169bool IsExpandableScalar(const Expr<T> &expr, FoldingContext &context,
1170 const Shape &shape, bool admitPureCall = false) {
1171 if (IsSafelyCopyable(expr, admitPureCall)) {
1172 return true;
1173 } else {
1174 auto extents{AsConstantExtents(context, shape)};
1175 return extents && !HasNegativeExtent(*extents) && GetSize(*extents) == 1;
1176 }
1177}
1178
1179// Common handling for procedure pointer compatibility of left- and right-hand
1180// sides. Returns nullopt if they're compatible. Otherwise, it returns a
1181// message that needs to be augmented by the names of the left and right sides.
1182std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
1183 const std::optional<characteristics::Procedure> &lhsProcedure,
1184 const characteristics::Procedure *rhsProcedure,
1185 const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
1186 std::optional<std::string> &warning, bool ignoreImplicitVsExplicit);
1187
1188// Scalar constant expansion
1189class ScalarConstantExpander {
1190public:
1191 explicit ScalarConstantExpander(ConstantSubscripts &&extents)
1192 : extents_{std::move(extents)} {}
1193 ScalarConstantExpander(
1194 ConstantSubscripts &&extents, std::optional<ConstantSubscripts> &&lbounds)
1195 : extents_{std::move(extents)}, lbounds_{std::move(lbounds)} {}
1196 ScalarConstantExpander(
1197 ConstantSubscripts &&extents, ConstantSubscripts &&lbounds)
1198 : extents_{std::move(extents)}, lbounds_{std::move(lbounds)} {}
1199
1200 template <typename A> A Expand(A &&x) const {
1201 return std::move(x); // default case
1202 }
1203 template <typename T> Constant<T> Expand(Constant<T> &&x) {
1204 auto expanded{x.Reshape(std::move(extents_))};
1205 if (lbounds_) {
1206 expanded.set_lbounds(std::move(*lbounds_));
1207 }
1208 return expanded;
1209 }
1210 template <typename T> Expr<T> Expand(Parentheses<T> &&x) {
1211 return Expand(std::move(x.left())); // Constant<> can be parenthesized
1212 }
1213 template <typename T> Expr<T> Expand(Expr<T> &&x) {
1214 return common::visit(
1215 [&](auto &&x) { return Expr<T>{Expand(std::move(x))}; },
1216 std::move(x.u));
1217 }
1218
1219private:
1220 ConstantSubscripts extents_;
1221 std::optional<ConstantSubscripts> lbounds_;
1222};
1223
1224// Given a collection of element values, package them as a Constant.
1225// If the type is Character or a derived type, take the length or type
1226// (resp.) from a another Constant.
1227template <typename T>
1228Constant<T> PackageConstant(std::vector<Scalar<T>> &&elements,
1229 const Constant<T> &reference, const ConstantSubscripts &shape) {
1230 if constexpr (T::category == TypeCategory::Character) {
1231 return Constant<T>{
1232 reference.LEN(), std::move(elements), ConstantSubscripts{shape}};
1233 } else if constexpr (T::category == TypeCategory::Derived) {
1234 return Constant<T>{reference.GetType().GetDerivedTypeSpec(),
1235 std::move(elements), ConstantSubscripts{shape}};
1236 } else {
1237 return Constant<T>{std::move(elements), ConstantSubscripts{shape}};
1238 }
1239}
1240
1241// Nonstandard conversions of constants (integer->logical, logical->integer)
1242// that can appear in DATA statements as an extension.
1243std::optional<Expr<SomeType>> DataConstantConversionExtension(
1244 FoldingContext &, const DynamicType &, const Expr<SomeType> &);
1245
1246// Convert Hollerith or short character to a another type as if the
1247// Hollerith data had been BOZ.
1248std::optional<Expr<SomeType>> HollerithToBOZ(
1249 FoldingContext &, const Expr<SomeType> &, const DynamicType &);
1250
1251// Set explicit lower bounds on a constant array.
1252class ArrayConstantBoundChanger {
1253public:
1254 explicit ArrayConstantBoundChanger(ConstantSubscripts &&lbounds)
1255 : lbounds_{std::move(lbounds)} {}
1256
1257 template <typename A> A ChangeLbounds(A &&x) const {
1258 return std::move(x); // default case
1259 }
1260 template <typename T> Constant<T> ChangeLbounds(Constant<T> &&x) {
1261 x.set_lbounds(std::move(lbounds_));
1262 return std::move(x);
1263 }
1264 template <typename T> Expr<T> ChangeLbounds(Parentheses<T> &&x) {
1265 return ChangeLbounds(
1266 std::move(x.left())); // Constant<> can be parenthesized
1267 }
1268 template <typename T> Expr<T> ChangeLbounds(Expr<T> &&x) {
1269 return common::visit(
1270 [&](auto &&x) { return Expr<T>{ChangeLbounds(std::move(x))}; },
1271 std::move(x.u)); // recurse until we hit a constant
1272 }
1273
1274private:
1275 ConstantSubscripts &&lbounds_;
1276};
1277
1278// Predicate: should two expressions be considered identical for the purposes
1279// of determining whether two procedure interfaces are compatible, modulo
1280// naming of corresponding dummy arguments?
1281template <typename T>
1282std::optional<bool> AreEquivalentInInterface(const Expr<T> &, const Expr<T> &);
1283extern template std::optional<bool> AreEquivalentInInterface<SubscriptInteger>(
1285extern template std::optional<bool> AreEquivalentInInterface<SomeInteger>(
1286 const Expr<SomeInteger> &, const Expr<SomeInteger> &);
1287
1288bool CheckForCoindexedObject(parser::ContextualMessages &,
1289 const std::optional<ActualArgument> &, const std::string &procName,
1290 const std::string &argName);
1291
1292bool IsCUDADeviceSymbol(const Symbol &sym);
1293
1294inline bool IsCUDAManagedOrUnifiedSymbol(const Symbol &sym) {
1295 if (const auto *details =
1296 sym.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()) {
1297 if (details->cudaDataAttr() &&
1298 (*details->cudaDataAttr() == common::CUDADataAttr::Managed ||
1299 *details->cudaDataAttr() == common::CUDADataAttr::Unified)) {
1300 return true;
1301 }
1302 }
1303 return false;
1304}
1305
1306// Get the number of distinct symbols with CUDA device
1307// attribute in the expression.
1308template <typename A> inline int GetNbOfCUDADeviceSymbols(const A &expr) {
1309 semantics::UnorderedSymbolSet symbols;
1310 for (const Symbol &sym : CollectCudaSymbols(expr)) {
1311 if (IsCUDADeviceSymbol(sym)) {
1312 symbols.insert(sym);
1313 }
1314 }
1315 return symbols.size();
1316}
1317
1318// Get the number of distinct symbols with CUDA managed or unified
1319// attribute in the expression.
1320template <typename A>
1321inline int GetNbOfCUDAManagedOrUnifiedSymbols(const A &expr) {
1322 semantics::UnorderedSymbolSet symbols;
1323 for (const Symbol &sym : CollectCudaSymbols(expr)) {
1324 if (IsCUDAManagedOrUnifiedSymbol(sym)) {
1325 symbols.insert(sym);
1326 }
1327 }
1328 return symbols.size();
1329}
1330
1331// Check if any of the symbols part of the expression has a CUDA device
1332// attribute.
1333template <typename A> inline bool HasCUDADeviceAttrs(const A &expr) {
1334 return GetNbOfCUDADeviceSymbols(expr) > 0;
1335}
1336
1337// Check if any of the symbols part of the lhs or rhs expression has a CUDA
1338// device attribute.
1339template <typename A, typename B>
1340inline bool IsCUDADataTransfer(const A &lhs, const B &rhs) {
1341 int lhsNbManagedSymbols = {GetNbOfCUDAManagedOrUnifiedSymbols(lhs)};
1342 int rhsNbManagedSymbols = {GetNbOfCUDAManagedOrUnifiedSymbols(rhs)};
1343 int rhsNbSymbols{GetNbOfCUDADeviceSymbols(rhs)};
1344
1345 // Special cases perforemd on the host:
1346 // - Only managed or unifed symbols are involved on RHS and LHS.
1347 // - LHS is managed or unified and the RHS is host only.
1348 if ((lhsNbManagedSymbols == 1 && rhsNbManagedSymbols == 1 &&
1349 rhsNbSymbols == 1) ||
1350 (lhsNbManagedSymbols == 1 && rhsNbSymbols == 0)) {
1351 return false;
1352 }
1353 return HasCUDADeviceAttrs(lhs) || rhsNbSymbols > 0;
1354}
1355
1358bool HasCUDAImplicitTransfer(const Expr<SomeType> &expr);
1359
1360// Checks whether the symbol on the LHS is present in the RHS expression.
1361bool CheckForSymbolMatch(const Expr<SomeType> *lhs, const Expr<SomeType> *rhs);
1362
1363namespace operation {
1364
1365enum class Operator {
1366 Unknown,
1367 Add,
1368 And,
1369 Associated,
1370 Call,
1371 Constant,
1372 Convert,
1373 Div,
1374 Eq,
1375 Eqv,
1376 False,
1377 Ge,
1378 Gt,
1379 Identity,
1380 Intrinsic,
1381 Le,
1382 Lt,
1383 Max,
1384 Min,
1385 Mul,
1386 Ne,
1387 Neqv,
1388 Not,
1389 Or,
1390 Pow,
1391 Resize, // Convert within the same TypeCategory
1392 Sub,
1393 True,
1394};
1395
1396using OperatorSet = common::EnumSet<Operator, 32>;
1397
1398std::string ToString(Operator op);
1399
1400template <int Kind> Operator OperationCode(const LogicalOperation<Kind> &op) {
1401 switch (op.logicalOperator) {
1402 case common::LogicalOperator::And:
1403 return Operator::And;
1404 case common::LogicalOperator::Or:
1405 return Operator::Or;
1406 case common::LogicalOperator::Eqv:
1407 return Operator::Eqv;
1408 case common::LogicalOperator::Neqv:
1409 return Operator::Neqv;
1410 case common::LogicalOperator::Not:
1411 return Operator::Not;
1412 }
1413 return Operator::Unknown;
1414}
1415
1416Operator OperationCode(const Relational<SomeType> &op);
1417
1418template <typename T> Operator OperationCode(const Relational<T> &op) {
1419 switch (op.opr) {
1420 case common::RelationalOperator::LT:
1421 return Operator::Lt;
1422 case common::RelationalOperator::LE:
1423 return Operator::Le;
1424 case common::RelationalOperator::EQ:
1425 return Operator::Eq;
1426 case common::RelationalOperator::NE:
1427 return Operator::Ne;
1428 case common::RelationalOperator::GE:
1429 return Operator::Ge;
1430 case common::RelationalOperator::GT:
1431 return Operator::Gt;
1432 }
1433 return Operator::Unknown;
1434}
1435
1436template <typename T> Operator OperationCode(const Add<T> &op) {
1437 return Operator::Add;
1438}
1439
1440template <typename T> Operator OperationCode(const Subtract<T> &op) {
1441 return Operator::Sub;
1442}
1443
1444template <typename T> Operator OperationCode(const Multiply<T> &op) {
1445 return Operator::Mul;
1446}
1447
1448template <typename T> Operator OperationCode(const Divide<T> &op) {
1449 return Operator::Div;
1450}
1451
1452template <typename T> Operator OperationCode(const Power<T> &op) {
1453 return Operator::Pow;
1454}
1455
1456template <typename T> Operator OperationCode(const RealToIntPower<T> &op) {
1457 return Operator::Pow;
1458}
1459
1460template <typename T, common::TypeCategory C>
1461Operator OperationCode(const Convert<T, C> &op) {
1462 if constexpr (C == T::category) {
1463 return Operator::Resize;
1464 } else {
1465 return Operator::Convert;
1466 }
1467}
1468
1469template <typename T> Operator OperationCode(const Extremum<T> &op) {
1470 if (op.ordering == Ordering::Greater) {
1471 return Operator::Max;
1472 } else {
1473 return Operator::Min;
1474 }
1475}
1476
1477template <typename T> Operator OperationCode(const Constant<T> &x) {
1478 return Operator::Constant;
1479}
1480
1481template <typename T> Operator OperationCode(const Designator<T> &x) {
1482 return Operator::Identity;
1483}
1484
1485template <typename T> Operator OperationCode(const T &) {
1486 return Operator::Unknown;
1487}
1488
1489Operator OperationCode(const ProcedureDesignator &proc);
1490
1491} // namespace operation
1492
1493// Return information about the top-level operation (ignoring parentheses):
1494// the operation code and the list of arguments.
1495std::pair<operation::Operator, std::vector<Expr<SomeType>>>
1496GetTopLevelOperation(const Expr<SomeType> &expr);
1497
1498// Return information about the top-level operation (ignoring parentheses, and
1499// resizing converts)
1500std::pair<operation::Operator, std::vector<Expr<SomeType>>>
1501GetTopLevelOperationIgnoreResizing(const Expr<SomeType> &expr);
1502
1503// Check if expr is same as x, or a sequence of Convert operations on x.
1504bool IsSameOrConvertOf(const Expr<SomeType> &expr, const Expr<SomeType> &x);
1505
1506// Check if the Variable appears as a subexpression of the expression.
1507bool IsVarSubexpressionOf(
1508 const Expr<SomeType> &var, const Expr<SomeType> &super);
1509
1510// Strip away any top-level Convert operations (if any exist) and return
1511// the input value. A ComplexConstructor(x, 0) is also considered as a
1512// convert operation.
1513// If the input is not Operation, Designator, FunctionRef or Constant,
1514// it returns std::nullopt.
1515std::optional<Expr<SomeType>> GetConvertInput(const Expr<SomeType> &x);
1516
1517// How many ancestors does have a derived type have?
1518std::optional<int> CountDerivedTypeAncestors(const semantics::Scope &);
1519
1520} // namespace Fortran::evaluate
1521
1522namespace Fortran::semantics {
1523
1524class Scope;
1525
1526// If a symbol represents an ENTRY, return the symbol of the main entry
1527// point to its subprogram.
1528const Symbol *GetMainEntry(const Symbol *);
1529
1530inline bool IsAlternateEntry(const Symbol *symbol) {
1531 // If symbol is not alternate entry symbol, GetMainEntry() returns the same
1532 // symbol.
1533 return symbol && GetMainEntry(symbol) != symbol;
1534}
1535
1536// These functions are used in Evaluate so they are defined here rather than in
1537// Semantics to avoid a link-time dependency on Semantics.
1538// All of these apply GetUltimate() or ResolveAssociations() to their arguments.
1539bool IsVariableName(const Symbol &);
1540bool IsPureProcedure(const Symbol &);
1541bool IsPureProcedure(const Scope &);
1542bool IsExplicitlyImpureProcedure(const Symbol &);
1543bool IsElementalProcedure(const Symbol &);
1544bool IsFunction(const Symbol &);
1545bool IsFunction(const Scope &);
1546bool IsProcedure(const Symbol &);
1547bool IsProcedure(const Scope &);
1548bool IsProcedurePointer(const Symbol *);
1549bool IsProcedurePointer(const Symbol &);
1550bool IsObjectPointer(const Symbol *);
1551bool IsAllocatableOrObjectPointer(const Symbol *);
1552bool IsAutomatic(const Symbol &);
1553bool IsSaved(const Symbol &); // saved implicitly or explicitly
1554bool IsDummy(const Symbol &);
1555
1556bool IsAssumedRank(const Symbol &);
1557template <typename A> bool IsAssumedRank(const A &x) {
1558 auto *symbol{UnwrapWholeSymbolDataRef(x)};
1559 return symbol && IsAssumedRank(*symbol);
1560}
1561
1562bool IsAssumedShape(const Symbol &);
1563template <typename A> bool IsAssumedShape(const A &x) {
1564 auto *symbol{UnwrapWholeSymbolDataRef(x)};
1565 return symbol && IsAssumedShape(*symbol);
1566}
1567
1568bool IsDeferredShape(const Symbol &);
1569bool IsFunctionResult(const Symbol &);
1570bool IsKindTypeParameter(const Symbol &);
1571bool IsLenTypeParameter(const Symbol &);
1572bool IsExtensibleType(const DerivedTypeSpec *);
1573bool IsSequenceOrBindCType(const DerivedTypeSpec *);
1574bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name);
1575bool IsBuiltinCPtr(const Symbol &);
1576bool IsFromBuiltinModule(const Symbol &);
1577bool IsEventType(const DerivedTypeSpec *);
1578bool IsLockType(const DerivedTypeSpec *);
1579bool IsNotifyType(const DerivedTypeSpec *);
1580// Is this derived type IEEE_FLAG_TYPE from module ISO_IEEE_EXCEPTIONS?
1581bool IsIeeeFlagType(const DerivedTypeSpec *);
1582// Is this derived type IEEE_ROUND_TYPE from module ISO_IEEE_ARITHMETIC?
1583bool IsIeeeRoundType(const DerivedTypeSpec *);
1584// Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV?
1585bool IsTeamType(const DerivedTypeSpec *);
1586// Is this derived type TEAM_TYPE, C_PTR, or C_FUNPTR?
1587bool IsBadCoarrayType(const DerivedTypeSpec *);
1588// Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING
1589bool IsIsoCType(const DerivedTypeSpec *);
1590bool IsEventTypeOrLockType(const DerivedTypeSpec *);
1591inline bool IsAssumedSizeArray(const Symbol &symbol) {
1592 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1593 return (object->isDummy() || symbol.test(Symbol::Flag::CrayPointee)) &&
1594 object->shape().CanBeAssumedSize();
1595 } else if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
1596 return assoc->IsAssumedSize();
1597 } else {
1598 return false;
1599 }
1600}
1601
1602// ResolveAssociations() traverses use associations and host associations
1603// like GetUltimate(), but also resolves through whole variable associations
1604// with ASSOCIATE(x => y) and related constructs. GetAssociationRoot()
1605// applies ResolveAssociations() and then, in the case of resolution to
1606// a construct association with part of a variable that does not involve a
1607// vector subscript, returns the first symbol of that variable instead
1608// of the construct entity.
1609// (E.g., for ASSOCIATE(x => y%z), ResolveAssociations(x) returns x,
1610// while GetAssociationRoot(x) returns y.)
1611// In a SELECT RANK construct, ResolveAssociations() stops at a
1612// RANK(n) or RANK(*) case symbol, but traverses the selector for
1613// RANK DEFAULT.
1614const Symbol &ResolveAssociations(const Symbol &, bool stopAtTypeGuard = false);
1615const Symbol &GetAssociationRoot(const Symbol &, bool stopAtTypeGuard = false);
1616
1617const Symbol *FindCommonBlockContaining(const Symbol &);
1618int CountLenParameters(const DerivedTypeSpec &);
1619int CountNonConstantLenParameters(const DerivedTypeSpec &);
1620
1621const Symbol &GetUsedModule(const UseDetails &);
1622const Symbol *FindFunctionResult(const Symbol &);
1623
1624// Type compatibility predicate: are x and y effectively the same type?
1625// Uses DynamicType::IsTkCompatible(), which handles the case of distinct
1626// but identical derived types.
1627bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
1628
1629common::IgnoreTKRSet GetIgnoreTKR(const Symbol &);
1630
1631std::optional<int> GetDummyArgumentNumber(const Symbol *);
1632
1633const Symbol *FindAncestorModuleProcedure(const Symbol *symInSubmodule);
1634
1635} // namespace Fortran::semantics
1636
1637#endif // FORTRAN_EVALUATE_TOOLS_H_
Definition variable.h:205
Definition variable.h:243
Definition variable.h:353
Definition variable.h:73
Definition constant.h:147
Definition variable.h:377
Definition type.h:74
Definition common.h:214
Definition common.h:216
Definition call.h:293
Definition variable.h:101
Definition call.h:233
Definition expression.h:656
Definition static-data.h:29
Definition variable.h:300
Definition type.h:57
Definition message.h:386
Definition scope.h:58
Definition symbol.h:791
Definition symbol.h:636
Definition call.h:34
bool HasCUDAImplicitTransfer(const Expr< SomeType > &expr)
Definition tools.cpp:1126
Definition expression.h:296
Definition expression.h:257
Definition expression.h:357
Definition expression.h:211
Definition variable.h:284
Definition expression.h:317
Definition expression.h:379
Definition expression.h:310
Definition expression.h:247
Definition expression.h:272
Definition expression.h:229
Definition type.h:399
Definition expression.h:303
Definition characteristics.h:367