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
1292inline bool IsCUDADeviceSymbol(const Symbol &sym) {
1293 if (const auto *details =
1294 sym.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()) {
1295 if (details->cudaDataAttr() &&
1296 *details->cudaDataAttr() != common::CUDADataAttr::Pinned) {
1297 return true;
1298 }
1299 }
1300 return false;
1301}
1302
1303inline bool IsCUDAManagedOrUnifiedSymbol(const Symbol &sym) {
1304 if (const auto *details =
1305 sym.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()) {
1306 if (details->cudaDataAttr() &&
1307 (*details->cudaDataAttr() == common::CUDADataAttr::Managed ||
1308 *details->cudaDataAttr() == common::CUDADataAttr::Unified)) {
1309 return true;
1310 }
1311 }
1312 return false;
1313}
1314
1315// Get the number of distinct symbols with CUDA device
1316// attribute in the expression.
1317template <typename A> inline int GetNbOfCUDADeviceSymbols(const A &expr) {
1318 semantics::UnorderedSymbolSet symbols;
1319 for (const Symbol &sym : CollectCudaSymbols(expr)) {
1320 if (IsCUDADeviceSymbol(sym)) {
1321 symbols.insert(sym);
1322 }
1323 }
1324 return symbols.size();
1325}
1326
1327// Get the number of distinct symbols with CUDA managed or unified
1328// attribute in the expression.
1329template <typename A>
1330inline int GetNbOfCUDAManagedOrUnifiedSymbols(const A &expr) {
1331 semantics::UnorderedSymbolSet symbols;
1332 for (const Symbol &sym : CollectCudaSymbols(expr)) {
1333 if (IsCUDAManagedOrUnifiedSymbol(sym)) {
1334 symbols.insert(sym);
1335 }
1336 }
1337 return symbols.size();
1338}
1339
1340// Check if any of the symbols part of the expression has a CUDA device
1341// attribute.
1342template <typename A> inline bool HasCUDADeviceAttrs(const A &expr) {
1343 return GetNbOfCUDADeviceSymbols(expr) > 0;
1344}
1345
1346// Check if any of the symbols part of the lhs or rhs expression has a CUDA
1347// device attribute.
1348template <typename A, typename B>
1349inline bool IsCUDADataTransfer(const A &lhs, const B &rhs) {
1350 int lhsNbManagedSymbols = {GetNbOfCUDAManagedOrUnifiedSymbols(lhs)};
1351 int rhsNbManagedSymbols = {GetNbOfCUDAManagedOrUnifiedSymbols(rhs)};
1352 int rhsNbSymbols{GetNbOfCUDADeviceSymbols(rhs)};
1353
1354 // Special case where only managed or unifed symbols are involved. This is
1355 // performed on the host.
1356 if (lhsNbManagedSymbols == 1 && rhsNbManagedSymbols == 1 &&
1357 rhsNbSymbols == 1) {
1358 return false;
1359 }
1360 return HasCUDADeviceAttrs(lhs) || rhsNbSymbols > 0;
1361}
1362
1365bool HasCUDAImplicitTransfer(const Expr<SomeType> &expr);
1366
1367// Checks whether the symbol on the LHS is present in the RHS expression.
1368bool CheckForSymbolMatch(const Expr<SomeType> *lhs, const Expr<SomeType> *rhs);
1369
1370namespace operation {
1371
1372enum class Operator {
1373 Unknown,
1374 Add,
1375 And,
1376 Associated,
1377 Call,
1378 Constant,
1379 Convert,
1380 Div,
1381 Eq,
1382 Eqv,
1383 False,
1384 Ge,
1385 Gt,
1386 Identity,
1387 Intrinsic,
1388 Le,
1389 Lt,
1390 Max,
1391 Min,
1392 Mul,
1393 Ne,
1394 Neqv,
1395 Not,
1396 Or,
1397 Pow,
1398 Resize, // Convert within the same TypeCategory
1399 Sub,
1400 True,
1401};
1402
1403using OperatorSet = common::EnumSet<Operator, 32>;
1404
1405std::string ToString(Operator op);
1406
1407template <int Kind> Operator OperationCode(const LogicalOperation<Kind> &op) {
1408 switch (op.logicalOperator) {
1409 case common::LogicalOperator::And:
1410 return Operator::And;
1411 case common::LogicalOperator::Or:
1412 return Operator::Or;
1413 case common::LogicalOperator::Eqv:
1414 return Operator::Eqv;
1415 case common::LogicalOperator::Neqv:
1416 return Operator::Neqv;
1417 case common::LogicalOperator::Not:
1418 return Operator::Not;
1419 }
1420 return Operator::Unknown;
1421}
1422
1423Operator OperationCode(const Relational<SomeType> &op);
1424
1425template <typename T> Operator OperationCode(const Relational<T> &op) {
1426 switch (op.opr) {
1427 case common::RelationalOperator::LT:
1428 return Operator::Lt;
1429 case common::RelationalOperator::LE:
1430 return Operator::Le;
1431 case common::RelationalOperator::EQ:
1432 return Operator::Eq;
1433 case common::RelationalOperator::NE:
1434 return Operator::Ne;
1435 case common::RelationalOperator::GE:
1436 return Operator::Ge;
1437 case common::RelationalOperator::GT:
1438 return Operator::Gt;
1439 }
1440 return Operator::Unknown;
1441}
1442
1443template <typename T> Operator OperationCode(const Add<T> &op) {
1444 return Operator::Add;
1445}
1446
1447template <typename T> Operator OperationCode(const Subtract<T> &op) {
1448 return Operator::Sub;
1449}
1450
1451template <typename T> Operator OperationCode(const Multiply<T> &op) {
1452 return Operator::Mul;
1453}
1454
1455template <typename T> Operator OperationCode(const Divide<T> &op) {
1456 return Operator::Div;
1457}
1458
1459template <typename T> Operator OperationCode(const Power<T> &op) {
1460 return Operator::Pow;
1461}
1462
1463template <typename T> Operator OperationCode(const RealToIntPower<T> &op) {
1464 return Operator::Pow;
1465}
1466
1467template <typename T, common::TypeCategory C>
1468Operator OperationCode(const Convert<T, C> &op) {
1469 if constexpr (C == T::category) {
1470 return Operator::Resize;
1471 } else {
1472 return Operator::Convert;
1473 }
1474}
1475
1476template <typename T> Operator OperationCode(const Extremum<T> &op) {
1477 if (op.ordering == Ordering::Greater) {
1478 return Operator::Max;
1479 } else {
1480 return Operator::Min;
1481 }
1482}
1483
1484template <typename T> Operator OperationCode(const Constant<T> &x) {
1485 return Operator::Constant;
1486}
1487
1488template <typename T> Operator OperationCode(const Designator<T> &x) {
1489 return Operator::Identity;
1490}
1491
1492template <typename T> Operator OperationCode(const T &) {
1493 return Operator::Unknown;
1494}
1495
1496Operator OperationCode(const ProcedureDesignator &proc);
1497
1498} // namespace operation
1499
1500// Return information about the top-level operation (ignoring parentheses):
1501// the operation code and the list of arguments.
1502std::pair<operation::Operator, std::vector<Expr<SomeType>>>
1503GetTopLevelOperation(const Expr<SomeType> &expr);
1504
1505// Return information about the top-level operation (ignoring parentheses, and
1506// resizing converts)
1507std::pair<operation::Operator, std::vector<Expr<SomeType>>>
1508GetTopLevelOperationIgnoreResizing(const Expr<SomeType> &expr);
1509
1510// Check if expr is same as x, or a sequence of Convert operations on x.
1511bool IsSameOrConvertOf(const Expr<SomeType> &expr, const Expr<SomeType> &x);
1512
1513// Check if the Variable appears as a subexpression of the expression.
1514bool IsVarSubexpressionOf(
1515 const Expr<SomeType> &var, const Expr<SomeType> &super);
1516
1517// Strip away any top-level Convert operations (if any exist) and return
1518// the input value. A ComplexConstructor(x, 0) is also considered as a
1519// convert operation.
1520// If the input is not Operation, Designator, FunctionRef or Constant,
1521// it returns std::nullopt.
1522std::optional<Expr<SomeType>> GetConvertInput(const Expr<SomeType> &x);
1523
1524// How many ancestors does have a derived type have?
1525std::optional<int> CountDerivedTypeAncestors(const semantics::Scope &);
1526
1527} // namespace Fortran::evaluate
1528
1529namespace Fortran::semantics {
1530
1531class Scope;
1532
1533// If a symbol represents an ENTRY, return the symbol of the main entry
1534// point to its subprogram.
1535const Symbol *GetMainEntry(const Symbol *);
1536
1537inline bool IsAlternateEntry(const Symbol *symbol) {
1538 // If symbol is not alternate entry symbol, GetMainEntry() returns the same
1539 // symbol.
1540 return symbol && GetMainEntry(symbol) != symbol;
1541}
1542
1543// These functions are used in Evaluate so they are defined here rather than in
1544// Semantics to avoid a link-time dependency on Semantics.
1545// All of these apply GetUltimate() or ResolveAssociations() to their arguments.
1546bool IsVariableName(const Symbol &);
1547bool IsPureProcedure(const Symbol &);
1548bool IsPureProcedure(const Scope &);
1549bool IsExplicitlyImpureProcedure(const Symbol &);
1550bool IsElementalProcedure(const Symbol &);
1551bool IsFunction(const Symbol &);
1552bool IsFunction(const Scope &);
1553bool IsProcedure(const Symbol &);
1554bool IsProcedure(const Scope &);
1555bool IsProcedurePointer(const Symbol *);
1556bool IsProcedurePointer(const Symbol &);
1557bool IsObjectPointer(const Symbol *);
1558bool IsAllocatableOrObjectPointer(const Symbol *);
1559bool IsAutomatic(const Symbol &);
1560bool IsSaved(const Symbol &); // saved implicitly or explicitly
1561bool IsDummy(const Symbol &);
1562
1563bool IsAssumedRank(const Symbol &);
1564template <typename A> bool IsAssumedRank(const A &x) {
1565 auto *symbol{UnwrapWholeSymbolDataRef(x)};
1566 return symbol && IsAssumedRank(*symbol);
1567}
1568
1569bool IsAssumedShape(const Symbol &);
1570template <typename A> bool IsAssumedShape(const A &x) {
1571 auto *symbol{UnwrapWholeSymbolDataRef(x)};
1572 return symbol && IsAssumedShape(*symbol);
1573}
1574
1575bool IsDeferredShape(const Symbol &);
1576bool IsFunctionResult(const Symbol &);
1577bool IsKindTypeParameter(const Symbol &);
1578bool IsLenTypeParameter(const Symbol &);
1579bool IsExtensibleType(const DerivedTypeSpec *);
1580bool IsSequenceOrBindCType(const DerivedTypeSpec *);
1581bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name);
1582bool IsBuiltinCPtr(const Symbol &);
1583bool IsFromBuiltinModule(const Symbol &);
1584bool IsEventType(const DerivedTypeSpec *);
1585bool IsLockType(const DerivedTypeSpec *);
1586bool IsNotifyType(const DerivedTypeSpec *);
1587// Is this derived type IEEE_FLAG_TYPE from module ISO_IEEE_EXCEPTIONS?
1588bool IsIeeeFlagType(const DerivedTypeSpec *);
1589// Is this derived type IEEE_ROUND_TYPE from module ISO_IEEE_ARITHMETIC?
1590bool IsIeeeRoundType(const DerivedTypeSpec *);
1591// Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV?
1592bool IsTeamType(const DerivedTypeSpec *);
1593// Is this derived type TEAM_TYPE, C_PTR, or C_FUNPTR?
1594bool IsBadCoarrayType(const DerivedTypeSpec *);
1595// Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING
1596bool IsIsoCType(const DerivedTypeSpec *);
1597bool IsEventTypeOrLockType(const DerivedTypeSpec *);
1598inline bool IsAssumedSizeArray(const Symbol &symbol) {
1599 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1600 return (object->isDummy() || symbol.test(Symbol::Flag::CrayPointee)) &&
1601 object->shape().CanBeAssumedSize();
1602 } else if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
1603 return assoc->IsAssumedSize();
1604 } else {
1605 return false;
1606 }
1607}
1608
1609// ResolveAssociations() traverses use associations and host associations
1610// like GetUltimate(), but also resolves through whole variable associations
1611// with ASSOCIATE(x => y) and related constructs. GetAssociationRoot()
1612// applies ResolveAssociations() and then, in the case of resolution to
1613// a construct association with part of a variable that does not involve a
1614// vector subscript, returns the first symbol of that variable instead
1615// of the construct entity.
1616// (E.g., for ASSOCIATE(x => y%z), ResolveAssociations(x) returns x,
1617// while GetAssociationRoot(x) returns y.)
1618// In a SELECT RANK construct, ResolveAssociations() stops at a
1619// RANK(n) or RANK(*) case symbol, but traverses the selector for
1620// RANK DEFAULT.
1621const Symbol &ResolveAssociations(const Symbol &, bool stopAtTypeGuard = false);
1622const Symbol &GetAssociationRoot(const Symbol &, bool stopAtTypeGuard = false);
1623
1624const Symbol *FindCommonBlockContaining(const Symbol &);
1625int CountLenParameters(const DerivedTypeSpec &);
1626int CountNonConstantLenParameters(const DerivedTypeSpec &);
1627
1628const Symbol &GetUsedModule(const UseDetails &);
1629const Symbol *FindFunctionResult(const Symbol &);
1630
1631// Type compatibility predicate: are x and y effectively the same type?
1632// Uses DynamicType::IsTkCompatible(), which handles the case of distinct
1633// but identical derived types.
1634bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
1635
1636common::IgnoreTKRSet GetIgnoreTKR(const Symbol &);
1637
1638std::optional<int> GetDummyArgumentNumber(const Symbol *);
1639
1640const Symbol *FindAncestorModuleProcedure(const Symbol *symInSubmodule);
1641
1642} // namespace Fortran::semantics
1643
1644#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:282
Definition variable.h:101
Definition call.h:232
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:781
Definition symbol.h:626
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