flang/lib/Evaluate/tools.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-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "flang/Evaluate/tools.h"
  10 #include "flang/Common/idioms.h"
  11 #include "flang/Evaluate/characteristics.h"
  12 #include "flang/Evaluate/traverse.h"
  13 #include "flang/Parser/message.h"
  14 #include "flang/Semantics/tools.h"
  15 #include <algorithm>
  16 #include <variant>
  17
  18 using namespace Fortran::parser::literals;
  19
  20 namespace Fortran::evaluate {
  21
  22 // Can x*(a,b) be represented as (x*a,x*b)?  This code duplication
  23 // of the subexpression "x" cannot (yet?) be reliably undone by
  24 // common subexpression elimination in lowering, so it's disabled
  25 // here for now to avoid the risk of potential duplication of
  26 // expensive subexpressions (e.g., large array expressions, references
  27 // to expensive functions) in generate code.
  28 static constexpr bool allowOperandDuplication{false};
  29
  30 std::optional<Expr<SomeType>> AsGenericExpr(DataRef &&ref) {
  31   const Symbol &symbol{ref.GetLastSymbol()};
  32   if (auto dyType{DynamicType::From(symbol)}) {
  33     return TypedWrapper<Designator, DataRef>(*dyType, std::move(ref));
  34   }
  35   return std::nullopt;
  36 }
  37
  38 std::optional<Expr<SomeType>> AsGenericExpr(const Symbol &symbol) {
  39   return AsGenericExpr(DataRef{symbol});
  40 }
  41
  42 Expr<SomeType> Parenthesize(Expr<SomeType> &&expr) {
  43   return common::visit(
  44       [&](auto &&x) {
  45         using T = std::decay_t<decltype(x)>;
  46         if constexpr (common::HasMember<T, TypelessExpression>) {
  47           return expr; // no parentheses around typeless
  48         } else if constexpr (std::is_same_v<T, Expr<SomeDerived>>) {
  49           return AsGenericExpr(Parentheses<SomeDerived>{std::move(x)});
  50         } else {
  51           return common::visit(
  52               [](auto &&y) {
  53                 using T = ResultType<decltype(y)>;
  54                 return AsGenericExpr(Parentheses<T>{std::move(y)});
  55               },
  56               std::move(x.u));
  57         }
  58       },
  59       std::move(expr.u));
  60 }
  61
  62 std::optional<DataRef> ExtractDataRef(
  63     const ActualArgument &arg, bool intoSubstring, bool intoComplexPart) {
  64   return ExtractDataRef(arg.UnwrapExpr(), intoSubstring, intoComplexPart);
  65 }
  66
  67 std::optional<DataRef> ExtractSubstringBase(const Substring &substring) {
  68   return common::visit(
  69       common::visitors{
  70           [&](const DataRef &x) -> std::optional<DataRef> { return x; },
  71           [&](const StaticDataObject::Pointer &) -> std::optional<DataRef> {
  72             return std::nullopt;
  73           },
  74       },
  75       substring.parent());
  76 }
  77
  78 // IsVariable()
  79
  80 auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
  81   // ASSOCIATE(x => expr) -- x counts as a variable, but undefinable
  82   const Symbol &ultimate{symbol.GetUltimate()};
  83   return !IsNamedConstant(ultimate) &&
  84       (ultimate.has<semantics::ObjectEntityDetails>() ||
  85           ultimate.has<semantics::AssocEntityDetails>());
  86 }
  87 auto IsVariableHelper::operator()(const Component &x) const -> Result {
  88   const Symbol &comp{x.GetLastSymbol()};
  89   return (*this)(comp) && (IsPointer(comp) || (*this)(x.base()));
  90 }
  91 auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
  92   return (*this)(x.base());
  93 }
  94 auto IsVariableHelper::operator()(const Substring &x) const -> Result {
  95   return (*this)(x.GetBaseObject());
  96 }
  97 auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
  98     -> Result {
  99   if (const Symbol * symbol{x.GetSymbol()}) {
 100     const Symbol *result{FindFunctionResult(*symbol)};
 101     return result && IsPointer(*result) && !IsProcedurePointer(*result);
 102   }
 103   return false;
 104 }
 105
 106 // Conversions of COMPLEX component expressions to REAL.
 107 ConvertRealOperandsResult ConvertRealOperands(
 108     parser::ContextualMessages &messages, Expr<SomeType> &&x,
 109     Expr<SomeType> &&y, int defaultRealKind) {
 110   return common::visit(
 111       common::visitors{
 112           [&](Expr<SomeInteger> &&ix,
 113               Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
 114             // Can happen in a CMPLX() constructor.  Per F'2018,
 115             // both integer operands are converted to default REAL.
 116             return {AsSameKindExprs<TypeCategory::Real>(
 117                 ConvertToKind<TypeCategory::Real>(
 118                     defaultRealKind, std::move(ix)),
 119                 ConvertToKind<TypeCategory::Real>(
 120                     defaultRealKind, std::move(iy)))};
 121           },
 122           [&](Expr<SomeInteger> &&ix,
 123               Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
 124             return {AsSameKindExprs<TypeCategory::Real>(
 125                 ConvertTo(ry, std::move(ix)), std::move(ry))};
 126           },
 127           [&](Expr<SomeReal> &&rx,
 128               Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
 129             return {AsSameKindExprs<TypeCategory::Real>(
 130                 std::move(rx), ConvertTo(rx, std::move(iy)))};
 131           },
 132           [&](Expr<SomeReal> &&rx,
 133               Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
 134             return {AsSameKindExprs<TypeCategory::Real>(
 135                 std::move(rx), std::move(ry))};
 136           },
 137           [&](Expr<SomeInteger> &&ix,
 138               BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
 139             return {AsSameKindExprs<TypeCategory::Real>(
 140                 ConvertToKind<TypeCategory::Real>(
 141                     defaultRealKind, std::move(ix)),
 142                 ConvertToKind<TypeCategory::Real>(
 143                     defaultRealKind, std::move(by)))};
 144           },
 145           [&](BOZLiteralConstant &&bx,
 146               Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
 147             return {AsSameKindExprs<TypeCategory::Real>(
 148                 ConvertToKind<TypeCategory::Real>(
 149                     defaultRealKind, std::move(bx)),
 150                 ConvertToKind<TypeCategory::Real>(
 151                     defaultRealKind, std::move(iy)))};
 152           },
 153           [&](Expr<SomeReal> &&rx,
 154               BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
 155             return {AsSameKindExprs<TypeCategory::Real>(
 156                 std::move(rx), ConvertTo(rx, std::move(by)))};
 157           },
 158           [&](BOZLiteralConstant &&bx,
 159               Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
 160             return {AsSameKindExprs<TypeCategory::Real>(
 161                 ConvertTo(ry, std::move(bx)), std::move(ry))};
 162           },
 163           [&](auto &&, auto &&) -> ConvertRealOperandsResult { // C718
 164             messages.Say("operands must be INTEGER or REAL"_err_en_US);
 165             return std::nullopt;
 166           },
 167       },
 168       std::move(x.u), std::move(y.u));
 169 }
 170
 171 // Helpers for NumericOperation and its subroutines below.
 172 static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }
 173
 174 template <TypeCategory CAT>
 175 std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {
 176   return {AsGenericExpr(std::move(catExpr))};
 177 }
 178 template <TypeCategory CAT>
 179 std::optional<Expr<SomeType>> Package(
 180     std::optional<Expr<SomeKind<CAT>>> &&catExpr) {
 181   if (catExpr) {
 182     return {AsGenericExpr(std::move(*catExpr))};
 183   }
 184   return NoExpr();
 185 }
 186
 187 // Mixed REAL+INTEGER operations.  REAL**INTEGER is a special case that
 188 // does not require conversion of the exponent expression.
 189 template <template <typename> class OPR>
 190 std::optional<Expr<SomeType>> MixedRealLeft(
 191     Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
 192   return Package(common::visit(
 193       [&](auto &&rxk) -> Expr<SomeReal> {
 194         using resultType = ResultType<decltype(rxk)>;
 195         if constexpr (std::is_same_v<OPR<resultType>, Power<resultType>>) {
 196           return AsCategoryExpr(
 197               RealToIntPower<resultType>{std::move(rxk), std::move(iy)});
 198         }
 199         // G++ 8.1.0 emits bogus warnings about missing return statements if
 200         // this statement is wrapped in an "else", as it should be.
 201         return AsCategoryExpr(OPR<resultType>{
 202             std::move(rxk), ConvertToType<resultType>(std::move(iy))});
 203       },
 204       std::move(rx.u)));
 205 }
 206
 207 std::optional<Expr<SomeComplex>> ConstructComplex(
 208     parser::ContextualMessages &messages, Expr<SomeType> &&real,
 209     Expr<SomeType> &&imaginary, int defaultRealKind) {
 210   if (auto converted{ConvertRealOperands(
 211           messages, std::move(real), std::move(imaginary), defaultRealKind)}) {
 212     return {common::visit(
 213         [](auto &&pair) {
 214           return MakeComplex(std::move(pair[0]), std::move(pair[1]));
 215         },
 216         std::move(*converted))};
 217   }
 218   return std::nullopt;
 219 }
 220
 221 std::optional<Expr<SomeComplex>> ConstructComplex(
 222     parser::ContextualMessages &messages, std::optional<Expr<SomeType>> &&real,
 223     std::optional<Expr<SomeType>> &&imaginary, int defaultRealKind) {
 224   if (auto parts{common::AllPresent(std::move(real), std::move(imaginary))}) {
 225     return ConstructComplex(messages, std::get<0>(std::move(*parts)),
 226         std::get<1>(std::move(*parts)), defaultRealKind);
 227   }
 228   return std::nullopt;
 229 }
 230
 231 Expr<SomeReal> GetComplexPart(const Expr<SomeComplex> &z, bool isImaginary) {
 232   return common::visit(
 233       [&](const auto &zk) {
 234         static constexpr int kind{ResultType<decltype(zk)>::kind};
 235         return AsCategoryExpr(ComplexComponent<kind>{isImaginary, zk});
 236       },
 237       z.u);
 238 }
 239
 240 Expr<SomeReal> GetComplexPart(Expr<SomeComplex> &&z, bool isImaginary) {
 241   return common::visit(
 242       [&](auto &&zk) {
 243         static constexpr int kind{ResultType<decltype(zk)>::kind};
 244         return AsCategoryExpr(
 245             ComplexComponent<kind>{isImaginary, std::move(zk)});
 246       },
 247       z.u);
 248 }
 249
 250 // Convert REAL to COMPLEX of the same kind. Preserving the real operand kind
 251 // and then applying complex operand promotion rules allows the result to have
 252 // the highest precision of REAL and COMPLEX operands as required by Fortran
 253 // 2018 10.9.1.3.
 254 Expr<SomeComplex> PromoteRealToComplex(Expr<SomeReal> &&someX) {
 255   return common::visit(
 256       [](auto &&x) {
 257         using RT = ResultType<decltype(x)>;
 258         return AsCategoryExpr(ComplexConstructor<RT::kind>{
 259             std::move(x), AsExpr(Constant<RT>{Scalar<RT>{}})});
 260       },
 261       std::move(someX.u));
 262 }
 263
 264 // Handle mixed COMPLEX+REAL (or INTEGER) operations in a better way
 265 // than just converting the second operand to COMPLEX and performing the
 266 // corresponding COMPLEX+COMPLEX operation.
 267 template <template <typename> class OPR, TypeCategory RCAT>
 268 std::optional<Expr<SomeType>> MixedComplexLeft(
 269     parser::ContextualMessages &messages, Expr<SomeComplex> &&zx,
 270     Expr<SomeKind<RCAT>> &&iry, [[maybe_unused]] int defaultRealKind) {
 271   Expr<SomeReal> zr{GetComplexPart(zx, false)};
 272   Expr<SomeReal> zi{GetComplexPart(zx, true)};
 273   if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
 274       std::is_same_v<OPR<LargestReal>, Subtract<LargestReal>>) {
 275     // (a,b) + x -> (a+x, b)
 276     // (a,b) - x -> (a-x, b)
 277     if (std::optional<Expr<SomeType>> rr{
 278             NumericOperation<OPR>(messages, AsGenericExpr(std::move(zr)),
 279                 AsGenericExpr(std::move(iry)), defaultRealKind)}) {
 280       return Package(ConstructComplex(messages, std::move(*rr),
 281           AsGenericExpr(std::move(zi)), defaultRealKind));
 282     }
 283   } else if constexpr (allowOperandDuplication &&
 284       (std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>> ||
 285           std::is_same_v<OPR<LargestReal>, Divide<LargestReal>>)) {
 286     // (a,b) * x -> (a*x, b*x)
 287     // (a,b) / x -> (a/x, b/x)
 288     auto copy{iry};
 289     auto rr{NumericOperation<OPR>(messages, AsGenericExpr(std::move(zr)),
 290         AsGenericExpr(std::move(iry)), defaultRealKind)};
 291     auto ri{NumericOperation<OPR>(messages, AsGenericExpr(std::move(zi)),
 292         AsGenericExpr(std::move(copy)), defaultRealKind)};
 293     if (auto parts{common::AllPresent(std::move(rr), std::move(ri))}) {
 294       return Package(ConstructComplex(messages, std::get<0>(std::move(*parts)),
 295           std::get<1>(std::move(*parts)), defaultRealKind));
 296     }
 297   } else if constexpr (RCAT == TypeCategory::Integer &&
 298       std::is_same_v<OPR<LargestReal>, Power<LargestReal>>) {
 299     // COMPLEX**INTEGER is a special case that doesn't convert the exponent.
 300     static_assert(RCAT == TypeCategory::Integer);
 301     return Package(common::visit(
 302         [&](auto &&zxk) {
 303           using Ty = ResultType<decltype(zxk)>;
 304           return AsCategoryExpr(
 305               AsExpr(RealToIntPower<Ty>{std::move(zxk), std::move(iry)}));
 306         },
 307         std::move(zx.u)));
 308   } else {
 309     // (a,b) ** x -> (a,b) ** (x,0)
 310     if constexpr (RCAT == TypeCategory::Integer) {
 311       Expr<SomeComplex> zy{ConvertTo(zx, std::move(iry))};
 312       return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
 313     } else {
 314       Expr<SomeComplex> zy{PromoteRealToComplex(std::move(iry))};
 315       return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
 316     }
 317   }
 318   return NoExpr();
 319 }
 320
 321 // Mixed COMPLEX operations with the COMPLEX operand on the right.
 322 //  x + (a,b) -> (x+a, b)
 323 //  x - (a,b) -> (x-a, -b)
 324 //  x * (a,b) -> (x*a, x*b)
 325 //  x / (a,b) -> (x,0) / (a,b)   (and **)
 326 template <template <typename> class OPR, TypeCategory LCAT>
 327 std::optional<Expr<SomeType>> MixedComplexRight(
 328     parser::ContextualMessages &messages, Expr<SomeKind<LCAT>> &&irx,
 329     Expr<SomeComplex> &&zy, [[maybe_unused]] int defaultRealKind) {
 330   if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>>) {
 331     // x + (a,b) -> (a,b) + x -> (a+x, b)
 332     return MixedComplexLeft<OPR, LCAT>(
 333         messages, std::move(zy), std::move(irx), defaultRealKind);
 334   } else if constexpr (allowOperandDuplication &&
 335       std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>>) {
 336     // x * (a,b) -> (a,b) * x -> (a*x, b*x)
 337     return MixedComplexLeft<OPR, LCAT>(
 338         messages, std::move(zy), std::move(irx), defaultRealKind);
 339   } else if constexpr (std::is_same_v<OPR<LargestReal>,
 340                            Subtract<LargestReal>>) {
 341     // x - (a,b) -> (x-a, -b)
 342     Expr<SomeReal> zr{GetComplexPart(zy, false)};
 343     Expr<SomeReal> zi{GetComplexPart(zy, true)};
 344     if (std::optional<Expr<SomeType>> rr{
 345             NumericOperation<Subtract>(messages, AsGenericExpr(std::move(irx)),
 346                 AsGenericExpr(std::move(zr)), defaultRealKind)}) {
 347       return Package(ConstructComplex(messages, std::move(*rr),
 348           AsGenericExpr(-std::move(zi)), defaultRealKind));
 349     }
 350   } else {
 351     // x / (a,b) -> (x,0) / (a,b)
 352     if constexpr (LCAT == TypeCategory::Integer) {
 353       Expr<SomeComplex> zx{ConvertTo(zy, std::move(irx))};
 354       return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
 355     } else {
 356       Expr<SomeComplex> zx{PromoteRealToComplex(std::move(irx))};
 357       return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
 358     }
 359   }
 360   return NoExpr();
 361 }
 362
 363 // N.B. When a "typeless" BOZ literal constant appears as one (not both!) of
 364 // the operands to a dyadic operation where one is permitted, it assumes the
 365 // type and kind of the other operand.
 366 template <template <typename> class OPR>
 367 std::optional<Expr<SomeType>> NumericOperation(
 368     parser::ContextualMessages &messages, Expr<SomeType> &&x,
 369     Expr<SomeType> &&y, int defaultRealKind) {
 370   return common::visit(
 371       common::visitors{
 372           [](Expr<SomeInteger> &&ix, Expr<SomeInteger> &&iy) {
 373             return Package(PromoteAndCombine<OPR, TypeCategory::Integer>(
 374                 std::move(ix), std::move(iy)));
 375           },
 376           [](Expr<SomeReal> &&rx, Expr<SomeReal> &&ry) {
 377             return Package(PromoteAndCombine<OPR, TypeCategory::Real>(
 378                 std::move(rx), std::move(ry)));
 379           },
 380           // Mixed REAL/INTEGER operations
 381           [](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
 382             return MixedRealLeft<OPR>(std::move(rx), std::move(iy));
 383           },
 384           [](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
 385             return Package(common::visit(
 386                 [&](auto &&ryk) -> Expr<SomeReal> {
 387                   using resultType = ResultType<decltype(ryk)>;
 388                   return AsCategoryExpr(
 389                       OPR<resultType>{ConvertToType<resultType>(std::move(ix)),
 390                           std::move(ryk)});
 391                 },
 392                 std::move(ry.u)));
 393           },
 394           // Homogeneous and mixed COMPLEX operations
 395           [](Expr<SomeComplex> &&zx, Expr<SomeComplex> &&zy) {
 396             return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
 397                 std::move(zx), std::move(zy)));
 398           },
 399           [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
 400             return MixedComplexLeft<OPR>(
 401                 messages, std::move(zx), std::move(iy), defaultRealKind);
 402           },
 403           [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
 404             return MixedComplexLeft<OPR>(
 405                 messages, std::move(zx), std::move(ry), defaultRealKind);
 406           },
 407           [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
 408             return MixedComplexRight<OPR>(
 409                 messages, std::move(ix), std::move(zy), defaultRealKind);
 410           },
 411           [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
 412             return MixedComplexRight<OPR>(
 413                 messages, std::move(rx), std::move(zy), defaultRealKind);
 414           },
 415           // Operations with one typeless operand
 416           [&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {
 417             return NumericOperation<OPR>(messages,
 418                 AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
 419                 defaultRealKind);
 420           },
 421           [&](BOZLiteralConstant &&bx, Expr<SomeReal> &&ry) {
 422             return NumericOperation<OPR>(messages,
 423                 AsGenericExpr(ConvertTo(ry, std::move(bx))), std::move(y),
 424                 defaultRealKind);
 425           },
 426           [&](Expr<SomeInteger> &&ix, BOZLiteralConstant &&by) {
 427             return NumericOperation<OPR>(messages, std::move(x),
 428                 AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);
 429           },
 430           [&](Expr<SomeReal> &&rx, BOZLiteralConstant &&by) {
 431             return NumericOperation<OPR>(messages, std::move(x),
 432                 AsGenericExpr(ConvertTo(rx, std::move(by))), defaultRealKind);
 433           },
 434           // Default case
 435           [&](auto &&, auto &&) {
 436             // TODO: defined operator
 437             messages.Say("non-numeric operands to numeric operation"_err_en_US);
 438             return NoExpr();
 439           },
 440       },
 441       std::move(x.u), std::move(y.u));
 442 }
 443
 444 template std::optional<Expr<SomeType>> NumericOperation<Power>(
 445     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
 446     int defaultRealKind);
 447 template std::optional<Expr<SomeType>> NumericOperation<Multiply>(
 448     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
 449     int defaultRealKind);
 450 template std::optional<Expr<SomeType>> NumericOperation<Divide>(
 451     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
 452     int defaultRealKind);
 453 template std::optional<Expr<SomeType>> NumericOperation<Add>(
 454     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
 455     int defaultRealKind);
 456 template std::optional<Expr<SomeType>> NumericOperation<Subtract>(
 457     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
 458     int defaultRealKind);
 459
 460 std::optional<Expr<SomeType>> Negation(
 461     parser::ContextualMessages &messages, Expr<SomeType> &&x) {
 462   return common::visit(
 463       common::visitors{
 464           [&](BOZLiteralConstant &&) {
 465             messages.Say("BOZ literal cannot be negated"_err_en_US);
 466             return NoExpr();
 467           },
 468           [&](NullPointer &&) {
 469             messages.Say("NULL() cannot be negated"_err_en_US);
 470             return NoExpr();
 471           },
 472           [&](ProcedureDesignator &&) {
 473             messages.Say("Subroutine cannot be negated"_err_en_US);
 474             return NoExpr();
 475           },
 476           [&](ProcedureRef &&) {
 477             messages.Say("Pointer to subroutine cannot be negated"_err_en_US);
 478             return NoExpr();
 479           },
 480           [&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },
 481           [&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },
 482           [&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },
 483           [&](Expr<SomeCharacter> &&) {
 484             // TODO: defined operator
 485             messages.Say("CHARACTER cannot be negated"_err_en_US);
 486             return NoExpr();
 487           },
 488           [&](Expr<SomeLogical> &&) {
 489             // TODO: defined operator
 490             messages.Say("LOGICAL cannot be negated"_err_en_US);
 491             return NoExpr();
 492           },
 493           [&](Expr<SomeDerived> &&) {
 494             // TODO: defined operator
 495             messages.Say("Operand cannot be negated"_err_en_US);
 496             return NoExpr();
 497           },
 498       },
 499       std::move(x.u));
 500 }
 501
 502 Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&x) {
 503   return common::visit(
 504       [](auto &&xk) { return AsCategoryExpr(LogicalNegation(std::move(xk))); },
 505       std::move(x.u));
 506 }
 507
 508 template <TypeCategory CAT>
 509 Expr<LogicalResult> PromoteAndRelate(
 510     RelationalOperator opr, Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
 511   return common::visit(
 512       [=](auto &&xy) {
 513         return PackageRelation(opr, std::move(xy[0]), std::move(xy[1]));
 514       },
 515       AsSameKindExprs(std::move(x), std::move(y)));
 516 }
 517
 518 std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
 519     RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {
 520   return common::visit(
 521       common::visitors{
 522           [=](Expr<SomeInteger> &&ix,
 523               Expr<SomeInteger> &&iy) -> std::optional<Expr<LogicalResult>> {
 524             return PromoteAndRelate(opr, std::move(ix), std::move(iy));
 525           },
 526           [=](Expr<SomeReal> &&rx,
 527               Expr<SomeReal> &&ry) -> std::optional<Expr<LogicalResult>> {
 528             return PromoteAndRelate(opr, std::move(rx), std::move(ry));
 529           },
 530           [&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
 531             return Relate(messages, opr, std::move(x),
 532                 AsGenericExpr(ConvertTo(rx, std::move(iy))));
 533           },
 534           [&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
 535             return Relate(messages, opr,
 536                 AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));
 537           },
 538           [&](Expr<SomeComplex> &&zx,
 539               Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {
 540             if (opr == RelationalOperator::EQ ||
 541                 opr == RelationalOperator::NE) {
 542               return PromoteAndRelate(opr, std::move(zx), std::move(zy));
 543             } else {
 544               messages.Say(
 545                   "COMPLEX data may be compared only for equality"_err_en_US);
 546               return std::nullopt;
 547             }
 548           },
 549           [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
 550             return Relate(messages, opr, std::move(x),
 551                 AsGenericExpr(ConvertTo(zx, std::move(iy))));
 552           },
 553           [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
 554             return Relate(messages, opr, std::move(x),
 555                 AsGenericExpr(ConvertTo(zx, std::move(ry))));
 556           },
 557           [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
 558             return Relate(messages, opr,
 559                 AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
 560           },
 561           [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
 562             return Relate(messages, opr,
 563                 AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
 564           },
 565           [&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
 566             return common::visit(
 567                 [&](auto &&cxk,
 568                     auto &&cyk) -> std::optional<Expr<LogicalResult>> {
 569                   using Ty = ResultType<decltype(cxk)>;
 570                   if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {
 571                     return PackageRelation(opr, std::move(cxk), std::move(cyk));
 572                   } else {
 573                     messages.Say(
 574                         "CHARACTER operands do not have same KIND"_err_en_US);
 575                     return std::nullopt;
 576                   }
 577                 },
 578                 std::move(cx.u), std::move(cy.u));
 579           },
 580           // Default case
 581           [&](auto &&, auto &&) {
 582             DIE("invalid types for relational operator");
 583             return std::optional<Expr<LogicalResult>>{};
 584           },
 585       },
 586       std::move(x.u), std::move(y.u));
 587 }
 588
 589 Expr<SomeLogical> BinaryLogicalOperation(
 590     LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {
 591   CHECK(opr != LogicalOperator::Not);
 592   return common::visit(
 593       [=](auto &&xy) {
 594         using Ty = ResultType<decltype(xy[0])>;
 595         return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
 596             opr, std::move(xy[0]), std::move(xy[1]))};
 597       },
 598       AsSameKindExprs(std::move(x), std::move(y)));
 599 }
 600
 601 template <TypeCategory TO>
 602 std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
 603   static_assert(common::IsNumericTypeCategory(TO));
 604   return common::visit(
 605       [=](auto &&cx) -> std::optional<Expr<SomeType>> {
 606         using cxType = std::decay_t<decltype(cx)>;
 607         if constexpr (!common::HasMember<cxType, TypelessExpression>) {
 608           if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
 609             return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};
 610           }
 611         }
 612         return std::nullopt;
 613       },
 614       std::move(x.u));
 615 }
 616
 617 std::optional<Expr<SomeType>> ConvertToType(
 618     const DynamicType &type, Expr<SomeType> &&x) {
 619   if (type.IsTypelessIntrinsicArgument()) {
 620     return std::nullopt;
 621   }
 622   switch (type.category()) {
 623   case TypeCategory::Integer:
 624     if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
 625       // Extension to C7109: allow BOZ literals to appear in integer contexts
 626       // when the type is unambiguous.
 627       return Expr<SomeType>{
 628           ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
 629     }
 630     return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));
 631   case TypeCategory::Real:
 632     if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
 633       return Expr<SomeType>{
 634           ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};
 635     }
 636     return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));
 637   case TypeCategory::Complex:
 638     return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));
 639   case TypeCategory::Character:
 640     if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
 641       auto converted{
 642           ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};
 643       if (auto length{type.GetCharLength()}) {
 644         converted = common::visit(
 645             [&](auto &&x) {
 646               using Ty = std::decay_t<decltype(x)>;
 647               using CharacterType = typename Ty::Result;
 648               return Expr<SomeCharacter>{
 649                   Expr<CharacterType>{SetLength<CharacterType::kind>{
 650                       std::move(x), std::move(*length)}}};
 651             },
 652             std::move(converted.u));
 653       }
 654       return Expr<SomeType>{std::move(converted)};
 655     }
 656     break;
 657   case TypeCategory::Logical:
 658     if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {
 659       return Expr<SomeType>{
 660           ConvertToKind<TypeCategory::Logical>(type.kind(), std::move(*cx))};
 661     }
 662     break;
 663   case TypeCategory::Derived:
 664     if (auto fromType{x.GetType()}) {
 665       if (type.IsTkCompatibleWith(*fromType)) {
 666         // "x" could be assigned or passed to "type", or appear in a
 667         // structure constructor as a value for a component with "type"
 668         return std::move(x);
 669       }
 670     }
 671     break;
 672   }
 673   return std::nullopt;
 674 }
 675
 676 std::optional<Expr<SomeType>> ConvertToType(
 677     const DynamicType &to, std::optional<Expr<SomeType>> &&x) {
 678   if (x) {
 679     return ConvertToType(to, std::move(*x));
 680   } else {
 681     return std::nullopt;
 682   }
 683 }
 684
 685 std::optional<Expr<SomeType>> ConvertToType(
 686     const Symbol &symbol, Expr<SomeType> &&x) {
 687   if (auto symType{DynamicType::From(symbol)}) {
 688     return ConvertToType(*symType, std::move(x));
 689   }
 690   return std::nullopt;
 691 }
 692
 693 std::optional<Expr<SomeType>> ConvertToType(
 694     const Symbol &to, std::optional<Expr<SomeType>> &&x) {
 695   if (x) {
 696     return ConvertToType(to, std::move(*x));
 697   } else {
 698     return std::nullopt;
 699   }
 700 }
 701
 702 bool IsAssumedRank(const Symbol &original) {
 703   if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
 704     if (assoc->rank()) {
 705       return false; // in SELECT RANK case
 706     }
 707   }
 708   const Symbol &symbol{semantics::ResolveAssociations(original)};
 709   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
 710     return details->IsAssumedRank();
 711   } else {
 712     return false;
 713   }
 714 }
 715
 716 bool IsAssumedRank(const ActualArgument &arg) {
 717   if (const auto *expr{arg.UnwrapExpr()}) {
 718     return IsAssumedRank(*expr);
 719   } else {
 720     const Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
 721     CHECK(assumedTypeDummy);
 722     return IsAssumedRank(*assumedTypeDummy);
 723   }
 724 }
 725
 726 bool IsCoarray(const ActualArgument &arg) {
 727   const auto *expr{arg.UnwrapExpr()};
 728   return expr && IsCoarray(*expr);
 729 }
 730
 731 bool IsCoarray(const Symbol &symbol) {
 732   return GetAssociationRoot(symbol).Corank() > 0;
 733 }
 734
 735 bool IsProcedure(const Expr<SomeType> &expr) {
 736   return std::holds_alternative<ProcedureDesignator>(expr.u);
 737 }
 738 bool IsFunction(const Expr<SomeType> &expr) {
 739   const auto *designator{std::get_if<ProcedureDesignator>(&expr.u)};
 740   return designator && designator->GetType().has_value();
 741 }
 742
 743 bool IsProcedurePointer(const Expr<SomeType> &expr) {
 744   return common::visit(common::visitors{
 745                            [](const NullPointer &) { return true; },
 746                            [](const ProcedureRef &) { return false; },
 747                            [&](const auto &) {
 748                              const Symbol *last{GetLastSymbol(expr)};
 749                              return last && IsProcedurePointer(*last);
 750                            },
 751                        },
 752       expr.u);
 753 }
 754
 755 bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
 756   return common::visit(common::visitors{
 757                            [](const NullPointer &) { return true; },
 758                            [](const ProcedureDesignator &) { return true; },
 759                            [](const ProcedureRef &) { return true; },
 760                            [&](const auto &) {
 761                              const Symbol *last{GetLastSymbol(expr)};
 762                              return last && IsProcedurePointer(*last);
 763                            },
 764                        },
 765       expr.u);
 766 }
 767
 768 template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
 769   return nullptr;
 770 }
 771
 772 template <typename T>
 773 inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
 774   return &func;
 775 }
 776
 777 template <typename T>
 778 inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
 779   return common::visit(
 780       [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
 781 }
 782
 783 // IsObjectPointer()
 784 bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
 785   if (IsNullObjectPointer(expr)) {
 786     return true;
 787   } else if (IsProcedurePointerTarget(expr)) {
 788     return false;
 789   } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
 790     return IsVariable(*funcRef);
 791   } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
 792     return IsPointer(symbol->GetUltimate());
 793   } else {
 794     return false;
 795   }
 796 }
 797
 798 const ProcedureRef *GetProcedureRef(const Expr<SomeType> &expr) {
 799   return UnwrapProcedureRef(expr);
 800 }
 801
 802 // IsNullPointer() & variations
 803
 804 template <bool IS_PROC_PTR> struct IsNullPointerHelper {
 805   template <typename A> bool operator()(const A &) const { return false; }
 806   bool operator()(const ProcedureRef &call) const {
 807     if constexpr (IS_PROC_PTR) {
 808       const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
 809       return intrinsic &&
 810           intrinsic->characteristics.value().attrs.test(
 811               characteristics::Procedure::Attr::NullPointer);
 812     } else {
 813       return false;
 814     }
 815   }
 816   template <typename T> bool operator()(const FunctionRef<T> &call) const {
 817     if constexpr (IS_PROC_PTR) {
 818       return false;
 819     } else {
 820       const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
 821       return intrinsic &&
 822           intrinsic->characteristics.value().attrs.test(
 823               characteristics::Procedure::Attr::NullPointer);
 824     }
 825   }
 826   template <typename T> bool operator()(const Designator<T> &x) const {
 827     if (const auto *component{std::get_if<Component>(&x.u)}) {
 828       if (const auto *baseSym{std::get_if<SymbolRef>(&component->base().u)}) {
 829         const Symbol &base{**baseSym};
 830         if (const auto *object{
 831                 base.detailsIf<semantics::ObjectEntityDetails>()}) {
 832           // TODO: nested component and array references
 833           if (IsNamedConstant(base) && object->init()) {
 834             if (auto structCons{
 835                     GetScalarConstantValue<SomeDerived>(*object->init())}) {
 836               auto iter{structCons->values().find(component->GetLastSymbol())};
 837               if (iter != structCons->values().end()) {
 838                 return (*this)(iter->second.value());
 839               }
 840             }
 841           }
 842         }
 843       }
 844     }
 845     return false;
 846   }
 847   bool operator()(const NullPointer &) const { return true; }
 848   template <typename T> bool operator()(const Parentheses<T> &x) const {
 849     return (*this)(x.left());
 850   }
 851   template <typename T> bool operator()(const Expr<T> &x) const {
 852     return common::visit(*this, x.u);
 853   }
 854 };
 855
 856 bool IsNullObjectPointer(const Expr<SomeType> &expr) {
 857   return IsNullPointerHelper<false>{}(expr);
 858 }
 859
 860 bool IsNullProcedurePointer(const Expr<SomeType> &expr) {
 861   return IsNullPointerHelper<true>{}(expr);
 862 }
 863
 864 bool IsNullPointer(const Expr<SomeType> &expr) {
 865   return IsNullObjectPointer(expr) || IsNullProcedurePointer(expr);
 866 }
 867
 868 bool IsBareNullPointer(const Expr<SomeType> *expr) {
 869   return expr && std::holds_alternative<NullPointer>(expr->u);
 870 }
 871
 872 // GetSymbolVector()
 873 auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
 874   if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
 875     if (IsVariable(details->expr()) && !GetProcedureRef(*details->expr())) {
 876       // associate(x => variable that is not a pointer returned by a function)
 877       return (*this)(details->expr());
 878     }
 879   }
 880   return {x.GetUltimate()};
 881 }
 882 auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
 883   Result result{(*this)(x.base())};
 884   result.emplace_back(x.GetLastSymbol());
 885   return result;
 886 }
 887 auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
 888   return GetSymbolVector(x.base());
 889 }
 890 auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {
 891   return x.base();
 892 }
 893
 894 const Symbol *GetLastTarget(const SymbolVector &symbols) {
 895   auto end{std::crend(symbols)};
 896   // N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.
 897   auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {
 898     return x.attrs().HasAny(
 899         {semantics::Attr::POINTER, semantics::Attr::TARGET});
 900   })};
 901   return iter == end ? nullptr : &**iter;
 902 }
 903
 904 struct CollectSymbolsHelper
 905     : public SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet> {
 906   using Base = SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet>;
 907   CollectSymbolsHelper() : Base{*this} {}
 908   using Base::operator();
 909   semantics::UnorderedSymbolSet operator()(const Symbol &symbol) const {
 910     return {symbol};
 911   }
 912 };
 913 template <typename A> semantics::UnorderedSymbolSet CollectSymbols(const A &x) {
 914   return CollectSymbolsHelper{}(x);
 915 }
 916 template semantics::UnorderedSymbolSet CollectSymbols(const Expr<SomeType> &);
 917 template semantics::UnorderedSymbolSet CollectSymbols(
 918     const Expr<SomeInteger> &);
 919 template semantics::UnorderedSymbolSet CollectSymbols(
 920     const Expr<SubscriptInteger> &);
 921
 922 // HasVectorSubscript()
 923 struct HasVectorSubscriptHelper : public AnyTraverse<HasVectorSubscriptHelper> {
 924   using Base = AnyTraverse<HasVectorSubscriptHelper>;
 925   HasVectorSubscriptHelper() : Base{*this} {}
 926   using Base::operator();
 927   bool operator()(const Subscript &ss) const {
 928     return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
 929   }
 930   bool operator()(const ProcedureRef &) const {
 931     return false; // don't descend into function call arguments
 932   }
 933 };
 934
 935 bool HasVectorSubscript(const Expr<SomeType> &expr) {
 936   return HasVectorSubscriptHelper{}(expr);
 937 }
 938
 939 parser::Message *AttachDeclaration(
 940     parser::Message &message, const Symbol &symbol) {
 941   const Symbol *unhosted{&symbol};
 942   while (
 943       const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
 944     unhosted = &assoc->symbol();
 945   }
 946   if (const auto *binding{
 947           unhosted->detailsIf<semantics::ProcBindingDetails>()}) {
 948     if (binding->symbol().name() != symbol.name()) {
 949       message.Attach(binding->symbol().name(),
 950           "Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(),
 951           symbol.owner().GetName().value(), binding->symbol().name());
 952       return &message;
 953     }
 954     unhosted = &binding->symbol();
 955   }
 956   if (const auto *use{symbol.detailsIf<semantics::UseDetails>()}) {
 957     message.Attach(use->location(),
 958         "'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
 959         unhosted->name(), GetUsedModule(*use).name());
 960   } else {
 961     message.Attach(
 962         unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
 963   }
 964   return &message;
 965 }
 966
 967 parser::Message *AttachDeclaration(
 968     parser::Message *message, const Symbol &symbol) {
 969   return message ? AttachDeclaration(*message, symbol) : nullptr;
 970 }
 971
 972 class FindImpureCallHelper
 973     : public AnyTraverse<FindImpureCallHelper, std::optional<std::string>> {
 974   using Result = std::optional<std::string>;
 975   using Base = AnyTraverse<FindImpureCallHelper, Result>;
 976
 977 public:
 978   explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
 979   using Base::operator();
 980   Result operator()(const ProcedureRef &call) const {
 981     if (auto chars{
 982             characteristics::Procedure::Characterize(call.proc(), context_)}) {
 983       if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
 984         return (*this)(call.arguments());
 985       }
 986     }
 987     return call.proc().GetName();
 988   }
 989
 990 private:
 991   FoldingContext &context_;
 992 };
 993
 994 std::optional<std::string> FindImpureCall(
 995     FoldingContext &context, const Expr<SomeType> &expr) {
 996   return FindImpureCallHelper{context}(expr);
 997 }
 998 std::optional<std::string> FindImpureCall(
 999     FoldingContext &context, const ProcedureRef &proc) {
1000   return FindImpureCallHelper{context}(proc);
1001 }
1002
1003 // Common handling for procedure pointer compatibility of left- and right-hand
1004 // sides.  Returns nullopt if they're compatible.  Otherwise, it returns a
1005 // message that needs to be augmented by the names of the left and right sides
1006 // and the content of the "whyNotCompatible" string.
1007 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
1008     const std::optional<characteristics::Procedure> &lhsProcedure,
1009     const characteristics::Procedure *rhsProcedure,
1010     const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible) {
1011   std::optional<parser::MessageFixedText> msg;
1012   if (!lhsProcedure) {
1013     msg = "In assignment to object %s, the target '%s' is a procedure"
1014           " designator"_err_en_US;
1015   } else if (!rhsProcedure) {
1016     msg = "In assignment to procedure %s, the characteristics of the target"
1017           " procedure '%s' could not be determined"_err_en_US;
1018   } else if (!isCall && lhsProcedure->functionResult &&
1019       rhsProcedure->functionResult &&
1020       !lhsProcedure->functionResult->IsCompatibleWith(
1021           *rhsProcedure->functionResult, &whyNotCompatible)) {
1022     msg =
1023         "Function %s associated with incompatible function designator '%s': %s"_err_en_US;
1024   } else if (lhsProcedure->IsCompatibleWith(
1025                  *rhsProcedure, &whyNotCompatible, specificIntrinsic)) {
1026     // OK
1027   } else if (isCall) {
1028     msg = "Procedure %s associated with result of reference to function '%s'"
1029           " that is an incompatible procedure pointer: %s"_err_en_US;
1030   } else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
1031     msg = "PURE procedure %s may not be associated with non-PURE"
1032           " procedure designator '%s'"_err_en_US;
1033   } else if (lhsProcedure->IsFunction() && rhsProcedure->IsSubroutine()) {
1034     msg = "Function %s may not be associated with subroutine"
1035           " designator '%s'"_err_en_US;
1036   } else if (lhsProcedure->IsSubroutine() && rhsProcedure->IsFunction()) {
1037     msg = "Subroutine %s may not be associated with function"
1038           " designator '%s'"_err_en_US;
1039   } else if (lhsProcedure->HasExplicitInterface() &&
1040       !rhsProcedure->HasExplicitInterface()) {
1041     // Section 10.2.2.4, paragraph 3 prohibits associating a procedure pointer
1042     // that has an explicit interface with a procedure whose characteristics
1043     // don't match.  That's the case if the target procedure has an implicit
1044     // interface.  But this case is allowed by several other compilers as long
1045     // as the explicit interface can be called via an implicit interface.
1046     if (!lhsProcedure->CanBeCalledViaImplicitInterface()) {
1047       msg = "Procedure %s with explicit interface that cannot be called via "
1048             "an implicit interface cannot be associated with procedure "
1049             "designator with an implicit interface"_err_en_US;
1050     }
1051   } else if (!lhsProcedure->HasExplicitInterface() &&
1052       rhsProcedure->HasExplicitInterface()) {
1053     // OK if the target can be called via an implicit interface
1054     if (!rhsProcedure->CanBeCalledViaImplicitInterface() &&
1055         !specificIntrinsic) {
1056       msg = "Procedure %s with implicit interface may not be associated "
1057             "with procedure designator '%s' with explicit interface that "
1058             "cannot be called via an implicit interface"_err_en_US;
1059     }
1060   } else {
1061     msg = "Procedure %s associated with incompatible procedure"
1062           " designator '%s': %s"_err_en_US;
1063   }
1064   return msg;
1065 }
1066
1067 // GetLastPointerSymbol()
1068 static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {
1069   return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;
1070 }
1071 static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) {
1072   return GetLastPointerSymbol(*symbol);
1073 }
1074 static const Symbol *GetLastPointerSymbol(const Component &x) {
1075   const Symbol &c{x.GetLastSymbol()};
1076   return IsPointer(c) ? &c : GetLastPointerSymbol(x.base());
1077 }
1078 static const Symbol *GetLastPointerSymbol(const NamedEntity &x) {
1079   const auto *c{x.UnwrapComponent()};
1080   return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol());
1081 }
1082 static const Symbol *GetLastPointerSymbol(const ArrayRef &x) {
1083   return GetLastPointerSymbol(x.base());
1084 }
1085 static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) {
1086   return nullptr;
1087 }
1088 const Symbol *GetLastPointerSymbol(const DataRef &x) {
1089   return common::visit(
1090       [](const auto &y) { return GetLastPointerSymbol(y); }, x.u);
1091 }
1092
1093 template <TypeCategory TO, TypeCategory FROM>
1094 static std::optional<Expr<SomeType>> DataConstantConversionHelper(
1095     FoldingContext &context, const DynamicType &toType,
1096     const Expr<SomeType> &expr) {
1097   DynamicType sizedType{FROM, toType.kind()};
1098   if (auto sized{
1099           Fold(context, ConvertToType(sizedType, Expr<SomeType>{expr}))}) {
1100     if (const auto *someExpr{UnwrapExpr<Expr<SomeKind<FROM>>>(*sized)}) {
1101       return common::visit(
1102           [](const auto &w) -> std::optional<Expr<SomeType>> {
1103             using FromType = typename std::decay_t<decltype(w)>::Result;
1104             static constexpr int kind{FromType::kind};
1105             if constexpr (IsValidKindOfIntrinsicType(TO, kind)) {
1106               if (const auto *fromConst{UnwrapExpr<Constant<FromType>>(w)}) {
1107                 using FromWordType = typename FromType::Scalar;
1108                 using LogicalType = value::Logical<FromWordType::bits>;
1109                 using ElementType =
1110                     std::conditional_t<TO == TypeCategory::Logical, LogicalType,
1111                         typename LogicalType::Word>;
1112                 std::vector<ElementType> values;
1113                 auto at{fromConst->lbounds()};
1114                 auto shape{fromConst->shape()};
1115                 for (auto n{GetSize(shape)}; n-- > 0;
1116                      fromConst->IncrementSubscripts(at)) {
1117                   auto elt{fromConst->At(at)};
1118                   if constexpr (TO == TypeCategory::Logical) {
1119                     values.emplace_back(std::move(elt));
1120                   } else {
1121                     values.emplace_back(elt.word());
1122                   }
1123                 }
1124                 return {AsGenericExpr(AsExpr(Constant<Type<TO, kind>>{
1125                     std::move(values), std::move(shape)}))};
1126               }
1127             }
1128             return std::nullopt;
1129           },
1130           someExpr->u);
1131     }
1132   }
1133   return std::nullopt;
1134 }
1135
1136 std::optional<Expr<SomeType>> DataConstantConversionExtension(
1137     FoldingContext &context, const DynamicType &toType,
1138     const Expr<SomeType> &expr0) {
1139   Expr<SomeType> expr{Fold(context, Expr<SomeType>{expr0})};
1140   if (!IsActuallyConstant(expr)) {
1141     return std::nullopt;
1142   }
1143   if (auto fromType{expr.GetType()}) {
1144     if (toType.category() == TypeCategory::Logical &&
1145         fromType->category() == TypeCategory::Integer) {
1146       return DataConstantConversionHelper<TypeCategory::Logical,
1147           TypeCategory::Integer>(context, toType, expr);
1148     }
1149     if (toType.category() == TypeCategory::Integer &&
1150         fromType->category() == TypeCategory::Logical) {
1151       return DataConstantConversionHelper<TypeCategory::Integer,
1152           TypeCategory::Logical>(context, toType, expr);
1153     }
1154   }
1155   return std::nullopt;
1156 }
1157
1158 bool IsAllocatableOrPointerObject(
1159     const Expr<SomeType> &expr, FoldingContext &context) {
1160   const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
1161   return (sym && semantics::IsAllocatableOrPointer(*sym)) ||
1162       evaluate::IsObjectPointer(expr, context);
1163 }
1164
1165 bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
1166   // Allocatable sub-objects are not themselves allocatable (9.5.3.1 NOTE 2).
1167   if (const semantics::Symbol *
1168       sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) {
1169     return semantics::IsAllocatable(sym->GetUltimate());
1170   }
1171   return false;
1172 }
1173
1174 bool MayBePassedAsAbsentOptional(
1175     const Expr<SomeType> &expr, FoldingContext &context) {
1176   const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
1177   // 15.5.2.12 1. is pretty clear that an unallocated allocatable/pointer actual
1178   // may be passed to a non-allocatable/non-pointer optional dummy. Note that
1179   // other compilers (like nag, nvfortran, ifort, gfortran and xlf) seems to
1180   // ignore this point in intrinsic contexts (e.g CMPLX argument).
1181   return (sym && semantics::IsOptional(*sym)) ||
1182       IsAllocatableOrPointerObject(expr, context);
1183 }
1184
1185 std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
1186     const Expr<SomeType> &expr, const DynamicType &type) {
1187   if (std::optional<std::string> chValue{GetScalarConstantValue<Ascii>(expr)}) {
1188     // Pad on the right with spaces when short, truncate the right if long.
1189     // TODO: big-endian targets
1190     auto bytes{static_cast<std::size_t>(
1191         ToInt64(type.MeasureSizeInBytes(context, false)).value())};
1192     BOZLiteralConstant bits{0};
1193     for (std::size_t j{0}; j < bytes; ++j) {
1194       char ch{j >= chValue->size() ? ' ' : chValue->at(j)};
1195       BOZLiteralConstant chBOZ{static_cast<unsigned char>(ch)};
1196       bits = bits.IOR(chBOZ.SHIFTL(8 * j));
1197     }
1198     return ConvertToType(type, Expr<SomeType>{bits});
1199   } else {
1200     return std::nullopt;
1201   }
1202 }
1203
1204 } // namespace Fortran::evaluate
1205
1206 namespace Fortran::semantics {
1207
1208 const Symbol &ResolveAssociations(const Symbol &original) {
1209   const Symbol &symbol{original.GetUltimate()};
1210   if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1211     if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
1212       return ResolveAssociations(*nested);
1213     }
1214   }
1215   return symbol;
1216 }
1217
1218 const Symbol &ResolveAssociationsExceptSelectRank(const Symbol &original) {
1219   const Symbol &symbol{original.GetUltimate()};
1220   if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1221     if (!details->rank()) {
1222       if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
1223         return ResolveAssociations(*nested);
1224       }
1225     }
1226   }
1227   return symbol;
1228 }
1229
1230 // When a construct association maps to a variable, and that variable
1231 // is not an array with a vector-valued subscript, return the base
1232 // Symbol of that variable, else nullptr.  Descends into other construct
1233 // associations when one associations maps to another.
1234 static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
1235   if (const auto &expr{details.expr()}) {
1236     if (IsVariable(*expr) && !HasVectorSubscript(*expr)) {
1237       if (const Symbol * varSymbol{GetFirstSymbol(*expr)}) {
1238         return &GetAssociationRoot(*varSymbol);
1239       }
1240     }
1241   }
1242   return nullptr;
1243 }
1244
1245 const Symbol &GetAssociationRoot(const Symbol &original) {
1246   const Symbol &symbol{ResolveAssociations(original)};
1247   if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1248     if (const Symbol * root{GetAssociatedVariable(*details)}) {
1249       return *root;
1250     }
1251   }
1252   return symbol;
1253 }
1254
1255 const Symbol *GetMainEntry(const Symbol *symbol) {
1256   if (symbol) {
1257     if (const auto *subpDetails{symbol->detailsIf<SubprogramDetails>()}) {
1258       if (const Scope * scope{subpDetails->entryScope()}) {
1259         if (const Symbol * main{scope->symbol()}) {
1260           return main;
1261         }
1262       }
1263     }
1264   }
1265   return symbol;
1266 }
1267
1268 bool IsVariableName(const Symbol &original) {
1269   const Symbol &ultimate{original.GetUltimate()};
1270   return !IsNamedConstant(ultimate) &&
1271       (ultimate.has<ObjectEntityDetails>() ||
1272           ultimate.has<AssocEntityDetails>());
1273 }
1274
1275 bool IsPureProcedure(const Symbol &original) {
1276   // An ENTRY is pure if its containing subprogram is
1277   const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
1278   if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
1279     if (procDetails->procInterface()) {
1280       // procedure with a pure interface
1281       return IsPureProcedure(*procDetails->procInterface());
1282     }
1283   } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
1284     return IsPureProcedure(details->symbol());
1285   } else if (!IsProcedure(symbol)) {
1286     return false;
1287   }
1288   if (IsStmtFunction(symbol)) {
1289     // Section 15.7(1) states that a statement function is PURE if it does not
1290     // reference an IMPURE procedure or a VOLATILE variable
1291     if (const auto &expr{symbol.get<SubprogramDetails>().stmtFunction()}) {
1292       for (const SymbolRef &ref : evaluate::CollectSymbols(*expr)) {
1293         if (&*ref == &symbol) {
1294           return false; // error recovery, recursion is caught elsewhere
1295         }
1296         if (IsFunction(*ref) && !IsPureProcedure(*ref)) {
1297           return false;
1298         }
1299         if (ref->GetUltimate().attrs().test(Attr::VOLATILE)) {
1300           return false;
1301         }
1302       }
1303     }
1304     return true; // statement function was not found to be impure
1305   }
1306   return symbol.attrs().test(Attr::PURE) ||
1307       (symbol.attrs().test(Attr::ELEMENTAL) &&
1308           !symbol.attrs().test(Attr::IMPURE));
1309 }
1310
1311 bool IsPureProcedure(const Scope &scope) {
1312   const Symbol *symbol{scope.GetSymbol()};
1313   return symbol && IsPureProcedure(*symbol);
1314 }
1315
1316 bool IsElementalProcedure(const Symbol &original) {
1317   // An ENTRY is elemental if its containing subprogram is
1318   const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
1319   if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
1320     if (const Symbol * procInterface{procDetails->procInterface()}) {
1321       // procedure with an elemental interface, ignoring the elemental
1322       // aspect of intrinsic functions
1323       return !procInterface->attrs().test(Attr::INTRINSIC) &&
1324           IsElementalProcedure(*procInterface);
1325     }
1326   } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
1327     return !details->symbol().attrs().test(Attr::INTRINSIC) &&
1328         IsElementalProcedure(details->symbol());
1329   } else if (!IsProcedure(symbol)) {
1330     return false;
1331   }
1332   return symbol.attrs().test(Attr::ELEMENTAL);
1333 }
1334
1335 bool IsFunction(const Symbol &symbol) {
1336   const Symbol &ultimate{symbol.GetUltimate()};
1337   return ultimate.test(Symbol::Flag::Function) ||
1338       (!ultimate.test(Symbol::Flag::Subroutine) &&
1339           common::visit(
1340               common::visitors{
1341                   [](const SubprogramDetails &x) { return x.isFunction(); },
1342                   [](const ProcEntityDetails &x) {
1343                     const Symbol *ifc{x.procInterface()};
1344                     return x.type() || (ifc && IsFunction(*ifc));
1345                   },
1346                   [](const ProcBindingDetails &x) {
1347                     return IsFunction(x.symbol());
1348                   },
1349                   [](const auto &) { return false; },
1350               },
1351               ultimate.details()));
1352 }
1353
1354 bool IsFunction(const Scope &scope) {
1355   const Symbol *symbol{scope.GetSymbol()};
1356   return symbol && IsFunction(*symbol);
1357 }
1358
1359 bool IsProcedure(const Symbol &symbol) {
1360   return common::visit(common::visitors{
1361                            [&symbol](const SubprogramDetails &) {
1362                              const Scope *scope{symbol.scope()};
1363                              // Main programs & BLOCK DATA are not procedures.
1364                              return !scope ||
1365                                  scope->kind() == Scope::Kind::Subprogram;
1366                            },
1367                            [](const SubprogramNameDetails &) { return true; },
1368                            [](const ProcEntityDetails &) { return true; },
1369                            [](const GenericDetails &) { return true; },
1370                            [](const ProcBindingDetails &) { return true; },
1371                            [](const auto &) { return false; },
1372                        },
1373       symbol.GetUltimate().details());
1374 }
1375
1376 bool IsProcedure(const Scope &scope) {
1377   const Symbol *symbol{scope.GetSymbol()};
1378   return symbol && IsProcedure(*symbol);
1379 }
1380
1381 const Symbol *FindCommonBlockContaining(const Symbol &original) {
1382   const Symbol &root{GetAssociationRoot(original)};
1383   const auto *details{root.detailsIf<ObjectEntityDetails>()};
1384   return details ? details->commonBlock() : nullptr;
1385 }
1386
1387 bool IsProcedurePointer(const Symbol &original) {
1388   const Symbol &symbol{GetAssociationRoot(original)};
1389   return IsPointer(symbol) && IsProcedure(symbol);
1390 }
1391
1392 // 3.11 automatic data object
1393 bool IsAutomatic(const Symbol &original) {
1394   const Symbol &symbol{original.GetUltimate()};
1395   if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1396     if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {
1397       if (const DeclTypeSpec * type{symbol.GetType()}) {
1398         // If a type parameter value is not a constant expression, the
1399         // object is automatic.
1400         if (type->category() == DeclTypeSpec::Character) {
1401           if (const auto &length{
1402                   type->characterTypeSpec().length().GetExplicit()}) {
1403             if (!evaluate::IsConstantExpr(*length)) {
1404               return true;
1405             }
1406           }
1407         } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
1408           for (const auto &pair : derived->parameters()) {
1409             if (const auto &value{pair.second.GetExplicit()}) {
1410               if (!evaluate::IsConstantExpr(*value)) {
1411                 return true;
1412               }
1413             }
1414           }
1415         }
1416       }
1417       // If an array bound is not a constant expression, the object is
1418       // automatic.
1419       for (const ShapeSpec &dim : object->shape()) {
1420         if (const auto &lb{dim.lbound().GetExplicit()}) {
1421           if (!evaluate::IsConstantExpr(*lb)) {
1422             return true;
1423           }
1424         }
1425         if (const auto &ub{dim.ubound().GetExplicit()}) {
1426           if (!evaluate::IsConstantExpr(*ub)) {
1427             return true;
1428           }
1429         }
1430       }
1431     }
1432   }
1433   return false;
1434 }
1435
1436 bool IsSaved(const Symbol &original) {
1437   const Symbol &symbol{GetAssociationRoot(original)};
1438   const Scope &scope{symbol.owner()};
1439   const common::LanguageFeatureControl &features{
1440       scope.context().languageFeatures()};
1441   auto scopeKind{scope.kind()};
1442   if (symbol.has<AssocEntityDetails>()) {
1443     return false; // ASSOCIATE(non-variable)
1444   } else if (scopeKind == Scope::Kind::DerivedType) {
1445     return false; // this is a component
1446   } else if (symbol.attrs().test(Attr::SAVE)) {
1447     return true; // explicit SAVE attribute
1448   } else if (IsDummy(symbol) || IsFunctionResult(symbol) ||
1449       IsAutomatic(symbol) || IsNamedConstant(symbol)) {
1450     return false;
1451   } else if (scopeKind == Scope::Kind::Module ||
1452       (scopeKind == Scope::Kind::MainProgram &&
1453           (symbol.attrs().test(Attr::TARGET) || evaluate::IsCoarray(symbol)))) {
1454     // 8.5.16p4
1455     // In main programs, implied SAVE matters only for pointer
1456     // initialization targets and coarrays.
1457     // BLOCK DATA entities must all be in COMMON,
1458     // which was checked above.
1459     return true;
1460   } else if (scopeKind == Scope::Kind::MainProgram &&
1461       (features.IsEnabled(common::LanguageFeature::SaveMainProgram) ||
1462           (features.IsEnabled(
1463                common::LanguageFeature::SaveBigMainProgramVariables) &&
1464               symbol.size() > 32))) {
1465     // With SaveBigMainProgramVariables, keeping all unsaved main program
1466     // variables of 32 bytes or less on the stack allows keeping numerical and
1467     // logical scalars, small scalar characters or derived, small arrays, and
1468     // scalar descriptors on the stack. This leaves more room for lower level
1469     // optimizers to do register promotion or get easy aliasing information.
1470     return true;
1471   } else if (features.IsEnabled(common::LanguageFeature::DefaultSave) &&
1472       (scopeKind == Scope::Kind::MainProgram ||
1473           (scope.kind() == Scope::Kind::Subprogram &&
1474               !(scope.symbol() &&
1475                   scope.symbol()->attrs().test(Attr::RECURSIVE))))) {
1476     // -fno-automatic/-save/-Msave option applies to all objects in executable
1477     // main programs and subprograms unless they are explicitly RECURSIVE.
1478     return true;
1479   } else if (symbol.test(Symbol::Flag::InDataStmt)) {
1480     return true;
1481   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
1482              object && object->init()) {
1483     return true;
1484   } else if (IsProcedurePointer(symbol) && symbol.has<ProcEntityDetails>() &&
1485       symbol.get<ProcEntityDetails>().init()) {
1486     return true;
1487   } else if (scope.hasSAVE()) {
1488     return true; // bare SAVE statement
1489   } else if (const Symbol * block{FindCommonBlockContaining(symbol)};
1490              block && block->attrs().test(Attr::SAVE)) {
1491     return true; // in COMMON with SAVE
1492   } else {
1493     return false;
1494   }
1495 }
1496
1497 bool IsDummy(const Symbol &symbol) {
1498   return common::visit(
1499       common::visitors{[](const EntityDetails &x) { return x.isDummy(); },
1500           [](const ObjectEntityDetails &x) { return x.isDummy(); },
1501           [](const ProcEntityDetails &x) { return x.isDummy(); },
1502           [](const SubprogramDetails &x) { return x.isDummy(); },
1503           [](const auto &) { return false; }},
1504       ResolveAssociations(symbol).details());
1505 }
1506
1507 bool IsAssumedShape(const Symbol &symbol) {
1508   const Symbol &ultimate{ResolveAssociations(symbol)};
1509   const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
1510   return object && object->CanBeAssumedShape() &&
1511       !semantics::IsAllocatableOrPointer(ultimate);
1512 }
1513
1514 bool IsDeferredShape(const Symbol &symbol) {
1515   const Symbol &ultimate{ResolveAssociations(symbol)};
1516   const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
1517   return object && object->CanBeDeferredShape() &&
1518       semantics::IsAllocatableOrPointer(ultimate);
1519 }
1520
1521 bool IsFunctionResult(const Symbol &original) {
1522   const Symbol &symbol{GetAssociationRoot(original)};
1523   return common::visit(
1524       common::visitors{
1525           [](const EntityDetails &x) { return x.isFuncResult(); },
1526           [](const ObjectEntityDetails &x) { return x.isFuncResult(); },
1527           [](const ProcEntityDetails &x) { return x.isFuncResult(); },
1528           [](const auto &) { return false; },
1529       },
1530       symbol.details());
1531 }
1532
1533 bool IsKindTypeParameter(const Symbol &symbol) {
1534   const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1535   return param && param->attr() == common::TypeParamAttr::Kind;
1536 }
1537
1538 bool IsLenTypeParameter(const Symbol &symbol) {
1539   const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1540   return param && param->attr() == common::TypeParamAttr::Len;
1541 }
1542
1543 bool IsExtensibleType(const DerivedTypeSpec *derived) {
1544   return derived && !IsIsoCType(derived) &&
1545       !derived->typeSymbol().attrs().test(Attr::BIND_C) &&
1546       !derived->typeSymbol().get<DerivedTypeDetails>().sequence();
1547 }
1548
1549 bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {
1550   if (!derived) {
1551     return false;
1552   } else {
1553     const auto &symbol{derived->typeSymbol()};
1554     return &symbol.owner() == symbol.owner().context().GetBuiltinsScope() &&
1555         symbol.name() == "__builtin_"s + name;
1556   }
1557 }
1558
1559 bool IsBuiltinCPtr(const Symbol &symbol) {
1560   if (const DeclTypeSpec *declType = symbol.GetType())
1561     if (const DerivedTypeSpec *derived = declType->AsDerived())
1562       return IsIsoCType(derived);
1563   return false;
1564 }
1565
1566 bool IsIsoCType(const DerivedTypeSpec *derived) {
1567   return IsBuiltinDerivedType(derived, "c_ptr") ||
1568       IsBuiltinDerivedType(derived, "c_funptr");
1569 }
1570
1571 bool IsTeamType(const DerivedTypeSpec *derived) {
1572   return IsBuiltinDerivedType(derived, "team_type");
1573 }
1574
1575 bool IsBadCoarrayType(const DerivedTypeSpec *derived) {
1576   return IsTeamType(derived) || IsIsoCType(derived);
1577 }
1578
1579 bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
1580   return IsBuiltinDerivedType(derivedTypeSpec, "event_type") ||
1581       IsBuiltinDerivedType(derivedTypeSpec, "lock_type");
1582 }
1583
1584 int CountLenParameters(const DerivedTypeSpec &type) {
1585   return llvm::count_if(
1586       type.parameters(), [](const auto &pair) { return pair.second.isLen(); });
1587 }
1588
1589 int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
1590   return llvm::count_if(type.parameters(), [](const auto &pair) {
1591     if (!pair.second.isLen()) {
1592       return false;
1593     } else if (const auto &expr{pair.second.GetExplicit()}) {
1594       return !IsConstantExpr(*expr);
1595     } else {
1596       return true;
1597     }
1598   });
1599 }
1600
1601 // Are the type parameters of type1 compile-time compatible with the
1602 // corresponding kind type parameters of type2?  Return true if all constant
1603 // valued parameters are equal.
1604 // Used to check assignment statements and argument passing.  See 15.5.2.4(4)
1605 bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &type1,
1606     const semantics::DerivedTypeSpec &type2) {
1607   for (const auto &[name, param1] : type1.parameters()) {
1608     if (semantics::MaybeIntExpr paramExpr1{param1.GetExplicit()}) {
1609       if (IsConstantExpr(*paramExpr1)) {
1610         const semantics::ParamValue *param2{type2.FindParameter(name)};
1611         if (param2) {
1612           if (semantics::MaybeIntExpr paramExpr2{param2->GetExplicit()}) {
1613             if (IsConstantExpr(*paramExpr2)) {
1614               if (ToInt64(*paramExpr1) != ToInt64(*paramExpr2)) {
1615                 return false;
1616               }
1617             }
1618           }
1619         }
1620       }
1621     }
1622   }
1623   return true;
1624 }
1625
1626 const Symbol &GetUsedModule(const UseDetails &details) {
1627   return DEREF(details.symbol().owner().symbol());
1628 }
1629
1630 static const Symbol *FindFunctionResult(
1631     const Symbol &original, UnorderedSymbolSet &seen) {
1632   const Symbol &root{GetAssociationRoot(original)};
1633   ;
1634   if (!seen.insert(root).second) {
1635     return nullptr; // don't loop
1636   }
1637   return common::visit(
1638       common::visitors{[](const SubprogramDetails &subp) {
1639                          return subp.isFunction() ? &subp.result() : nullptr;
1640                        },
1641           [&](const ProcEntityDetails &proc) {
1642             const Symbol *iface{proc.procInterface()};
1643             return iface ? FindFunctionResult(*iface, seen) : nullptr;
1644           },
1645           [&](const ProcBindingDetails &binding) {
1646             return FindFunctionResult(binding.symbol(), seen);
1647           },
1648           [](const auto &) -> const Symbol * { return nullptr; }},
1649       root.details());
1650 }
1651
1652 const Symbol *FindFunctionResult(const Symbol &symbol) {
1653   UnorderedSymbolSet seen;
1654   return FindFunctionResult(symbol, seen);
1655 }
1656
1657 // These are here in Evaluate/tools.cpp so that Evaluate can use
1658 // them; they cannot be defined in symbol.h due to the dependence
1659 // on Scope.
1660
1661 bool SymbolSourcePositionCompare::operator()(
1662     const SymbolRef &x, const SymbolRef &y) const {
1663   return x->GetSemanticsContext().allCookedSources().Precedes(
1664       x->name(), y->name());
1665 }
1666 bool SymbolSourcePositionCompare::operator()(
1667     const MutableSymbolRef &x, const MutableSymbolRef &y) const {
1668   return x->GetSemanticsContext().allCookedSources().Precedes(
1669       x->name(), y->name());
1670 }
1671
1672 SemanticsContext &Symbol::GetSemanticsContext() const {
1673   return DEREF(owner_).context();
1674 }
1675
1676 bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y) {
1677   if (x && y) {
1678     if (auto xDt{evaluate::DynamicType::From(*x)}) {
1679       if (auto yDt{evaluate::DynamicType::From(*y)}) {
1680         return xDt->IsTkCompatibleWith(*yDt);
1681       }
1682     }
1683   }
1684   return false;
1685 }
1686
1687 } // namespace Fortran::semantics