2642 lines · cpp
1//===-- lib/Evaluate/tools.cpp --------------------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Evaluate/tools.h"10#include "flang/Common/idioms.h"11#include "flang/Common/type-kinds.h"12#include "flang/Evaluate/characteristics.h"13#include "flang/Evaluate/traverse.h"14#include "flang/Parser/message.h"15#include "flang/Semantics/tools.h"16#include "llvm/ADT/StringSwitch.h"17#include <algorithm>18#include <variant>19 20using namespace Fortran::parser::literals;21 22namespace Fortran::evaluate {23 24// Can x*(a,b) be represented as (x*a,x*b)? This code duplication25// of the subexpression "x" cannot (yet?) be reliably undone by26// common subexpression elimination in lowering, so it's disabled27// here for now to avoid the risk of potential duplication of28// expensive subexpressions (e.g., large array expressions, references29// to expensive functions) in generate code.30static constexpr bool allowOperandDuplication{false};31 32std::optional<Expr<SomeType>> AsGenericExpr(DataRef &&ref) {33 if (auto dyType{DynamicType::From(ref.GetLastSymbol())}) {34 return TypedWrapper<Designator, DataRef>(*dyType, std::move(ref));35 } else {36 return std::nullopt;37 }38}39 40std::optional<Expr<SomeType>> AsGenericExpr(const Symbol &symbol) {41 return AsGenericExpr(DataRef{symbol});42}43 44Expr<SomeType> Parenthesize(Expr<SomeType> &&expr) {45 return common::visit(46 [&](auto &&x) {47 using T = std::decay_t<decltype(x)>;48 if constexpr (common::HasMember<T, TypelessExpression>) {49 return expr; // no parentheses around typeless50 } else if constexpr (std::is_same_v<T, Expr<SomeDerived>>) {51 return AsGenericExpr(Parentheses<SomeDerived>{std::move(x)});52 } else {53 return common::visit(54 [](auto &&y) {55 using T = ResultType<decltype(y)>;56 return AsGenericExpr(Parentheses<T>{std::move(y)});57 },58 std::move(x.u));59 }60 },61 std::move(expr.u));62}63 64std::optional<DataRef> ExtractDataRef(65 const ActualArgument &arg, bool intoSubstring, bool intoComplexPart) {66 return ExtractDataRef(arg.UnwrapExpr(), intoSubstring, intoComplexPart);67}68 69std::optional<DataRef> ExtractSubstringBase(const Substring &substring) {70 return common::visit(71 common::visitors{72 [&](const DataRef &x) -> std::optional<DataRef> { return x; },73 [&](const StaticDataObject::Pointer &) -> std::optional<DataRef> {74 return std::nullopt;75 },76 },77 substring.parent());78}79 80// IsVariable()81 82auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {83 // ASSOCIATE(x => expr) -- x counts as a variable, but undefinable84 const Symbol &ultimate{symbol.GetUltimate()};85 return !IsNamedConstant(ultimate) &&86 (ultimate.has<semantics::ObjectEntityDetails>() ||87 (ultimate.has<semantics::EntityDetails>() &&88 ultimate.attrs().test(semantics::Attr::TARGET)) ||89 ultimate.has<semantics::AssocEntityDetails>());90}91auto IsVariableHelper::operator()(const Component &x) const -> Result {92 const Symbol &comp{x.GetLastSymbol()};93 return (*this)(comp) && (IsPointer(comp) || (*this)(x.base()));94}95auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {96 return (*this)(x.base());97}98auto IsVariableHelper::operator()(const Substring &x) const -> Result {99 return (*this)(x.GetBaseObject());100}101auto IsVariableHelper::operator()(const ProcedureDesignator &x) const102 -> Result {103 if (const Symbol * symbol{x.GetSymbol()}) {104 const Symbol *result{FindFunctionResult(*symbol)};105 return result && IsPointer(*result) && !IsProcedurePointer(*result);106 }107 return false;108}109 110// Conversions of COMPLEX component expressions to REAL.111ConvertRealOperandsResult ConvertRealOperands(112 parser::ContextualMessages &messages, Expr<SomeType> &&x,113 Expr<SomeType> &&y, int defaultRealKind) {114 return common::visit(115 common::visitors{116 [&](Expr<SomeInteger> &&ix,117 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {118 // Can happen in a CMPLX() constructor. Per F'2018,119 // both integer operands are converted to default REAL.120 return {AsSameKindExprs<TypeCategory::Real>(121 ConvertToKind<TypeCategory::Real>(122 defaultRealKind, std::move(ix)),123 ConvertToKind<TypeCategory::Real>(124 defaultRealKind, std::move(iy)))};125 },126 [&](Expr<SomeInteger> &&ix,127 Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {128 return {AsSameKindExprs<TypeCategory::Real>(129 ConvertToKind<TypeCategory::Real>(130 defaultRealKind, std::move(ix)),131 ConvertToKind<TypeCategory::Real>(132 defaultRealKind, std::move(iy)))};133 },134 [&](Expr<SomeUnsigned> &&ix,135 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {136 return {AsSameKindExprs<TypeCategory::Real>(137 ConvertToKind<TypeCategory::Real>(138 defaultRealKind, std::move(ix)),139 ConvertToKind<TypeCategory::Real>(140 defaultRealKind, std::move(iy)))};141 },142 [&](Expr<SomeUnsigned> &&ix,143 Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {144 return {AsSameKindExprs<TypeCategory::Real>(145 ConvertToKind<TypeCategory::Real>(146 defaultRealKind, std::move(ix)),147 ConvertToKind<TypeCategory::Real>(148 defaultRealKind, std::move(iy)))};149 },150 [&](Expr<SomeInteger> &&ix,151 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {152 return {AsSameKindExprs<TypeCategory::Real>(153 ConvertTo(ry, std::move(ix)), std::move(ry))};154 },155 [&](Expr<SomeUnsigned> &&ix,156 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {157 return {AsSameKindExprs<TypeCategory::Real>(158 ConvertTo(ry, std::move(ix)), std::move(ry))};159 },160 [&](Expr<SomeReal> &&rx,161 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {162 return {AsSameKindExprs<TypeCategory::Real>(163 std::move(rx), ConvertTo(rx, std::move(iy)))};164 },165 [&](Expr<SomeReal> &&rx,166 Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {167 return {AsSameKindExprs<TypeCategory::Real>(168 std::move(rx), ConvertTo(rx, std::move(iy)))};169 },170 [&](Expr<SomeReal> &&rx,171 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {172 return {AsSameKindExprs<TypeCategory::Real>(173 std::move(rx), std::move(ry))};174 },175 [&](Expr<SomeInteger> &&ix,176 BOZLiteralConstant &&by) -> ConvertRealOperandsResult {177 return {AsSameKindExprs<TypeCategory::Real>(178 ConvertToKind<TypeCategory::Real>(179 defaultRealKind, std::move(ix)),180 ConvertToKind<TypeCategory::Real>(181 defaultRealKind, std::move(by)))};182 },183 [&](Expr<SomeUnsigned> &&ix,184 BOZLiteralConstant &&by) -> ConvertRealOperandsResult {185 return {AsSameKindExprs<TypeCategory::Real>(186 ConvertToKind<TypeCategory::Real>(187 defaultRealKind, std::move(ix)),188 ConvertToKind<TypeCategory::Real>(189 defaultRealKind, std::move(by)))};190 },191 [&](BOZLiteralConstant &&bx,192 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {193 return {AsSameKindExprs<TypeCategory::Real>(194 ConvertToKind<TypeCategory::Real>(195 defaultRealKind, std::move(bx)),196 ConvertToKind<TypeCategory::Real>(197 defaultRealKind, std::move(iy)))};198 },199 [&](BOZLiteralConstant &&bx,200 Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {201 return {AsSameKindExprs<TypeCategory::Real>(202 ConvertToKind<TypeCategory::Real>(203 defaultRealKind, std::move(bx)),204 ConvertToKind<TypeCategory::Real>(205 defaultRealKind, std::move(iy)))};206 },207 [&](Expr<SomeReal> &&rx,208 BOZLiteralConstant &&by) -> ConvertRealOperandsResult {209 return {AsSameKindExprs<TypeCategory::Real>(210 std::move(rx), ConvertTo(rx, std::move(by)))};211 },212 [&](BOZLiteralConstant &&bx,213 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {214 return {AsSameKindExprs<TypeCategory::Real>(215 ConvertTo(ry, std::move(bx)), std::move(ry))};216 },217 [&](BOZLiteralConstant &&,218 BOZLiteralConstant &&) -> ConvertRealOperandsResult {219 messages.Say("operands cannot both be BOZ"_err_en_US);220 return std::nullopt;221 },222 [&](auto &&, auto &&) -> ConvertRealOperandsResult { // C718223 messages.Say(224 "operands must be INTEGER, UNSIGNED, REAL, or BOZ"_err_en_US);225 return std::nullopt;226 },227 },228 std::move(x.u), std::move(y.u));229}230 231// Helpers for NumericOperation and its subroutines below.232static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }233 234template <TypeCategory CAT>235std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {236 return {AsGenericExpr(std::move(catExpr))};237}238template <TypeCategory CAT>239std::optional<Expr<SomeType>> Package(240 std::optional<Expr<SomeKind<CAT>>> &&catExpr) {241 if (catExpr) {242 return {AsGenericExpr(std::move(*catExpr))};243 } else {244 return std::nullopt;245 }246}247 248// Mixed REAL+INTEGER operations. REAL**INTEGER is a special case that249// does not require conversion of the exponent expression.250template <template <typename> class OPR>251std::optional<Expr<SomeType>> MixedRealLeft(252 Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {253 return Package(common::visit(254 [&](auto &&rxk) -> Expr<SomeReal> {255 using resultType = ResultType<decltype(rxk)>;256 if constexpr (std::is_same_v<OPR<resultType>, Power<resultType>>) {257 return AsCategoryExpr(258 RealToIntPower<resultType>{std::move(rxk), std::move(iy)});259 }260 // G++ 8.1.0 emits bogus warnings about missing return statements if261 // this statement is wrapped in an "else", as it should be.262 return AsCategoryExpr(OPR<resultType>{263 std::move(rxk), ConvertToType<resultType>(std::move(iy))});264 },265 std::move(rx.u)));266}267 268template <int KIND>269Expr<SomeComplex> MakeComplex(Expr<Type<TypeCategory::Real, KIND>> &&re,270 Expr<Type<TypeCategory::Real, KIND>> &&im) {271 return AsCategoryExpr(ComplexConstructor<KIND>{std::move(re), std::move(im)});272}273 274std::optional<Expr<SomeComplex>> ConstructComplex(275 parser::ContextualMessages &messages, Expr<SomeType> &&real,276 Expr<SomeType> &&imaginary, int defaultRealKind) {277 if (auto converted{ConvertRealOperands(278 messages, std::move(real), std::move(imaginary), defaultRealKind)}) {279 return {common::visit(280 [](auto &&pair) {281 return MakeComplex(std::move(pair[0]), std::move(pair[1]));282 },283 std::move(*converted))};284 }285 return std::nullopt;286}287 288std::optional<Expr<SomeComplex>> ConstructComplex(289 parser::ContextualMessages &messages, std::optional<Expr<SomeType>> &&real,290 std::optional<Expr<SomeType>> &&imaginary, int defaultRealKind) {291 if (auto parts{common::AllPresent(std::move(real), std::move(imaginary))}) {292 return ConstructComplex(messages, std::get<0>(std::move(*parts)),293 std::get<1>(std::move(*parts)), defaultRealKind);294 }295 return std::nullopt;296}297 298// Extracts the real or imaginary part of the result of a COMPLEX299// expression, when that expression is simple enough to be duplicated.300template <bool GET_IMAGINARY> struct ComplexPartExtractor {301 template <typename A> static std::optional<Expr<SomeReal>> Get(const A &) {302 return std::nullopt;303 }304 305 template <int KIND>306 static std::optional<Expr<SomeReal>> Get(307 const Parentheses<Type<TypeCategory::Complex, KIND>> &kz) {308 if (auto x{Get(kz.left())}) {309 return AsGenericExpr(AsSpecificExpr(310 Parentheses<Type<TypeCategory::Real, KIND>>{std::move(*x)}));311 } else {312 return std::nullopt;313 }314 }315 316 template <int KIND>317 static std::optional<Expr<SomeReal>> Get(318 const Negate<Type<TypeCategory::Complex, KIND>> &kz) {319 if (auto x{Get(kz.left())}) {320 return AsGenericExpr(AsSpecificExpr(321 Negate<Type<TypeCategory::Real, KIND>>{std::move(*x)}));322 } else {323 return std::nullopt;324 }325 }326 327 template <int KIND>328 static std::optional<Expr<SomeReal>> Get(329 const Convert<Type<TypeCategory::Complex, KIND>, TypeCategory::Complex>330 &kz) {331 if (auto x{Get(kz.left())}) {332 return AsGenericExpr(AsSpecificExpr(333 Convert<Type<TypeCategory::Real, KIND>, TypeCategory::Real>{334 AsGenericExpr(std::move(*x))}));335 } else {336 return std::nullopt;337 }338 }339 340 template <int KIND>341 static std::optional<Expr<SomeReal>> Get(const ComplexConstructor<KIND> &kz) {342 return GET_IMAGINARY ? Get(kz.right()) : Get(kz.left());343 }344 345 template <int KIND>346 static std::optional<Expr<SomeReal>> Get(347 const Constant<Type<TypeCategory::Complex, KIND>> &kz) {348 if (auto cz{kz.GetScalarValue()}) {349 return AsGenericExpr(350 AsSpecificExpr(GET_IMAGINARY ? cz->AIMAG() : cz->REAL()));351 } else {352 return std::nullopt;353 }354 }355 356 template <int KIND>357 static std::optional<Expr<SomeReal>> Get(358 const Designator<Type<TypeCategory::Complex, KIND>> &kz) {359 if (const auto *symbolRef{std::get_if<SymbolRef>(&kz.u)}) {360 return AsGenericExpr(AsSpecificExpr(361 Designator<Type<TypeCategory::Complex, KIND>>{ComplexPart{362 DataRef{*symbolRef},363 GET_IMAGINARY ? ComplexPart::Part::IM : ComplexPart::Part::RE}}));364 } else {365 return std::nullopt;366 }367 }368 369 template <int KIND>370 static std::optional<Expr<SomeReal>> Get(371 const Expr<Type<TypeCategory::Complex, KIND>> &kz) {372 return Get(kz.u);373 }374 375 static std::optional<Expr<SomeReal>> Get(const Expr<SomeComplex> &z) {376 return Get(z.u);377 }378};379 380// Convert REAL to COMPLEX of the same kind. Preserving the real operand kind381// and then applying complex operand promotion rules allows the result to have382// the highest precision of REAL and COMPLEX operands as required by Fortran383// 2018 10.9.1.3.384Expr<SomeComplex> PromoteRealToComplex(Expr<SomeReal> &&someX) {385 return common::visit(386 [](auto &&x) {387 using RT = ResultType<decltype(x)>;388 return AsCategoryExpr(ComplexConstructor<RT::kind>{389 std::move(x), AsExpr(Constant<RT>{Scalar<RT>{}})});390 },391 std::move(someX.u));392}393 394// Handle mixed COMPLEX+REAL (or INTEGER) operations in a better way395// than just converting the second operand to COMPLEX and performing the396// corresponding COMPLEX+COMPLEX operation.397template <template <typename> class OPR, TypeCategory RCAT>398std::optional<Expr<SomeType>> MixedComplexLeft(399 parser::ContextualMessages &messages, const Expr<SomeComplex> &zx,400 const Expr<SomeKind<RCAT>> &iry, [[maybe_unused]] int defaultRealKind) {401 if constexpr (RCAT == TypeCategory::Integer &&402 std::is_same_v<OPR<LargestReal>, Power<LargestReal>>) {403 // COMPLEX**INTEGER is a special case that doesn't convert the exponent.404 return Package(common::visit(405 [&](const auto &zxk) {406 using Ty = ResultType<decltype(zxk)>;407 return AsCategoryExpr(AsExpr(408 RealToIntPower<Ty>{common::Clone(zxk), common::Clone(iry)}));409 },410 zx.u));411 }412 std::optional<Expr<SomeReal>> zr{ComplexPartExtractor<false>{}.Get(zx)};413 std::optional<Expr<SomeReal>> zi{ComplexPartExtractor<true>{}.Get(zx)};414 if (!zr || !zi) {415 } else if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||416 std::is_same_v<OPR<LargestReal>, Subtract<LargestReal>>) {417 // (a,b) + x -> (a+x, b)418 // (a,b) - x -> (a-x, b)419 if (std::optional<Expr<SomeType>> rr{420 NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zr)),421 AsGenericExpr(common::Clone(iry)), defaultRealKind)}) {422 return Package(ConstructComplex(messages, std::move(*rr),423 AsGenericExpr(std::move(*zi)), defaultRealKind));424 }425 } else if constexpr (allowOperandDuplication &&426 (std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>> ||427 std::is_same_v<OPR<LargestReal>, Divide<LargestReal>>)) {428 // (a,b) * x -> (a*x, b*x)429 // (a,b) / x -> (a/x, b/x)430 auto copy{iry};431 auto rr{NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zr)),432 AsGenericExpr(common::Clone(iry)), defaultRealKind)};433 auto ri{NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zi)),434 AsGenericExpr(std::move(copy)), defaultRealKind)};435 if (auto parts{common::AllPresent(std::move(rr), std::move(ri))}) {436 return Package(ConstructComplex(messages, std::get<0>(std::move(*parts)),437 std::get<1>(std::move(*parts)), defaultRealKind));438 }439 }440 return std::nullopt;441}442 443// Mixed COMPLEX operations with the COMPLEX operand on the right.444// x + (a,b) -> (x+a, b)445// x - (a,b) -> (x-a, -b)446// x * (a,b) -> (x*a, x*b)447// x / (a,b) -> (x,0) / (a,b) (and **)448template <template <typename> class OPR, TypeCategory LCAT>449std::optional<Expr<SomeType>> MixedComplexRight(450 parser::ContextualMessages &messages, const Expr<SomeKind<LCAT>> &irx,451 const Expr<SomeComplex> &zy, [[maybe_unused]] int defaultRealKind) {452 if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>>) {453 // x + (a,b) -> (a,b) + x -> (a+x, b)454 return MixedComplexLeft<OPR, LCAT>(messages, zy, irx, defaultRealKind);455 } else if constexpr (allowOperandDuplication &&456 std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>>) {457 // x * (a,b) -> (a,b) * x -> (a*x, b*x)458 return MixedComplexLeft<OPR, LCAT>(messages, zy, irx, defaultRealKind);459 } else if constexpr (std::is_same_v<OPR<LargestReal>,460 Subtract<LargestReal>>) {461 // x - (a,b) -> (x-a, -b)462 std::optional<Expr<SomeReal>> zr{ComplexPartExtractor<false>{}.Get(zy)};463 std::optional<Expr<SomeReal>> zi{ComplexPartExtractor<true>{}.Get(zy)};464 if (zr && zi) {465 if (std::optional<Expr<SomeType>> rr{NumericOperation<Subtract>(messages,466 AsGenericExpr(common::Clone(irx)), AsGenericExpr(std::move(*zr)),467 defaultRealKind)}) {468 return Package(ConstructComplex(messages, std::move(*rr),469 AsGenericExpr(-std::move(*zi)), defaultRealKind));470 }471 }472 }473 return std::nullopt;474}475 476// Promotes REAL(rk) and COMPLEX(zk) operands COMPLEX(max(rk,zk))477// then combine them with an operator.478template <template <typename> class OPR, TypeCategory XCAT, TypeCategory YCAT>479Expr<SomeComplex> PromoteMixedComplexReal(480 Expr<SomeKind<XCAT>> &&x, Expr<SomeKind<YCAT>> &&y) {481 static_assert(XCAT == TypeCategory::Complex || YCAT == TypeCategory::Complex);482 static_assert(XCAT == TypeCategory::Real || YCAT == TypeCategory::Real);483 return common::visit(484 [&](const auto &kx, const auto &ky) {485 constexpr int maxKind{std::max(486 ResultType<decltype(kx)>::kind, ResultType<decltype(ky)>::kind)};487 using ZTy = Type<TypeCategory::Complex, maxKind>;488 return Expr<SomeComplex>{489 Expr<ZTy>{OPR<ZTy>{ConvertToType<ZTy>(std::move(x)),490 ConvertToType<ZTy>(std::move(y))}}};491 },492 x.u, y.u);493}494 495// N.B. When a "typeless" BOZ literal constant appears as one (not both!) of496// the operands to a dyadic operation where one is permitted, it assumes the497// type and kind of the other operand.498template <template <typename> class OPR>499std::optional<Expr<SomeType>> NumericOperation(500 parser::ContextualMessages &messages, Expr<SomeType> &&x,501 Expr<SomeType> &&y, int defaultRealKind) {502 return common::visit(503 common::visitors{504 [](Expr<SomeInteger> &&ix, Expr<SomeInteger> &&iy) {505 return Package(PromoteAndCombine<OPR, TypeCategory::Integer>(506 std::move(ix), std::move(iy)));507 },508 [](Expr<SomeReal> &&rx, Expr<SomeReal> &&ry) {509 return Package(PromoteAndCombine<OPR, TypeCategory::Real>(510 std::move(rx), std::move(ry)));511 },512 [&](Expr<SomeUnsigned> &&ix, Expr<SomeUnsigned> &&iy) {513 return Package(PromoteAndCombine<OPR, TypeCategory::Unsigned>(514 std::move(ix), std::move(iy)));515 },516 // Mixed REAL/INTEGER operations517 [](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {518 return MixedRealLeft<OPR>(std::move(rx), std::move(iy));519 },520 [](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {521 return Package(common::visit(522 [&](auto &&ryk) -> Expr<SomeReal> {523 using resultType = ResultType<decltype(ryk)>;524 return AsCategoryExpr(525 OPR<resultType>{ConvertToType<resultType>(std::move(ix)),526 std::move(ryk)});527 },528 std::move(ry.u)));529 },530 // Homogeneous and mixed COMPLEX operations531 [](Expr<SomeComplex> &&zx, Expr<SomeComplex> &&zy) {532 return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(533 std::move(zx), std::move(zy)));534 },535 [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {536 if (auto result{537 MixedComplexLeft<OPR>(messages, zx, iy, defaultRealKind)}) {538 return result;539 } else {540 return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(541 std::move(zx), ConvertTo(zx, std::move(iy))));542 }543 },544 [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {545 if (auto result{546 MixedComplexLeft<OPR>(messages, zx, ry, defaultRealKind)}) {547 return result;548 } else {549 return Package(550 PromoteMixedComplexReal<OPR>(std::move(zx), std::move(ry)));551 }552 },553 [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {554 if (auto result{MixedComplexRight<OPR>(555 messages, ix, zy, defaultRealKind)}) {556 return result;557 } else {558 return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(559 ConvertTo(zy, std::move(ix)), std::move(zy)));560 }561 },562 [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {563 if (auto result{MixedComplexRight<OPR>(564 messages, rx, zy, defaultRealKind)}) {565 return result;566 } else {567 return Package(568 PromoteMixedComplexReal<OPR>(std::move(rx), std::move(zy)));569 }570 },571 // Operations with one typeless operand572 [&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {573 return NumericOperation<OPR>(messages,574 AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),575 defaultRealKind);576 },577 [&](BOZLiteralConstant &&bx, Expr<SomeUnsigned> &&iy) {578 return NumericOperation<OPR>(messages,579 AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),580 defaultRealKind);581 },582 [&](BOZLiteralConstant &&bx, Expr<SomeReal> &&ry) {583 return NumericOperation<OPR>(messages,584 AsGenericExpr(ConvertTo(ry, std::move(bx))), std::move(y),585 defaultRealKind);586 },587 [&](Expr<SomeInteger> &&ix, BOZLiteralConstant &&by) {588 return NumericOperation<OPR>(messages, std::move(x),589 AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);590 },591 [&](Expr<SomeUnsigned> &&ix, BOZLiteralConstant &&by) {592 return NumericOperation<OPR>(messages, std::move(x),593 AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);594 },595 [&](Expr<SomeReal> &&rx, BOZLiteralConstant &&by) {596 return NumericOperation<OPR>(messages, std::move(x),597 AsGenericExpr(ConvertTo(rx, std::move(by))), defaultRealKind);598 },599 // Error cases600 [&](Expr<SomeUnsigned> &&, auto &&) {601 messages.Say("Both operands must be UNSIGNED"_err_en_US);602 return NoExpr();603 },604 [&](auto &&, Expr<SomeUnsigned> &&) {605 messages.Say("Both operands must be UNSIGNED"_err_en_US);606 return NoExpr();607 },608 [&](auto &&, auto &&) {609 messages.Say("non-numeric operands to numeric operation"_err_en_US);610 return NoExpr();611 },612 },613 std::move(x.u), std::move(y.u));614}615 616template std::optional<Expr<SomeType>> NumericOperation<Power>(617 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,618 int defaultRealKind);619template std::optional<Expr<SomeType>> NumericOperation<Multiply>(620 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,621 int defaultRealKind);622template std::optional<Expr<SomeType>> NumericOperation<Divide>(623 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,624 int defaultRealKind);625template std::optional<Expr<SomeType>> NumericOperation<Add>(626 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,627 int defaultRealKind);628template std::optional<Expr<SomeType>> NumericOperation<Subtract>(629 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,630 int defaultRealKind);631 632std::optional<Expr<SomeType>> Negation(633 parser::ContextualMessages &messages, Expr<SomeType> &&x) {634 return common::visit(635 common::visitors{636 [&](BOZLiteralConstant &&) {637 messages.Say("BOZ literal cannot be negated"_err_en_US);638 return NoExpr();639 },640 [&](NullPointer &&) {641 messages.Say("NULL() cannot be negated"_err_en_US);642 return NoExpr();643 },644 [&](ProcedureDesignator &&) {645 messages.Say("Subroutine cannot be negated"_err_en_US);646 return NoExpr();647 },648 [&](ProcedureRef &&) {649 messages.Say("Pointer to subroutine cannot be negated"_err_en_US);650 return NoExpr();651 },652 [&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },653 [&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },654 [&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },655 [&](Expr<SomeCharacter> &&) {656 messages.Say("CHARACTER cannot be negated"_err_en_US);657 return NoExpr();658 },659 [&](Expr<SomeLogical> &&) {660 messages.Say("LOGICAL cannot be negated"_err_en_US);661 return NoExpr();662 },663 [&](Expr<SomeUnsigned> &&x) { return Package(-std::move(x)); },664 [&](Expr<SomeDerived> &&) {665 messages.Say("Operand cannot be negated"_err_en_US);666 return NoExpr();667 },668 },669 std::move(x.u));670}671 672Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&x) {673 return common::visit(674 [](auto &&xk) { return AsCategoryExpr(LogicalNegation(std::move(xk))); },675 std::move(x.u));676}677 678template <TypeCategory CAT>679Expr<LogicalResult> PromoteAndRelate(680 RelationalOperator opr, Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {681 return common::visit(682 [=](auto &&xy) {683 return PackageRelation(opr, std::move(xy[0]), std::move(xy[1]));684 },685 AsSameKindExprs(std::move(x), std::move(y)));686}687 688std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,689 RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {690 return common::visit(691 common::visitors{692 [=](Expr<SomeInteger> &&ix,693 Expr<SomeInteger> &&iy) -> std::optional<Expr<LogicalResult>> {694 return PromoteAndRelate(opr, std::move(ix), std::move(iy));695 },696 [=](Expr<SomeUnsigned> &&ix,697 Expr<SomeUnsigned> &&iy) -> std::optional<Expr<LogicalResult>> {698 return PromoteAndRelate(opr, std::move(ix), std::move(iy));699 },700 [=](Expr<SomeReal> &&rx,701 Expr<SomeReal> &&ry) -> std::optional<Expr<LogicalResult>> {702 return PromoteAndRelate(opr, std::move(rx), std::move(ry));703 },704 [&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {705 return Relate(messages, opr, std::move(x),706 AsGenericExpr(ConvertTo(rx, std::move(iy))));707 },708 [&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {709 return Relate(messages, opr,710 AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));711 },712 [&](Expr<SomeComplex> &&zx,713 Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {714 if (opr == RelationalOperator::EQ ||715 opr == RelationalOperator::NE) {716 return PromoteAndRelate(opr, std::move(zx), std::move(zy));717 } else {718 messages.Say(719 "COMPLEX data may be compared only for equality"_err_en_US);720 return std::nullopt;721 }722 },723 [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {724 return Relate(messages, opr, std::move(x),725 AsGenericExpr(ConvertTo(zx, std::move(iy))));726 },727 [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {728 return Relate(messages, opr, std::move(x),729 AsGenericExpr(ConvertTo(zx, std::move(ry))));730 },731 [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {732 return Relate(messages, opr,733 AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));734 },735 [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {736 return Relate(messages, opr,737 AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));738 },739 [&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {740 return common::visit(741 [&](auto &&cxk,742 auto &&cyk) -> std::optional<Expr<LogicalResult>> {743 using Ty = ResultType<decltype(cxk)>;744 if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {745 return PackageRelation(opr, std::move(cxk), std::move(cyk));746 } else {747 messages.Say(748 "CHARACTER operands do not have same KIND"_err_en_US);749 return std::nullopt;750 }751 },752 std::move(cx.u), std::move(cy.u));753 },754 // Default case755 [&](auto &&, auto &&) {756 DIE("invalid types for relational operator");757 return std::optional<Expr<LogicalResult>>{};758 },759 },760 std::move(x.u), std::move(y.u));761}762 763Expr<SomeLogical> BinaryLogicalOperation(764 LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {765 CHECK(opr != LogicalOperator::Not);766 return common::visit(767 [=](auto &&xy) {768 using Ty = ResultType<decltype(xy[0])>;769 return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(770 opr, std::move(xy[0]), std::move(xy[1]))};771 },772 AsSameKindExprs(std::move(x), std::move(y)));773}774 775template <TypeCategory TO>776std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {777 static_assert(common::IsNumericTypeCategory(TO));778 return common::visit(779 [=](auto &&cx) -> std::optional<Expr<SomeType>> {780 using cxType = std::decay_t<decltype(cx)>;781 if constexpr (!common::HasMember<cxType, TypelessExpression>) {782 if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {783 return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};784 }785 }786 return std::nullopt;787 },788 std::move(x.u));789}790 791std::optional<Expr<SomeType>> ConvertToType(792 const DynamicType &type, Expr<SomeType> &&x) {793 if (type.IsTypelessIntrinsicArgument()) {794 return std::nullopt;795 }796 switch (type.category()) {797 case TypeCategory::Integer:798 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {799 // Extension to C7109: allow BOZ literals to appear in integer contexts800 // when the type is unambiguous.801 return Expr<SomeType>{802 ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};803 }804 return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));805 case TypeCategory::Unsigned:806 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {807 return Expr<SomeType>{808 ConvertToKind<TypeCategory::Unsigned>(type.kind(), std::move(*boz))};809 }810 if (auto *cx{UnwrapExpr<Expr<SomeUnsigned>>(x)}) {811 return Expr<SomeType>{812 ConvertToKind<TypeCategory::Unsigned>(type.kind(), std::move(*cx))};813 }814 break;815 case TypeCategory::Real:816 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {817 return Expr<SomeType>{818 ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};819 }820 return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));821 case TypeCategory::Complex:822 return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));823 case TypeCategory::Character:824 if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {825 auto converted{826 ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};827 if (auto length{type.GetCharLength()}) {828 converted = common::visit(829 [&](auto &&x) {830 using CharacterType = ResultType<decltype(x)>;831 return Expr<SomeCharacter>{832 Expr<CharacterType>{SetLength<CharacterType::kind>{833 std::move(x), std::move(*length)}}};834 },835 std::move(converted.u));836 }837 return Expr<SomeType>{std::move(converted)};838 }839 break;840 case TypeCategory::Logical:841 if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {842 return Expr<SomeType>{843 ConvertToKind<TypeCategory::Logical>(type.kind(), std::move(*cx))};844 }845 break;846 case TypeCategory::Derived:847 if (auto fromType{x.GetType()}) {848 if (type.IsTkCompatibleWith(*fromType)) {849 // "x" could be assigned or passed to "type", or appear in a850 // structure constructor as a value for a component with "type"851 return std::move(x);852 }853 }854 break;855 }856 return std::nullopt;857}858 859std::optional<Expr<SomeType>> ConvertToType(860 const DynamicType &to, std::optional<Expr<SomeType>> &&x) {861 if (x) {862 return ConvertToType(to, std::move(*x));863 } else {864 return std::nullopt;865 }866}867 868std::optional<Expr<SomeType>> ConvertToType(869 const Symbol &symbol, Expr<SomeType> &&x) {870 if (auto symType{DynamicType::From(symbol)}) {871 return ConvertToType(*symType, std::move(x));872 }873 return std::nullopt;874}875 876std::optional<Expr<SomeType>> ConvertToType(877 const Symbol &to, std::optional<Expr<SomeType>> &&x) {878 if (x) {879 return ConvertToType(to, std::move(*x));880 } else {881 return std::nullopt;882 }883}884 885int GetCorank(const ActualArgument &arg) {886 const auto *expr{arg.UnwrapExpr()};887 return GetCorank(*expr);888}889 890bool IsProcedureDesignator(const Expr<SomeType> &expr) {891 return std::holds_alternative<ProcedureDesignator>(expr.u);892}893bool IsFunctionDesignator(const Expr<SomeType> &expr) {894 const auto *designator{std::get_if<ProcedureDesignator>(&expr.u)};895 return designator && designator->GetType().has_value();896}897 898bool IsPointer(const Expr<SomeType> &expr) {899 return IsObjectPointer(expr) || IsProcedurePointer(expr);900}901 902bool IsProcedurePointer(const Expr<SomeType> &expr) {903 if (IsNullProcedurePointer(&expr)) {904 return true;905 } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {906 if (const Symbol * proc{funcRef->proc().GetSymbol()}) {907 const Symbol *result{FindFunctionResult(*proc)};908 return result && IsProcedurePointer(*result);909 } else {910 return false;911 }912 } else if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {913 return IsProcedurePointer(proc->GetSymbol());914 } else {915 return false;916 }917}918 919bool IsProcedure(const Expr<SomeType> &expr) {920 return IsProcedureDesignator(expr) || IsProcedurePointer(expr);921}922 923bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {924 return common::visit(common::visitors{925 [](const NullPointer &) { return true; },926 [](const ProcedureDesignator &) { return true; },927 [](const ProcedureRef &) { return true; },928 [&](const auto &) {929 const Symbol *last{GetLastSymbol(expr)};930 return last && IsProcedurePointer(*last);931 },932 },933 expr.u);934}935 936bool IsObjectPointer(const Expr<SomeType> &expr) {937 if (IsNullObjectPointer(&expr)) {938 return true;939 } else if (IsProcedurePointerTarget(expr)) {940 return false;941 } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {942 return IsVariable(*funcRef);943 } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {944 return IsPointer(symbol->GetUltimate());945 } else {946 return false;947 }948}949 950// IsNullPointer() & variations951 952template <bool IS_PROC_PTR> struct IsNullPointerHelper {953 template <typename A> bool operator()(const A &) const { return false; }954 bool operator()(const ProcedureRef &call) const {955 if constexpr (IS_PROC_PTR) {956 const auto *intrinsic{call.proc().GetSpecificIntrinsic()};957 return intrinsic &&958 intrinsic->characteristics.value().attrs.test(959 characteristics::Procedure::Attr::NullPointer);960 } else {961 return false;962 }963 }964 template <typename T> bool operator()(const FunctionRef<T> &call) const {965 if constexpr (IS_PROC_PTR) {966 return false;967 } else {968 const auto *intrinsic{call.proc().GetSpecificIntrinsic()};969 return intrinsic &&970 intrinsic->characteristics.value().attrs.test(971 characteristics::Procedure::Attr::NullPointer);972 }973 }974 template <typename T> bool operator()(const Designator<T> &x) const {975 if (const auto *component{std::get_if<Component>(&x.u)}) {976 if (const auto *baseSym{std::get_if<SymbolRef>(&component->base().u)}) {977 const Symbol &base{**baseSym};978 if (const auto *object{979 base.detailsIf<semantics::ObjectEntityDetails>()}) {980 // TODO: nested component and array references981 if (IsNamedConstant(base) && object->init()) {982 if (auto structCons{983 GetScalarConstantValue<SomeDerived>(*object->init())}) {984 auto iter{structCons->values().find(component->GetLastSymbol())};985 if (iter != structCons->values().end()) {986 return (*this)(iter->second.value());987 }988 }989 }990 }991 }992 }993 return false;994 }995 bool operator()(const NullPointer &) const { return true; }996 template <typename T> bool operator()(const Parentheses<T> &x) const {997 return (*this)(x.left());998 }999 template <typename T> bool operator()(const Expr<T> &x) const {1000 return common::visit(*this, x.u);1001 }1002};1003 1004bool IsNullObjectPointer(const Expr<SomeType> *expr) {1005 return expr && IsNullPointerHelper<false>{}(*expr);1006}1007 1008bool IsNullProcedurePointer(const Expr<SomeType> *expr) {1009 return expr && IsNullPointerHelper<true>{}(*expr);1010}1011 1012bool IsNullPointer(const Expr<SomeType> *expr) {1013 return IsNullObjectPointer(expr) || IsNullProcedurePointer(expr);1014}1015 1016bool IsBareNullPointer(const Expr<SomeType> *expr) {1017 return expr && std::holds_alternative<NullPointer>(expr->u);1018}1019 1020struct IsNullAllocatableHelper {1021 template <typename A> bool operator()(const A &) const { return false; }1022 template <typename T> bool operator()(const FunctionRef<T> &call) const {1023 const auto *intrinsic{call.proc().GetSpecificIntrinsic()};1024 return intrinsic &&1025 intrinsic->characteristics.value().attrs.test(1026 characteristics::Procedure::Attr::NullAllocatable);1027 }1028 template <typename T> bool operator()(const Parentheses<T> &x) const {1029 return (*this)(x.left());1030 }1031 template <typename T> bool operator()(const Expr<T> &x) const {1032 return common::visit(*this, x.u);1033 }1034};1035 1036bool IsNullAllocatable(const Expr<SomeType> *x) {1037 return x && IsNullAllocatableHelper{}(*x);1038}1039 1040bool IsNullPointerOrAllocatable(const Expr<SomeType> *x) {1041 return IsNullPointer(x) || IsNullAllocatable(x);1042}1043 1044// GetSymbolVector()1045auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {1046 if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {1047 if (IsVariable(details->expr()) && !UnwrapProcedureRef(*details->expr())) {1048 // associate(x => variable that is not a pointer returned by a function)1049 return (*this)(details->expr());1050 }1051 }1052 return {x.GetUltimate()};1053}1054auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {1055 Result result{(*this)(x.base())};1056 result.emplace_back(x.GetLastSymbol());1057 return result;1058}1059auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {1060 return GetSymbolVector(x.base());1061}1062auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {1063 return GetSymbolVector(x.base());1064}1065 1066const Symbol *GetLastTarget(const SymbolVector &symbols) {1067 auto end{std::crend(symbols)};1068 // N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.1069 auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {1070 return x.attrs().HasAny(1071 {semantics::Attr::POINTER, semantics::Attr::TARGET});1072 })};1073 return iter == end ? nullptr : &**iter;1074}1075 1076struct CollectSymbolsHelper1077 : public SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet> {1078 using Base = SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet>;1079 CollectSymbolsHelper() : Base{*this} {}1080 using Base::operator();1081 semantics::UnorderedSymbolSet operator()(const Symbol &symbol) const {1082 return {symbol};1083 }1084};1085template <typename A> semantics::UnorderedSymbolSet CollectSymbols(const A &x) {1086 return CollectSymbolsHelper{}(x);1087}1088template semantics::UnorderedSymbolSet CollectSymbols(const Expr<SomeType> &);1089template semantics::UnorderedSymbolSet CollectSymbols(1090 const Expr<SomeInteger> &);1091template semantics::UnorderedSymbolSet CollectSymbols(1092 const Expr<SubscriptInteger> &);1093 1094struct CollectCudaSymbolsHelper : public SetTraverse<CollectCudaSymbolsHelper,1095 semantics::UnorderedSymbolSet> {1096 using Base =1097 SetTraverse<CollectCudaSymbolsHelper, semantics::UnorderedSymbolSet>;1098 CollectCudaSymbolsHelper() : Base{*this} {}1099 using Base::operator();1100 semantics::UnorderedSymbolSet operator()(const Symbol &symbol) const {1101 return {symbol.GetUltimate()};1102 }1103 // Overload some of the operator() to filter out the symbols that are not1104 // of interest for CUDA data transfer logic.1105 semantics::UnorderedSymbolSet operator()(const DescriptorInquiry &) const {1106 return {};1107 }1108 semantics::UnorderedSymbolSet operator()(const Subscript &) const {1109 return {};1110 }1111 semantics::UnorderedSymbolSet operator()(const ProcedureRef &) const {1112 return {};1113 }1114};1115template <typename A>1116semantics::UnorderedSymbolSet CollectCudaSymbols(const A &x) {1117 return CollectCudaSymbolsHelper{}(x);1118}1119template semantics::UnorderedSymbolSet CollectCudaSymbols(1120 const Expr<SomeType> &);1121template semantics::UnorderedSymbolSet CollectCudaSymbols(1122 const Expr<SomeInteger> &);1123template semantics::UnorderedSymbolSet CollectCudaSymbols(1124 const Expr<SubscriptInteger> &);1125 1126bool HasCUDAImplicitTransfer(const Expr<SomeType> &expr) {1127 semantics::UnorderedSymbolSet hostSymbols;1128 semantics::UnorderedSymbolSet deviceSymbols;1129 semantics::UnorderedSymbolSet cudaSymbols{CollectCudaSymbols(expr)};1130 1131 SymbolVector symbols{GetSymbolVector(expr)};1132 std::reverse(symbols.begin(), symbols.end());1133 bool skipNext{false};1134 for (const Symbol &sym : symbols) {1135 if (cudaSymbols.find(sym) != cudaSymbols.end()) {1136 bool isComponent{sym.owner().IsDerivedType()};1137 bool skipComponent{false};1138 if (!skipNext) {1139 if (IsCUDADeviceSymbol(sym)) {1140 deviceSymbols.insert(sym);1141 } else if (isComponent) {1142 skipComponent = true; // Component is not device. Look on the base.1143 } else {1144 hostSymbols.insert(sym);1145 }1146 }1147 skipNext = isComponent && !skipComponent;1148 } else {1149 skipNext = false;1150 }1151 }1152 bool hasConstant{HasConstant(expr)};1153 return (hasConstant || (hostSymbols.size() > 0)) && deviceSymbols.size() > 0;1154}1155 1156bool IsCUDADeviceSymbol(const Symbol &sym) {1157 if (const auto *details =1158 sym.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()) {1159 return details->cudaDataAttr() &&1160 *details->cudaDataAttr() != common::CUDADataAttr::Pinned;1161 } else if (const auto *details =1162 sym.GetUltimate().detailsIf<semantics::AssocEntityDetails>()) {1163 return GetNbOfCUDADeviceSymbols(details->expr()) > 0;1164 }1165 return false;1166}1167 1168// HasVectorSubscript()1169struct HasVectorSubscriptHelper1170 : public AnyTraverse<HasVectorSubscriptHelper, bool,1171 /*TraverseAssocEntityDetails=*/false> {1172 using Base = AnyTraverse<HasVectorSubscriptHelper, bool, false>;1173 HasVectorSubscriptHelper() : Base{*this} {}1174 using Base::operator();1175 bool operator()(const Subscript &ss) const {1176 return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;1177 }1178 bool operator()(const ProcedureRef &) const {1179 return false; // don't descend into function call arguments1180 }1181};1182 1183bool HasVectorSubscript(const Expr<SomeType> &expr) {1184 return HasVectorSubscriptHelper{}(expr);1185}1186 1187bool HasVectorSubscript(const ActualArgument &actual) {1188 auto expr{actual.UnwrapExpr()};1189 return expr && HasVectorSubscript(*expr);1190}1191 1192bool IsArraySection(const Expr<SomeType> &expr) {1193 return expr.Rank() > 0 && IsVariable(expr) && !UnwrapWholeSymbolDataRef(expr);1194}1195 1196// HasConstant()1197struct HasConstantHelper : public AnyTraverse<HasConstantHelper, bool,1198 /*TraverseAssocEntityDetails=*/false> {1199 using Base = AnyTraverse<HasConstantHelper, bool, false>;1200 HasConstantHelper() : Base{*this} {}1201 using Base::operator();1202 template <typename T> bool operator()(const Constant<T> &) const {1203 return true;1204 }1205 // Only look for constant not in subscript.1206 bool operator()(const Subscript &) const { return false; }1207};1208 1209bool HasConstant(const Expr<SomeType> &expr) {1210 return HasConstantHelper{}(expr);1211}1212 1213// HasStructureComponent()1214struct HasStructureComponentHelper1215 : public AnyTraverse<HasStructureComponentHelper, bool, false> {1216 using Base = AnyTraverse<HasStructureComponentHelper, bool, false>;1217 HasStructureComponentHelper() : Base(*this) {}1218 using Base::operator();1219 1220 bool operator()(const Component &) const { return true; }1221};1222 1223bool HasStructureComponent(const Expr<SomeType> &expr) {1224 return HasStructureComponentHelper{}(expr);1225}1226 1227parser::Message *AttachDeclaration(1228 parser::Message &message, const Symbol &symbol) {1229 const Symbol *unhosted{&symbol};1230 while (1231 const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {1232 unhosted = &assoc->symbol();1233 }1234 if (const auto *use{symbol.detailsIf<semantics::UseDetails>()}) {1235 message.Attach(use->location(),1236 "'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),1237 unhosted->name(), GetUsedModule(*use).name());1238 } else if (const auto *common{1239 unhosted->detailsIf<semantics::CommonBlockDetails>()}) {1240 parser::CharBlock at{unhosted->name()};1241 if (at.empty()) { // blank COMMON, with or without //1242 at = common->sourceLocation();1243 }1244 if (!at.empty()) {1245 message.Attach(at, "Declaration of /%s/"_en_US, unhosted->name());1246 }1247 } else {1248 message.Attach(1249 unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());1250 }1251 if (const auto *binding{1252 unhosted->detailsIf<semantics::ProcBindingDetails>()}) {1253 if (!symbol.attrs().test(semantics::Attr::DEFERRED) &&1254 binding->symbol().name() != symbol.name()) {1255 message.Attach(binding->symbol().name(),1256 "Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(),1257 symbol.owner().GetName().value(), binding->symbol().name());1258 }1259 }1260 return &message;1261}1262 1263parser::Message *AttachDeclaration(1264 parser::Message *message, const Symbol &symbol) {1265 return message ? AttachDeclaration(*message, symbol) : nullptr;1266}1267 1268class FindImpureCallHelper1269 : public AnyTraverse<FindImpureCallHelper, std::optional<std::string>,1270 /*TraverseAssocEntityDetails=*/false> {1271 using Result = std::optional<std::string>;1272 using Base = AnyTraverse<FindImpureCallHelper, Result, false>;1273 1274public:1275 explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}1276 using Base::operator();1277 Result operator()(const ProcedureRef &call) const {1278 if (auto chars{characteristics::Procedure::Characterize(1279 call.proc(), context_, /*emitError=*/false)}) {1280 if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {1281 return (*this)(call.arguments());1282 }1283 }1284 return call.proc().GetName();1285 }1286 1287private:1288 FoldingContext &context_;1289};1290 1291std::optional<std::string> FindImpureCall(1292 FoldingContext &context, const Expr<SomeType> &expr) {1293 return FindImpureCallHelper{context}(expr);1294}1295std::optional<std::string> FindImpureCall(1296 FoldingContext &context, const ProcedureRef &proc) {1297 return FindImpureCallHelper{context}(proc);1298}1299 1300// Common handling for procedure pointer compatibility of left- and right-hand1301// sides. Returns nullopt if they're compatible. Otherwise, it returns a1302// message that needs to be augmented by the names of the left and right sides1303// and the content of the "whyNotCompatible" string.1304std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,1305 const std::optional<characteristics::Procedure> &lhsProcedure,1306 const characteristics::Procedure *rhsProcedure,1307 const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,1308 std::optional<std::string> &warning, bool ignoreImplicitVsExplicit) {1309 std::optional<parser::MessageFixedText> msg;1310 if (!lhsProcedure) {1311 msg = "In assignment to object %s, the target '%s' is a procedure"1312 " designator"_err_en_US;1313 } else if (!rhsProcedure) {1314 msg = "In assignment to procedure %s, the characteristics of the target"1315 " procedure '%s' could not be determined"_err_en_US;1316 } else if (!isCall && lhsProcedure->functionResult &&1317 rhsProcedure->functionResult &&1318 !lhsProcedure->functionResult->IsCompatibleWith(1319 *rhsProcedure->functionResult, &whyNotCompatible)) {1320 msg =1321 "Function %s associated with incompatible function designator '%s': %s"_err_en_US;1322 } else if (lhsProcedure->IsCompatibleWith(*rhsProcedure,1323 ignoreImplicitVsExplicit, &whyNotCompatible, specificIntrinsic,1324 &warning)) {1325 // OK1326 } else if (isCall) {1327 msg = "Procedure %s associated with result of reference to function '%s'"1328 " that is an incompatible procedure pointer: %s"_err_en_US;1329 } else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {1330 msg = "PURE procedure %s may not be associated with non-PURE"1331 " procedure designator '%s'"_err_en_US;1332 } else if (lhsProcedure->IsFunction() && rhsProcedure->IsSubroutine()) {1333 msg = "Function %s may not be associated with subroutine"1334 " designator '%s'"_err_en_US;1335 } else if (lhsProcedure->IsSubroutine() && rhsProcedure->IsFunction()) {1336 msg = "Subroutine %s may not be associated with function"1337 " designator '%s'"_err_en_US;1338 } else if (lhsProcedure->HasExplicitInterface() &&1339 !rhsProcedure->HasExplicitInterface()) {1340 // Section 10.2.2.4, paragraph 3 prohibits associating a procedure pointer1341 // that has an explicit interface with a procedure whose characteristics1342 // don't match. That's the case if the target procedure has an implicit1343 // interface. But this case is allowed by several other compilers as long1344 // as the explicit interface can be called via an implicit interface.1345 if (!lhsProcedure->CanBeCalledViaImplicitInterface()) {1346 msg = "Procedure %s with explicit interface that cannot be called via "1347 "an implicit interface cannot be associated with procedure "1348 "designator with an implicit interface"_err_en_US;1349 }1350 } else if (!lhsProcedure->HasExplicitInterface() &&1351 rhsProcedure->HasExplicitInterface()) {1352 // OK if the target can be called via an implicit interface1353 if (!rhsProcedure->CanBeCalledViaImplicitInterface() &&1354 !specificIntrinsic) {1355 msg = "Procedure %s with implicit interface may not be associated "1356 "with procedure designator '%s' with explicit interface that "1357 "cannot be called via an implicit interface"_err_en_US;1358 }1359 } else {1360 msg = "Procedure %s associated with incompatible procedure"1361 " designator '%s': %s"_err_en_US;1362 }1363 return msg;1364}1365 1366const Symbol *UnwrapWholeSymbolDataRef(const DataRef &dataRef) {1367 const SymbolRef *p{std::get_if<SymbolRef>(&dataRef.u)};1368 return p ? &p->get() : nullptr;1369}1370 1371const Symbol *UnwrapWholeSymbolDataRef(const std::optional<DataRef> &dataRef) {1372 return dataRef ? UnwrapWholeSymbolDataRef(*dataRef) : nullptr;1373}1374 1375const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &dataRef) {1376 if (const Component * c{std::get_if<Component>(&dataRef.u)}) {1377 return c->base().Rank() == 0 ? &c->GetLastSymbol() : nullptr;1378 } else {1379 return UnwrapWholeSymbolDataRef(dataRef);1380 }1381}1382 1383const Symbol *UnwrapWholeSymbolOrComponentDataRef(1384 const std::optional<DataRef> &dataRef) {1385 return dataRef ? UnwrapWholeSymbolOrComponentDataRef(*dataRef) : nullptr;1386}1387 1388const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &dataRef) {1389 if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef.u)}) {1390 return UnwrapWholeSymbolOrComponentOrCoarrayRef(c->base());1391 } else {1392 return UnwrapWholeSymbolOrComponentDataRef(dataRef);1393 }1394}1395 1396const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(1397 const std::optional<DataRef> &dataRef) {1398 return dataRef ? UnwrapWholeSymbolOrComponentOrCoarrayRef(*dataRef) : nullptr;1399}1400 1401// GetLastPointerSymbol()1402static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {1403 return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;1404}1405static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) {1406 return GetLastPointerSymbol(*symbol);1407}1408static const Symbol *GetLastPointerSymbol(const Component &x) {1409 const Symbol &c{x.GetLastSymbol()};1410 return IsPointer(c) ? &c : GetLastPointerSymbol(x.base());1411}1412static const Symbol *GetLastPointerSymbol(const NamedEntity &x) {1413 const auto *c{x.UnwrapComponent()};1414 return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol());1415}1416static const Symbol *GetLastPointerSymbol(const ArrayRef &x) {1417 return GetLastPointerSymbol(x.base());1418}1419static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) {1420 return nullptr;1421}1422const Symbol *GetLastPointerSymbol(const DataRef &x) {1423 return common::visit(1424 [](const auto &y) { return GetLastPointerSymbol(y); }, x.u);1425}1426 1427template <TypeCategory TO, TypeCategory FROM>1428static std::optional<Expr<SomeType>> DataConstantConversionHelper(1429 FoldingContext &context, const DynamicType &toType,1430 const Expr<SomeType> &expr) {1431 if (!common::IsValidKindOfIntrinsicType(FROM, toType.kind())) {1432 return std::nullopt;1433 }1434 DynamicType sizedType{FROM, toType.kind()};1435 if (auto sized{1436 Fold(context, ConvertToType(sizedType, Expr<SomeType>{expr}))}) {1437 if (const auto *someExpr{UnwrapExpr<Expr<SomeKind<FROM>>>(*sized)}) {1438 return common::visit(1439 [](const auto &w) -> std::optional<Expr<SomeType>> {1440 using FromType = ResultType<decltype(w)>;1441 static constexpr int kind{FromType::kind};1442 if constexpr (IsValidKindOfIntrinsicType(TO, kind)) {1443 if (const auto *fromConst{UnwrapExpr<Constant<FromType>>(w)}) {1444 using FromWordType = typename FromType::Scalar;1445 using LogicalType = value::Logical<FromWordType::bits>;1446 using ElementType =1447 std::conditional_t<TO == TypeCategory::Logical, LogicalType,1448 typename LogicalType::Word>;1449 std::vector<ElementType> values;1450 auto at{fromConst->lbounds()};1451 auto shape{fromConst->shape()};1452 for (auto n{GetSize(shape)}; n-- > 0;1453 fromConst->IncrementSubscripts(at)) {1454 auto elt{fromConst->At(at)};1455 if constexpr (TO == TypeCategory::Logical) {1456 values.emplace_back(std::move(elt));1457 } else {1458 values.emplace_back(elt.word());1459 }1460 }1461 return {AsGenericExpr(AsExpr(Constant<Type<TO, kind>>{1462 std::move(values), std::move(shape)}))};1463 }1464 }1465 return std::nullopt;1466 },1467 someExpr->u);1468 }1469 }1470 return std::nullopt;1471}1472 1473std::optional<Expr<SomeType>> DataConstantConversionExtension(1474 FoldingContext &context, const DynamicType &toType,1475 const Expr<SomeType> &expr0) {1476 Expr<SomeType> expr{Fold(context, Expr<SomeType>{expr0})};1477 if (!IsActuallyConstant(expr)) {1478 return std::nullopt;1479 }1480 if (auto fromType{expr.GetType()}) {1481 if (toType.category() == TypeCategory::Logical &&1482 fromType->category() == TypeCategory::Integer) {1483 return DataConstantConversionHelper<TypeCategory::Logical,1484 TypeCategory::Integer>(context, toType, expr);1485 }1486 if (toType.category() == TypeCategory::Integer &&1487 fromType->category() == TypeCategory::Logical) {1488 return DataConstantConversionHelper<TypeCategory::Integer,1489 TypeCategory::Logical>(context, toType, expr);1490 }1491 }1492 return std::nullopt;1493}1494 1495bool IsAllocatableOrPointerObject(const Expr<SomeType> &expr) {1496 const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};1497 return (sym &&1498 semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||1499 evaluate::IsObjectPointer(expr) || evaluate::IsNullAllocatable(&expr);1500}1501 1502bool IsAllocatableDesignator(const Expr<SomeType> &expr) {1503 // Allocatable sub-objects are not themselves allocatable (9.5.3.1 NOTE 2).1504 if (const semantics::Symbol *1505 sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) {1506 return semantics::IsAllocatable(sym->GetUltimate());1507 }1508 return false;1509}1510 1511bool MayBePassedAsAbsentOptional(const Expr<SomeType> &expr) {1512 const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};1513 // 15.5.2.12 1. is pretty clear that an unallocated allocatable/pointer actual1514 // may be passed to a non-allocatable/non-pointer optional dummy. Note that1515 // other compilers (like nag, nvfortran, ifort, gfortran and xlf) seems to1516 // ignore this point in intrinsic contexts (e.g CMPLX argument).1517 return (sym && semantics::IsOptional(*sym)) ||1518 IsAllocatableOrPointerObject(expr);1519}1520 1521std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,1522 const Expr<SomeType> &expr, const DynamicType &type) {1523 if (std::optional<std::string> chValue{GetScalarConstantValue<Ascii>(expr)}) {1524 // Pad on the right with spaces when short, truncate the right if long.1525 auto bytes{static_cast<std::size_t>(1526 ToInt64(type.MeasureSizeInBytes(context, false)).value())};1527 BOZLiteralConstant bits{0};1528 for (std::size_t j{0}; j < bytes; ++j) {1529 auto idx{isHostLittleEndian ? j : bytes - j - 1};1530 char ch{idx >= chValue->size() ? ' ' : chValue->at(idx)};1531 BOZLiteralConstant chBOZ{static_cast<unsigned char>(ch)};1532 bits = bits.IOR(chBOZ.SHIFTL(8 * j));1533 }1534 return ConvertToType(type, Expr<SomeType>{bits});1535 } else {1536 return std::nullopt;1537 }1538}1539 1540// Extracts a whole symbol being used as a bound of a dummy argument,1541// possibly wrapped with parentheses or MAX(0, ...).1542// Works with any integer expression.1543template <typename T> const Symbol *GetBoundSymbol(const Expr<T> &);1544template <int KIND>1545const Symbol *GetBoundSymbol(1546 const Expr<Type<TypeCategory::Integer, KIND>> &expr) {1547 using T = Type<TypeCategory::Integer, KIND>;1548 return common::visit(1549 common::visitors{1550 [](const Extremum<T> &max) -> const Symbol * {1551 if (max.ordering == Ordering::Greater) {1552 if (auto zero{ToInt64(max.left())}; zero && *zero == 0) {1553 return GetBoundSymbol(max.right());1554 }1555 }1556 return nullptr;1557 },1558 [](const Parentheses<T> &x) { return GetBoundSymbol(x.left()); },1559 [](const Designator<T> &x) -> const Symbol * {1560 if (const auto *ref{std::get_if<SymbolRef>(&x.u)}) {1561 return &**ref;1562 }1563 return nullptr;1564 },1565 [](const Convert<T, TypeCategory::Integer> &x) {1566 return common::visit(1567 [](const auto &y) -> const Symbol * {1568 using yType = std::decay_t<decltype(y)>;1569 using yResult = typename yType::Result;1570 if constexpr (yResult::kind <= KIND) {1571 return GetBoundSymbol(y);1572 } else {1573 return nullptr;1574 }1575 },1576 x.left().u);1577 },1578 [](const auto &) -> const Symbol * { return nullptr; },1579 },1580 expr.u);1581}1582template <>1583const Symbol *GetBoundSymbol<SomeInteger>(const Expr<SomeInteger> &expr) {1584 return common::visit(1585 [](const auto &kindExpr) { return GetBoundSymbol(kindExpr); }, expr.u);1586}1587 1588template <typename T>1589std::optional<bool> AreEquivalentInInterface(1590 const Expr<T> &x, const Expr<T> &y) {1591 auto xVal{ToInt64(x)};1592 auto yVal{ToInt64(y)};1593 if (xVal && yVal) {1594 return *xVal == *yVal;1595 } else if (xVal || yVal) {1596 return false;1597 }1598 const Symbol *xSym{GetBoundSymbol(x)};1599 const Symbol *ySym{GetBoundSymbol(y)};1600 if (xSym && ySym) {1601 if (&xSym->GetUltimate() == &ySym->GetUltimate()) {1602 return true; // USE/host associated same symbol1603 }1604 auto xNum{semantics::GetDummyArgumentNumber(xSym)};1605 auto yNum{semantics::GetDummyArgumentNumber(ySym)};1606 if (xNum && yNum) {1607 if (*xNum == *yNum) {1608 auto xType{DynamicType::From(*xSym)};1609 auto yType{DynamicType::From(*ySym)};1610 return xType && yType && xType->IsEquivalentTo(*yType);1611 }1612 }1613 return false;1614 } else if (xSym || ySym) {1615 return false;1616 }1617 // Neither expression is an integer constant or a whole symbol.1618 if (x == y) {1619 return true;1620 } else {1621 return std::nullopt; // not sure1622 }1623}1624template std::optional<bool> AreEquivalentInInterface<SubscriptInteger>(1625 const Expr<SubscriptInteger> &, const Expr<SubscriptInteger> &);1626template std::optional<bool> AreEquivalentInInterface<SomeInteger>(1627 const Expr<SomeInteger> &, const Expr<SomeInteger> &);1628 1629bool CheckForCoindexedObject(parser::ContextualMessages &messages,1630 const std::optional<ActualArgument> &arg, const std::string &procName,1631 const std::string &argName) {1632 if (arg && ExtractCoarrayRef(arg->UnwrapExpr())) {1633 messages.Say(arg->sourceLocation(),1634 "'%s' argument to '%s' may not be a coindexed object"_err_en_US,1635 argName, procName);1636 return false;1637 } else {1638 return true;1639 }1640}1641 1642bool CheckForSymbolMatch(const Expr<SomeType> *lhs, const Expr<SomeType> *rhs) {1643 if (lhs && rhs) {1644 if (SymbolVector lhsSymbols{GetSymbolVector(*lhs)}; !lhsSymbols.empty()) {1645 const Symbol &first{*lhsSymbols.front()};1646 for (const Symbol &symbol : GetSymbolVector(*rhs)) {1647 if (first == symbol) {1648 return true;1649 }1650 }1651 }1652 }1653 return false;1654}1655 1656namespace operation {1657template <typename T> Expr<SomeType> AsSomeExpr(const T &x) {1658 return AsGenericExpr(common::Clone(x));1659}1660 1661template <bool IgnoreResizingConverts>1662struct ArgumentExtractor1663 : public Traverse<ArgumentExtractor<IgnoreResizingConverts>,1664 std::pair<operation::Operator, std::vector<Expr<SomeType>>>, false> {1665 using Arguments = std::vector<Expr<SomeType>>;1666 using Result = std::pair<operation::Operator, Arguments>;1667 using Base =1668 Traverse<ArgumentExtractor<IgnoreResizingConverts>, Result, false>;1669 static constexpr auto IgnoreResizes{IgnoreResizingConverts};1670 static constexpr auto Logical{common::TypeCategory::Logical};1671 ArgumentExtractor() : Base(*this) {}1672 1673 Result Default() const { return {}; }1674 1675 using Base::operator();1676 1677 template <int Kind>1678 Result operator()(const Constant<Type<Logical, Kind>> &x) const {1679 if (const auto &val{x.GetScalarValue()}) {1680 return val->IsTrue()1681 ? std::make_pair(operation::Operator::True, Arguments{})1682 : std::make_pair(operation::Operator::False, Arguments{});1683 }1684 return Default();1685 }1686 1687 template <typename R> Result operator()(const FunctionRef<R> &x) const {1688 Result result{operation::OperationCode(x.proc()), {}};1689 for (size_t i{0}, e{x.arguments().size()}; i != e; ++i) {1690 if (auto *e{x.UnwrapArgExpr(i)}) {1691 result.second.push_back(*e);1692 }1693 }1694 return result;1695 }1696 1697 template <typename D, typename R, typename... Os>1698 Result operator()(const Operation<D, R, Os...> &x) const {1699 if constexpr (std::is_same_v<D, Parentheses<R>>) {1700 // Ignore top-level parentheses.1701 return (*this)(x.template operand<0>());1702 }1703 if constexpr (IgnoreResizes && std::is_same_v<D, Convert<R, R::category>>) {1704 // Ignore conversions within the same category.1705 // Atomic operations on int(kind=1) may be implicitly widened1706 // to int(kind=4) for example.1707 return (*this)(x.template operand<0>());1708 } else {1709 return std::make_pair(operation::OperationCode(x.derived()),1710 OperationArgs(x, std::index_sequence_for<Os...>{}));1711 }1712 }1713 1714 template <typename T> Result operator()(const Designator<T> &x) const {1715 return {operation::OperationCode(x), {AsSomeExpr(x)}};1716 }1717 1718 template <typename T> Result operator()(const Constant<T> &x) const {1719 return {operation::OperationCode(x), {AsSomeExpr(x)}};1720 }1721 1722 template <typename... Rs>1723 Result Combine(Result &&result, Rs &&...results) const {1724 // There shouldn't be any combining needed, since we're stopping the1725 // traversal at the top-level operation, but implement one that picks1726 // the first non-empty result.1727 if constexpr (sizeof...(Rs) == 0) {1728 return std::move(result);1729 } else {1730 if (!result.second.empty()) {1731 return std::move(result);1732 } else {1733 return Combine(std::move(results)...);1734 }1735 }1736 }1737 1738private:1739 template <typename D, typename R, typename... Os, size_t... Is>1740 Arguments OperationArgs(1741 const Operation<D, R, Os...> &x, std::index_sequence<Is...>) const {1742 return Arguments{Expr<SomeType>(x.template operand<Is>())...};1743 }1744};1745} // namespace operation1746 1747std::string operation::ToString(operation::Operator op) {1748 switch (op) {1749 case Operator::Unknown:1750 return "??";1751 case Operator::Add:1752 return "+";1753 case Operator::And:1754 return "AND";1755 case Operator::Associated:1756 return "ASSOCIATED";1757 case Operator::Call:1758 return "function-call";1759 case Operator::Constant:1760 return "constant";1761 case Operator::Convert:1762 return "type-conversion";1763 case Operator::Div:1764 return "/";1765 case Operator::Eq:1766 return "==";1767 case Operator::Eqv:1768 return "EQV";1769 case Operator::False:1770 return ".FALSE.";1771 case Operator::Ge:1772 return ">=";1773 case Operator::Gt:1774 return ">";1775 case Operator::Identity:1776 return "identity";1777 case Operator::Intrinsic:1778 return "intrinsic";1779 case Operator::Le:1780 return "<=";1781 case Operator::Lt:1782 return "<";1783 case Operator::Max:1784 return "MAX";1785 case Operator::Min:1786 return "MIN";1787 case Operator::Mul:1788 return "*";1789 case Operator::Ne:1790 return "/=";1791 case Operator::Neqv:1792 return "NEQV/EOR";1793 case Operator::Not:1794 return "NOT";1795 case Operator::Or:1796 return "OR";1797 case Operator::Pow:1798 return "**";1799 case Operator::Resize:1800 return "resize";1801 case Operator::Sub:1802 return "-";1803 case Operator::True:1804 return ".TRUE.";1805 }1806 llvm_unreachable("Unhandler operator");1807}1808 1809operation::Operator operation::OperationCode(const Relational<SomeType> &op) {1810 return common::visit([](auto &&s) { return OperationCode(s); }, op.u);1811}1812 1813operation::Operator operation::OperationCode(const ProcedureDesignator &proc) {1814 Operator code{llvm::StringSwitch<Operator>(proc.GetName())1815 .Case("associated", Operator::Associated)1816 .Case("min", Operator::Min)1817 .Case("max", Operator::Max)1818 .Case("iand", Operator::And)1819 .Case("ior", Operator::Or)1820 .Case("ieor", Operator::Neqv)1821 .Default(Operator::Call)};1822 if (code == Operator::Call && proc.GetSpecificIntrinsic()) {1823 return Operator::Intrinsic;1824 }1825 return code;1826}1827 1828std::pair<operation::Operator, std::vector<Expr<SomeType>>>1829GetTopLevelOperationIgnoreResizing(const Expr<SomeType> &expr) {1830 return operation::ArgumentExtractor<true>{}(expr);1831}1832 1833std::pair<operation::Operator, std::vector<Expr<SomeType>>>1834GetTopLevelOperation(const Expr<SomeType> &expr) {1835 return operation::ArgumentExtractor<false>{}(expr);1836}1837 1838namespace operation {1839struct ConvertCollector1840 : public Traverse<ConvertCollector,1841 std::pair<std::optional<Expr<SomeType>>, std::vector<DynamicType>>,1842 false> {1843 using Result =1844 std::pair<std::optional<Expr<SomeType>>, std::vector<DynamicType>>;1845 using Base = Traverse<ConvertCollector, Result, false>;1846 ConvertCollector() : Base(*this) {}1847 1848 Result Default() const { return {}; }1849 1850 using Base::operator();1851 1852 template <typename T> Result operator()(const Designator<T> &x) const {1853 return {AsSomeExpr(x), {}};1854 }1855 1856 template <typename T> Result operator()(const FunctionRef<T> &x) const {1857 return {AsSomeExpr(x), {}};1858 }1859 1860 template <typename T> Result operator()(const Constant<T> &x) const {1861 return {AsSomeExpr(x), {}};1862 }1863 1864 template <typename D, typename R, typename... Os>1865 Result operator()(const Operation<D, R, Os...> &x) const {1866 if constexpr (std::is_same_v<D, Parentheses<R>>) {1867 // Ignore parentheses.1868 return (*this)(x.template operand<0>());1869 } else if constexpr (is_convert_v<D>) {1870 // Convert should always have a typed result, so it should be safe to1871 // dereference x.GetType().1872 return Combine(1873 {std::nullopt, {*x.GetType()}}, (*this)(x.template operand<0>()));1874 } else if constexpr (is_complex_constructor_v<D>) {1875 // This is a conversion iff the imaginary operand is 0.1876 if (IsZero(x.template operand<1>())) {1877 return Combine(1878 {std::nullopt, {*x.GetType()}}, (*this)(x.template operand<0>()));1879 } else {1880 return {AsSomeExpr(x.derived()), {}};1881 }1882 } else {1883 return {AsSomeExpr(x.derived()), {}};1884 }1885 }1886 1887 template <typename... Rs>1888 Result Combine(Result &&result, Rs &&...results) const {1889 Result v(std::move(result));1890 auto setValue{[](std::optional<Expr<SomeType>> &x,1891 std::optional<Expr<SomeType>> &&y) {1892 assert((!x.has_value() || !y.has_value()) && "Multiple designators");1893 if (!x.has_value()) {1894 x = std::move(y);1895 }1896 }};1897 auto moveAppend{[](auto &accum, auto &&other) {1898 for (auto &&s : other) {1899 accum.push_back(std::move(s));1900 }1901 }};1902 (setValue(v.first, std::move(results).first), ...);1903 (moveAppend(v.second, std::move(results).second), ...);1904 return v;1905 }1906 1907private:1908 template <typename A> static bool IsZero(const A &x) { return false; }1909 template <typename T> static bool IsZero(const Expr<T> &x) {1910 return common::visit([](auto &&s) { return IsZero(s); }, x.u);1911 }1912 template <typename T> static bool IsZero(const Constant<T> &x) {1913 if (auto &&maybeScalar{x.GetScalarValue()}) {1914 return maybeScalar->IsZero();1915 } else {1916 return false;1917 }1918 }1919 1920 template <typename T> struct is_convert {1921 static constexpr bool value{false};1922 };1923 template <typename T, common::TypeCategory C>1924 struct is_convert<Convert<T, C>> {1925 static constexpr bool value{true};1926 };1927 template <int K> struct is_convert<ComplexComponent<K>> {1928 // Conversion from complex to real.1929 static constexpr bool value{true};1930 };1931 template <typename T>1932 static constexpr bool is_convert_v{is_convert<T>::value};1933 1934 template <typename T> struct is_complex_constructor {1935 static constexpr bool value{false};1936 };1937 template <int K> struct is_complex_constructor<ComplexConstructor<K>> {1938 static constexpr bool value{true};1939 };1940 template <typename T>1941 static constexpr bool is_complex_constructor_v{1942 is_complex_constructor<T>::value};1943};1944} // namespace operation1945 1946std::optional<Expr<SomeType>> GetConvertInput(const Expr<SomeType> &x) {1947 // This returns Expr<SomeType>{x} when x is a designator/functionref/constant.1948 return operation::ConvertCollector{}(x).first;1949}1950 1951bool IsSameOrConvertOf(const Expr<SomeType> &expr, const Expr<SomeType> &x) {1952 // Check if expr is same as x, or a sequence of Convert operations on x.1953 if (expr == x) {1954 return true;1955 } else if (auto maybe{GetConvertInput(expr)}) {1956 return *maybe == x;1957 } else {1958 return false;1959 }1960}1961 1962struct VariableFinder : public evaluate::AnyTraverse<VariableFinder> {1963 using Base = evaluate::AnyTraverse<VariableFinder>;1964 using SomeExpr = Expr<SomeType>;1965 VariableFinder(const SomeExpr &v) : Base(*this), var(v) {}1966 1967 using Base::operator();1968 1969 template <typename T>1970 bool operator()(const evaluate::Designator<T> &x) const {1971 return evaluate::AsGenericExpr(common::Clone(x)) == var;1972 }1973 1974 template <typename T>1975 bool operator()(const evaluate::FunctionRef<T> &x) const {1976 return evaluate::AsGenericExpr(common::Clone(x)) == var;1977 }1978 1979private:1980 const SomeExpr &var;1981};1982 1983bool IsVarSubexpressionOf(1984 const Expr<SomeType> &sub, const Expr<SomeType> &super) {1985 return VariableFinder{sub}(super);1986}1987 1988std::optional<int> CountDerivedTypeAncestors(const semantics::Scope &scope) {1989 if (scope.IsDerivedType()) {1990 for (auto iter{scope.cbegin()}; iter != scope.cend(); ++iter) {1991 const Symbol &symbol{*iter->second};1992 if (symbol.test(Symbol::Flag::ParentComp)) {1993 if (const semantics::DeclTypeSpec *type{symbol.GetType()}) {1994 if (const semantics::DerivedTypeSpec *derived{type->AsDerived()}) {1995 const semantics::Scope *parent{derived->scope()};1996 if (!parent) {1997 parent = derived->typeSymbol().scope();1998 }1999 if (parent) {2000 if (auto parentDepth{CountDerivedTypeAncestors(*parent)}) {2001 return 1 + *parentDepth;2002 }2003 }2004 }2005 }2006 return std::nullopt; // error recovery2007 }2008 }2009 return 0;2010 } else {2011 return std::nullopt; // error recovery2012 }2013}2014 2015} // namespace Fortran::evaluate2016 2017namespace Fortran::semantics {2018 2019const Symbol &ResolveAssociations(2020 const Symbol &original, bool stopAtTypeGuard) {2021 const Symbol &symbol{original.GetUltimate()};2022 if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {2023 if (!details->rank() /* not RANK(n) or RANK(*) */ &&2024 !(stopAtTypeGuard && details->isTypeGuard())) {2025 if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {2026 return ResolveAssociations(*nested);2027 }2028 }2029 }2030 return symbol;2031}2032 2033// When a construct association maps to a variable, and that variable2034// is not an array with a vector-valued subscript, return the base2035// Symbol of that variable, else nullptr. Descends into other construct2036// associations when one associations maps to another.2037static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {2038 if (const auto &expr{details.expr()}) {2039 if (IsVariable(*expr) && !HasVectorSubscript(*expr)) {2040 if (const Symbol * varSymbol{GetFirstSymbol(*expr)}) {2041 return &GetAssociationRoot(*varSymbol);2042 }2043 }2044 }2045 return nullptr;2046}2047 2048const Symbol &GetAssociationRoot(const Symbol &original, bool stopAtTypeGuard) {2049 const Symbol &symbol{ResolveAssociations(original, stopAtTypeGuard)};2050 if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {2051 if (const Symbol * root{GetAssociatedVariable(*details)}) {2052 return *root;2053 }2054 }2055 return symbol;2056}2057 2058const Symbol *GetMainEntry(const Symbol *symbol) {2059 if (symbol) {2060 if (const auto *subpDetails{symbol->detailsIf<SubprogramDetails>()}) {2061 if (const Scope * scope{subpDetails->entryScope()}) {2062 if (const Symbol * main{scope->symbol()}) {2063 return main;2064 }2065 }2066 }2067 }2068 return symbol;2069}2070 2071bool IsVariableName(const Symbol &original) {2072 const Symbol &ultimate{original.GetUltimate()};2073 return !IsNamedConstant(ultimate) &&2074 (ultimate.has<ObjectEntityDetails>() ||2075 ultimate.has<AssocEntityDetails>());2076}2077 2078static bool IsPureProcedureImpl(2079 const Symbol &original, semantics::UnorderedSymbolSet &set) {2080 // An ENTRY is pure if its containing subprogram is2081 const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};2082 if (set.find(symbol) != set.end()) {2083 return true;2084 }2085 set.emplace(symbol);2086 if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {2087 if (procDetails->procInterface()) {2088 // procedure with a pure interface2089 return IsPureProcedureImpl(*procDetails->procInterface(), set);2090 }2091 } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {2092 return IsPureProcedureImpl(details->symbol(), set);2093 } else if (!IsProcedure(symbol)) {2094 return false;2095 }2096 if (IsStmtFunction(symbol)) {2097 // Section 15.7(1) states that a statement function is PURE if it does not2098 // reference an IMPURE procedure or a VOLATILE variable2099 if (const auto &expr{symbol.get<SubprogramDetails>().stmtFunction()}) {2100 for (const SymbolRef &ref : evaluate::CollectSymbols(*expr)) {2101 if (&*ref == &symbol) {2102 return false; // error recovery, recursion is caught elsewhere2103 }2104 if (IsFunction(*ref) && !IsPureProcedureImpl(*ref, set)) {2105 return false;2106 }2107 if (ref->GetUltimate().attrs().test(Attr::VOLATILE)) {2108 return false;2109 }2110 }2111 }2112 return true; // statement function was not found to be impure2113 }2114 return symbol.attrs().test(Attr::PURE) ||2115 (symbol.attrs().test(Attr::ELEMENTAL) &&2116 !symbol.attrs().test(Attr::IMPURE));2117}2118 2119bool IsPureProcedure(const Symbol &original) {2120 semantics::UnorderedSymbolSet set;2121 return IsPureProcedureImpl(original, set);2122}2123 2124bool IsPureProcedure(const Scope &scope) {2125 const Symbol *symbol{scope.GetSymbol()};2126 return symbol && IsPureProcedure(*symbol);2127}2128 2129bool IsExplicitlyImpureProcedure(const Symbol &original) {2130 // An ENTRY is IMPURE if its containing subprogram is so2131 return DEREF(GetMainEntry(&original.GetUltimate()))2132 .attrs()2133 .test(Attr::IMPURE);2134}2135 2136bool IsElementalProcedure(const Symbol &original) {2137 // An ENTRY is elemental if its containing subprogram is2138 const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};2139 if (IsProcedure(symbol)) {2140 auto &foldingContext{symbol.owner().context().foldingContext()};2141 auto restorer{foldingContext.messages().DiscardMessages()};2142 auto proc{evaluate::characteristics::Procedure::Characterize(2143 symbol, foldingContext)};2144 return proc &&2145 proc->attrs.test(evaluate::characteristics::Procedure::Attr::Elemental);2146 } else {2147 return false;2148 }2149}2150 2151bool IsFunction(const Symbol &symbol) {2152 const Symbol &ultimate{symbol.GetUltimate()};2153 return ultimate.test(Symbol::Flag::Function) ||2154 (!ultimate.test(Symbol::Flag::Subroutine) &&2155 common::visit(2156 common::visitors{2157 [](const SubprogramDetails &x) { return x.isFunction(); },2158 [](const ProcEntityDetails &x) {2159 const Symbol *ifc{x.procInterface()};2160 return x.type() || (ifc && IsFunction(*ifc));2161 },2162 [](const ProcBindingDetails &x) {2163 return IsFunction(x.symbol());2164 },2165 [](const auto &) { return false; },2166 },2167 ultimate.details()));2168}2169 2170bool IsFunction(const Scope &scope) {2171 const Symbol *symbol{scope.GetSymbol()};2172 return symbol && IsFunction(*symbol);2173}2174 2175bool IsProcedure(const Symbol &symbol) {2176 return common::visit(common::visitors{2177 [&symbol](const SubprogramDetails &) {2178 const Scope *scope{symbol.scope()};2179 // Main programs & BLOCK DATA are not procedures.2180 return !scope ||2181 scope->kind() == Scope::Kind::Subprogram;2182 },2183 [](const SubprogramNameDetails &) { return true; },2184 [](const ProcEntityDetails &) { return true; },2185 [](const GenericDetails &) { return true; },2186 [](const ProcBindingDetails &) { return true; },2187 [](const auto &) { return false; },2188 },2189 symbol.GetUltimate().details());2190}2191 2192bool IsProcedure(const Scope &scope) {2193 const Symbol *symbol{scope.GetSymbol()};2194 return symbol && IsProcedure(*symbol);2195}2196 2197bool IsProcedurePointer(const Symbol &original) {2198 const Symbol &symbol{GetAssociationRoot(original)};2199 return IsPointer(symbol) && IsProcedure(symbol);2200}2201 2202bool IsProcedurePointer(const Symbol *symbol) {2203 return symbol && IsProcedurePointer(*symbol);2204}2205 2206bool IsObjectPointer(const Symbol *original) {2207 if (original) {2208 const Symbol &symbol{GetAssociationRoot(*original)};2209 return IsPointer(symbol) && !IsProcedure(symbol);2210 } else {2211 return false;2212 }2213}2214 2215bool IsAllocatableOrObjectPointer(const Symbol *original) {2216 if (original) {2217 const Symbol &ultimate{original->GetUltimate()};2218 if (const auto *assoc{ultimate.detailsIf<AssocEntityDetails>()}) {2219 // Only SELECT RANK construct entities can be ALLOCATABLE/POINTER.2220 return (assoc->rank() || assoc->IsAssumedSize() ||2221 assoc->IsAssumedRank()) &&2222 IsAllocatableOrObjectPointer(UnwrapWholeSymbolDataRef(assoc->expr()));2223 } else {2224 return IsAllocatable(ultimate) ||2225 (IsPointer(ultimate) && !IsProcedure(ultimate));2226 }2227 } else {2228 return false;2229 }2230}2231 2232const Symbol *FindCommonBlockContaining(const Symbol &original) {2233 const Symbol &root{GetAssociationRoot(original)};2234 const auto *details{root.detailsIf<ObjectEntityDetails>()};2235 return details ? details->commonBlock() : nullptr;2236}2237 2238// 3.11 automatic data object2239bool IsAutomatic(const Symbol &original) {2240 const Symbol &symbol{original.GetUltimate()};2241 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {2242 if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {2243 if (const DeclTypeSpec * type{symbol.GetType()}) {2244 // If a type parameter value is not a constant expression, the2245 // object is automatic.2246 if (type->category() == DeclTypeSpec::Character) {2247 if (const auto &length{2248 type->characterTypeSpec().length().GetExplicit()}) {2249 if (!evaluate::IsConstantExpr(*length)) {2250 return true;2251 }2252 }2253 } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {2254 for (const auto &pair : derived->parameters()) {2255 if (const auto &value{pair.second.GetExplicit()}) {2256 if (!evaluate::IsConstantExpr(*value)) {2257 return true;2258 }2259 }2260 }2261 }2262 }2263 // If an array bound is not a constant expression, the object is2264 // automatic.2265 for (const ShapeSpec &dim : object->shape()) {2266 if (const auto &lb{dim.lbound().GetExplicit()}) {2267 if (!evaluate::IsConstantExpr(*lb)) {2268 return true;2269 }2270 }2271 if (const auto &ub{dim.ubound().GetExplicit()}) {2272 if (!evaluate::IsConstantExpr(*ub)) {2273 return true;2274 }2275 }2276 }2277 }2278 }2279 return false;2280}2281 2282bool IsSaved(const Symbol &original) {2283 const Symbol &symbol{GetAssociationRoot(original)};2284 const Scope &scope{symbol.owner()};2285 const common::LanguageFeatureControl &features{2286 scope.context().languageFeatures()};2287 auto scopeKind{scope.kind()};2288 if (symbol.has<AssocEntityDetails>()) {2289 return false; // ASSOCIATE(non-variable)2290 } else if (scopeKind == Scope::Kind::DerivedType) {2291 return false; // this is a component2292 } else if (symbol.attrs().test(Attr::SAVE)) {2293 // explicit or implied SAVE attribute2294 // N.B.: semantics sets implied SAVE for main program2295 // local variables whose derived types have coarray2296 // potential subobject components.2297 return true;2298 } else if (IsDummy(symbol) || IsFunctionResult(symbol) ||2299 IsAutomatic(symbol) || IsNamedConstant(symbol)) {2300 return false;2301 } else if (scopeKind == Scope::Kind::Module ||2302 (scopeKind == Scope::Kind::MainProgram &&2303 (symbol.attrs().test(Attr::TARGET) || evaluate::IsCoarray(symbol)))) {2304 // 8.5.16p42305 // In main programs, implied SAVE matters only for pointer2306 // initialization targets and coarrays.2307 return true;2308 } else if (scopeKind == Scope::Kind::MainProgram &&2309 (features.IsEnabled(common::LanguageFeature::SaveMainProgram) ||2310 (features.IsEnabled(2311 common::LanguageFeature::SaveBigMainProgramVariables) &&2312 symbol.size() > 32))) {2313 // With SaveBigMainProgramVariables, keeping all unsaved main program2314 // variables of 32 bytes or less on the stack allows keeping numerical and2315 // logical scalars, small scalar characters or derived, small arrays, and2316 // scalar descriptors on the stack. This leaves more room for lower level2317 // optimizers to do register promotion or get easy aliasing information.2318 return true;2319 } else if (features.IsEnabled(common::LanguageFeature::DefaultSave) &&2320 (scopeKind == Scope::Kind::MainProgram ||2321 (scope.kind() == Scope::Kind::Subprogram &&2322 !(scope.symbol() &&2323 scope.symbol()->attrs().test(Attr::RECURSIVE))))) {2324 // -fno-automatic/-save/-Msave option applies to all objects in executable2325 // main programs and subprograms unless they are explicitly RECURSIVE.2326 return true;2327 } else if (symbol.test(Symbol::Flag::InDataStmt)) {2328 return true;2329 } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};2330 object && object->init()) {2331 return true;2332 } else if (IsProcedurePointer(symbol) && symbol.has<ProcEntityDetails>() &&2333 symbol.get<ProcEntityDetails>().init()) {2334 return true;2335 } else if (scope.hasSAVE()) {2336 return true; // bare SAVE statement2337 } else if (const Symbol *block{FindCommonBlockContaining(symbol)};2338 block && block->attrs().test(Attr::SAVE)) {2339 return true; // in COMMON with SAVE2340 } else {2341 return false;2342 }2343}2344 2345bool IsDummy(const Symbol &symbol) {2346 return common::visit(2347 common::visitors{[](const EntityDetails &x) { return x.isDummy(); },2348 [](const ObjectEntityDetails &x) { return x.isDummy(); },2349 [](const ProcEntityDetails &x) { return x.isDummy(); },2350 [](const SubprogramDetails &x) { return x.isDummy(); },2351 [](const auto &) { return false; }},2352 ResolveAssociations(symbol).details());2353}2354 2355bool IsAssumedRank(const Symbol &original) {2356 if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {2357 if (assoc->rank()) {2358 return false; // in RANK(n) or RANK(*)2359 } else if (assoc->IsAssumedRank()) {2360 return true; // RANK DEFAULT2361 }2362 }2363 const Symbol &symbol{semantics::ResolveAssociations(original)};2364 const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};2365 return object && object->IsAssumedRank();2366}2367 2368bool IsAssumedShape(const Symbol &symbol) {2369 const Symbol &ultimate{ResolveAssociations(symbol)};2370 const auto *object{ultimate.detailsIf<semantics::ObjectEntityDetails>()};2371 return object && object->IsAssumedShape() &&2372 !semantics::IsAllocatableOrObjectPointer(&ultimate);2373}2374 2375bool IsDeferredShape(const Symbol &symbol) {2376 const Symbol &ultimate{ResolveAssociations(symbol)};2377 const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};2378 return object && object->CanBeDeferredShape() &&2379 semantics::IsAllocatableOrObjectPointer(&ultimate);2380}2381 2382bool IsFunctionResult(const Symbol &original) {2383 const Symbol &symbol{GetAssociationRoot(original)};2384 return common::visit(2385 common::visitors{2386 [](const EntityDetails &x) { return x.isFuncResult(); },2387 [](const ObjectEntityDetails &x) { return x.isFuncResult(); },2388 [](const ProcEntityDetails &x) { return x.isFuncResult(); },2389 [](const auto &) { return false; },2390 },2391 symbol.details());2392}2393 2394bool IsKindTypeParameter(const Symbol &symbol) {2395 const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};2396 return param && param->attr() == common::TypeParamAttr::Kind;2397}2398 2399bool IsLenTypeParameter(const Symbol &symbol) {2400 const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};2401 return param && param->attr() == common::TypeParamAttr::Len;2402}2403 2404bool IsExtensibleType(const DerivedTypeSpec *derived) {2405 return !IsSequenceOrBindCType(derived) && !IsIsoCType(derived);2406}2407 2408bool IsSequenceOrBindCType(const DerivedTypeSpec *derived) {2409 return derived &&2410 (derived->typeSymbol().attrs().test(Attr::BIND_C) ||2411 derived->typeSymbol().get<DerivedTypeDetails>().sequence());2412}2413 2414static bool IsSameModule(const Scope *x, const Scope *y) {2415 if (x == y) {2416 return true;2417 } else if (x && y) {2418 // Allow for a builtin module to be read from distinct paths2419 const Symbol *xSym{x->symbol()};2420 const Symbol *ySym{y->symbol()};2421 if (xSym && ySym && xSym->name() == ySym->name()) {2422 const auto *xMod{xSym->detailsIf<ModuleDetails>()};2423 const auto *yMod{ySym->detailsIf<ModuleDetails>()};2424 if (xMod && yMod) {2425 auto xHash{xMod->moduleFileHash()};2426 auto yHash{yMod->moduleFileHash()};2427 return xHash && yHash && *xHash == *yHash;2428 }2429 }2430 }2431 return false;2432}2433 2434bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {2435 if (derived) {2436 const auto &symbol{derived->typeSymbol()};2437 const Scope &scope{symbol.owner()};2438 return symbol.name() == "__builtin_"s + name &&2439 IsSameModule(&scope, scope.context().GetBuiltinsScope());2440 } else {2441 return false;2442 }2443}2444 2445bool IsBuiltinCPtr(const Symbol &symbol) {2446 if (const DeclTypeSpec *declType = symbol.GetType()) {2447 if (const DerivedTypeSpec *derived = declType->AsDerived()) {2448 return IsIsoCType(derived);2449 }2450 }2451 return false;2452}2453 2454bool IsFromBuiltinModule(const Symbol &symbol) {2455 const Scope &scope{symbol.GetUltimate().owner()};2456 return IsSameModule(&scope, scope.context().GetBuiltinsScope());2457}2458 2459bool IsIsoCType(const DerivedTypeSpec *derived) {2460 return IsBuiltinDerivedType(derived, "c_ptr") ||2461 IsBuiltinDerivedType(derived, "c_funptr");2462}2463 2464bool IsEventType(const DerivedTypeSpec *derived) {2465 return IsBuiltinDerivedType(derived, "event_type");2466}2467 2468bool IsLockType(const DerivedTypeSpec *derived) {2469 return IsBuiltinDerivedType(derived, "lock_type");2470}2471 2472bool IsNotifyType(const DerivedTypeSpec *derived) {2473 return IsBuiltinDerivedType(derived, "notify_type");2474}2475 2476bool IsIeeeFlagType(const DerivedTypeSpec *derived) {2477 return IsBuiltinDerivedType(derived, "ieee_flag_type");2478}2479 2480bool IsIeeeRoundType(const DerivedTypeSpec *derived) {2481 return IsBuiltinDerivedType(derived, "ieee_round_type");2482}2483 2484bool IsTeamType(const DerivedTypeSpec *derived) {2485 return IsBuiltinDerivedType(derived, "team_type");2486}2487 2488bool IsBadCoarrayType(const DerivedTypeSpec *derived) {2489 return IsTeamType(derived) || IsIsoCType(derived);2490}2491 2492bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {2493 return IsEventType(derivedTypeSpec) || IsLockType(derivedTypeSpec);2494}2495 2496int CountLenParameters(const DerivedTypeSpec &type) {2497 return llvm::count_if(2498 type.parameters(), [](const auto &pair) { return pair.second.isLen(); });2499}2500 2501int CountNonConstantLenParameters(const DerivedTypeSpec &type) {2502 return llvm::count_if(type.parameters(), [](const auto &pair) {2503 if (!pair.second.isLen()) {2504 return false;2505 } else if (const auto &expr{pair.second.GetExplicit()}) {2506 return !IsConstantExpr(*expr);2507 } else {2508 return true;2509 }2510 });2511}2512 2513const Symbol &GetUsedModule(const UseDetails &details) {2514 return DEREF(details.symbol().owner().symbol());2515}2516 2517static const Symbol *FindFunctionResult(2518 const Symbol &original, UnorderedSymbolSet &seen) {2519 const Symbol &root{GetAssociationRoot(original)};2520 ;2521 if (!seen.insert(root).second) {2522 return nullptr; // don't loop2523 }2524 return common::visit(2525 common::visitors{[](const SubprogramDetails &subp) {2526 return subp.isFunction() ? &subp.result() : nullptr;2527 },2528 [&](const ProcEntityDetails &proc) {2529 const Symbol *iface{proc.procInterface()};2530 return iface ? FindFunctionResult(*iface, seen) : nullptr;2531 },2532 [&](const ProcBindingDetails &binding) {2533 return FindFunctionResult(binding.symbol(), seen);2534 },2535 [](const auto &) -> const Symbol * { return nullptr; }},2536 root.details());2537}2538 2539const Symbol *FindFunctionResult(const Symbol &symbol) {2540 UnorderedSymbolSet seen;2541 return FindFunctionResult(symbol, seen);2542}2543 2544// These are here in Evaluate/tools.cpp so that Evaluate can use2545// them; they cannot be defined in symbol.h due to the dependence2546// on Scope.2547 2548bool SymbolSourcePositionCompare::operator()(2549 const SymbolRef &x, const SymbolRef &y) const {2550 return x->GetSemanticsContext().allCookedSources().Precedes(2551 x->name(), y->name());2552}2553bool SymbolSourcePositionCompare::operator()(2554 const MutableSymbolRef &x, const MutableSymbolRef &y) const {2555 return x->GetSemanticsContext().allCookedSources().Precedes(2556 x->name(), y->name());2557}2558 2559SemanticsContext &Symbol::GetSemanticsContext() const {2560 return DEREF(owner_).context();2561}2562 2563bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y) {2564 if (x && y) {2565 if (auto xDt{evaluate::DynamicType::From(*x)}) {2566 if (auto yDt{evaluate::DynamicType::From(*y)}) {2567 return xDt->IsTkCompatibleWith(*yDt);2568 }2569 }2570 }2571 return false;2572}2573 2574common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {2575 common::IgnoreTKRSet result;2576 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {2577 result = object->ignoreTKR();2578 if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {2579 if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()}) {2580 if (ownerSubp->defaultIgnoreTKR()) {2581 result |= common::ignoreTKRAll;2582 }2583 }2584 }2585 }2586 return result;2587}2588 2589std::optional<int> GetDummyArgumentNumber(const Symbol *symbol) {2590 if (symbol) {2591 if (IsDummy(*symbol)) {2592 if (const Symbol * subpSym{symbol->owner().symbol()}) {2593 if (const auto *subp{subpSym->detailsIf<SubprogramDetails>()}) {2594 int j{0};2595 for (const Symbol *dummy : subp->dummyArgs()) {2596 if (dummy == symbol) {2597 return j;2598 }2599 ++j;2600 }2601 }2602 }2603 }2604 }2605 return std::nullopt;2606}2607 2608// Given a symbol that is a SubprogramNameDetails in a submodule, try to2609// find its interface definition in its module or ancestor submodule.2610const Symbol *FindAncestorModuleProcedure(const Symbol *symInSubmodule) {2611 if (symInSubmodule && symInSubmodule->owner().IsSubmodule()) {2612 if (const auto *nameDetails{2613 symInSubmodule->detailsIf<semantics::SubprogramNameDetails>()};2614 nameDetails &&2615 nameDetails->kind() == semantics::SubprogramKind::Module) {2616 const Symbol *next{symInSubmodule->owner().symbol()};2617 while (const Symbol * submodSym{next}) {2618 next = nullptr;2619 if (const auto *modDetails{2620 submodSym->detailsIf<semantics::ModuleDetails>()};2621 modDetails && modDetails->isSubmodule() && modDetails->scope()) {2622 if (const semantics::Scope & parent{modDetails->scope()->parent()};2623 parent.IsSubmodule() || parent.IsModule()) {2624 if (auto iter{parent.find(symInSubmodule->name())};2625 iter != parent.end()) {2626 const Symbol &proc{iter->second->GetUltimate()};2627 if (IsProcedure(proc)) {2628 return &proc;2629 }2630 } else if (parent.IsSubmodule()) {2631 next = parent.symbol();2632 }2633 }2634 }2635 }2636 }2637 }2638 return nullptr;2639}2640 2641} // namespace Fortran::semantics2642