//===-- lib/Semantics/expression.cpp --------------------------------------===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//

#include "flang/Semantics/expression.h"
#include "check-call.h"
#include "pointer-assignment.h"
#include "resolve-names-utils.h"
#include "resolve-names.h"
#include "flang/Common/idioms.h"
#include "flang/Common/type-kinds.h"
#include "flang/Evaluate/common.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/tools.h"
#include "flang/Parser/characters.h"
#include "flang/Parser/dump-parse-tree.h"
#include "flang/Parser/parse-tree-visitor.h"
#include "flang/Parser/parse-tree.h"
#include "flang/Semantics/scope.h"
#include "flang/Semantics/semantics.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "flang/Support/Fortran.h"
#include "llvm/Support/raw_ostream.h"
#include <algorithm>
#include <functional>
#include <optional>
#include <set>
#include <vector>

// Typedef for optional generic expressions (ubiquitous in this file)
using MaybeExpr =
    std::optional<Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>;

// Much of the code that implements semantic analysis of expressions is
// tightly coupled with their typed representations in lib/Evaluate,
// and appears here in namespace Fortran::evaluate for convenience.
namespace Fortran::evaluate {

using common::LanguageFeature;
using common::NumericOperator;
using common::TypeCategory;

static inline std::string ToUpperCase(std::string_view str) {
  return parser::ToUpperCaseLetters(str);
}

struct DynamicTypeWithLength : public DynamicType {
  explicit DynamicTypeWithLength(const DynamicType &t) : DynamicType{t} {}
  std::optional<Expr<SubscriptInteger>> LEN() const;
  std::optional<Expr<SubscriptInteger>> length;
};

std::optional<Expr<SubscriptInteger>> DynamicTypeWithLength::LEN() const {
  if (length) {
    return length;
  } else {
    return GetCharLength();
  }
}

static std::optional<DynamicTypeWithLength> AnalyzeTypeSpec(
    const std::optional<parser::TypeSpec> &spec, FoldingContext &context) {
  if (spec) {
    if (const semantics::DeclTypeSpec *typeSpec{spec->declTypeSpec}) {
      // Name resolution sets TypeSpec::declTypeSpec only when it's valid
      // (viz., an intrinsic type with valid known kind or a non-polymorphic
      // & non-ABSTRACT derived type).
      if (const semantics::IntrinsicTypeSpec *intrinsic{
              typeSpec->AsIntrinsic()}) {
        TypeCategory category{intrinsic->category()};
        if (auto optKind{ToInt64(intrinsic->kind())}) {
          int kind{static_cast<int>(*optKind)};
          if (category == TypeCategory::Character) {
            const semantics::CharacterTypeSpec &cts{
                typeSpec->characterTypeSpec()};
            const semantics::ParamValue &len{cts.length()};
            if (len.isAssumed() || len.isDeferred()) {
              context.messages().Say(
                  "A length specifier of '*' or ':' may not appear in the type of an array constructor"_err_en_US);
            }
            DynamicTypeWithLength type{DynamicType{kind, len}};
            if (auto lenExpr{type.LEN()}) {
              type.length = Fold(context,
                  AsExpr(Extremum<SubscriptInteger>{Ordering::Greater,
                      Expr<SubscriptInteger>{0}, std::move(*lenExpr)}));
            }
            return type;
          } else {
            return DynamicTypeWithLength{DynamicType{category, kind}};
          }
        }
      } else if (const semantics::DerivedTypeSpec *derived{
                     typeSpec->AsDerived()}) {
        return DynamicTypeWithLength{DynamicType{*derived}};
      }
    }
  }
  return std::nullopt;
}

// Utilities to set a source location, if we have one, on an actual argument,
// when it is statically present.
static void SetArgSourceLocation(ActualArgument &x, parser::CharBlock at) {
  x.set_sourceLocation(at);
}
static void SetArgSourceLocation(
    std::optional<ActualArgument> &x, parser::CharBlock at) {
  if (x) {
    x->set_sourceLocation(at);
  }
}
static void SetArgSourceLocation(
    std::optional<ActualArgument> &x, std::optional<parser::CharBlock> at) {
  if (x && at) {
    x->set_sourceLocation(*at);
  }
}

class ArgumentAnalyzer {
public:
  explicit ArgumentAnalyzer(ExpressionAnalyzer &context)
      : context_{context}, source_{context.GetContextualMessages().at()},
        isProcedureCall_{false} {}
  ArgumentAnalyzer(ExpressionAnalyzer &context, parser::CharBlock source,
      bool isProcedureCall = false)
      : context_{context}, source_{source}, isProcedureCall_{isProcedureCall} {}
  bool fatalErrors() const { return fatalErrors_; }
  ActualArguments &&GetActuals() {
    CHECK(!fatalErrors_);
    return std::move(actuals_);
  }
  const Expr<SomeType> &GetExpr(std::size_t i) const {
    return DEREF(actuals_.at(i).value().UnwrapExpr());
  }
  Expr<SomeType> &&MoveExpr(std::size_t i) {
    return std::move(DEREF(actuals_.at(i).value().UnwrapExpr()));
  }
  void Analyze(const common::Indirection<parser::Expr> &x) {
    Analyze(x.value());
  }
  void Analyze(const parser::Expr &x) {
    actuals_.emplace_back(AnalyzeExpr(x));
    SetArgSourceLocation(actuals_.back(), x.source);
    fatalErrors_ |= !actuals_.back();
  }
  void Analyze(const parser::Variable &);
  void Analyze(const parser::ActualArgSpec &, bool isSubroutine);
  void ConvertBOZOperand(std::optional<DynamicType> *thisType, std::size_t,
      std::optional<DynamicType> otherType);
  void ConvertBOZAssignmentRHS(const DynamicType &lhsType);

  bool IsIntrinsicRelational(
      RelationalOperator, const DynamicType &, const DynamicType &) const;
  bool IsIntrinsicLogical() const;
  bool IsIntrinsicNumeric(NumericOperator) const;
  bool IsIntrinsicConcat() const;

  bool CheckConformance();
  bool CheckAssignmentConformance();
  bool CheckConsequentTypesAndRanks(
      const ActualArgument::ConditionalArg &condArg);
  bool CheckForNullPointer(const char *where = "as an operand here");
  bool CheckForAssumedRank(const char *where = "as an operand here");

  bool AnyCUDADeviceData() const;
  // Returns true if an interface has been defined for an intrinsic operator
  // with one or more device operands.
  bool HasDeviceDefinedIntrinsicOpOverride(const char *) const;
  template <typename E> bool HasDeviceDefinedIntrinsicOpOverride(E opr) const {
    return HasDeviceDefinedIntrinsicOpOverride(
        context_.context().languageFeatures().GetNames(opr));
  }

  // Find and return a user-defined operator or report an error.
  // The provided message is used if there is no such operator.
  MaybeExpr TryDefinedOp(const char *, parser::MessageFixedText,
      bool isUserOp = false, bool checkForNullPointer = true);
  template <typename E>
  MaybeExpr TryDefinedOp(E opr, parser::MessageFixedText msg) {
    return TryDefinedOp(
        context_.context().languageFeatures().GetNames(opr), msg);
  }
  // Find and return a user-defined assignment
  std::optional<ProcedureRef> TryDefinedAssignment();
  std::optional<ProcedureRef> GetDefinedAssignmentProc(bool &isAmbiguous);
  std::optional<DynamicType> GetType(std::size_t) const;
  void Dump(llvm::raw_ostream &);

private:
  bool HasDeviceDefinedIntrinsicOpOverride(
      const std::vector<const char *> &) const;
  MaybeExpr TryDefinedOp(
      const std::vector<const char *> &, parser::MessageFixedText);
  MaybeExpr TryBoundOp(const Symbol &, int passIndex);
  std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
  std::optional<ActualArgument> AnalyzeVariable(const parser::Variable &);
  MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &);
  bool AreConformable() const;
  const Symbol *FindBoundOp(parser::CharBlock, int passIndex,
      const Symbol *&generic, bool isSubroutine, bool *isAmbiguous = nullptr);
  void AddAssignmentConversion(
      const DynamicType &lhsType, const DynamicType &rhsType);
  bool OkLogicalIntegerAssignment(TypeCategory lhs, TypeCategory rhs);
  int GetRank(std::size_t) const;
  bool IsBOZLiteral(std::size_t i) const {
    return evaluate::IsBOZLiteral(GetExpr(i));
  }
  void SayNoMatch(
      const std::string &, bool isAssignment = false, bool isAmbiguous = false);
  std::string TypeAsFortran(std::size_t);
  bool AnyUntypedOperand() const;
  bool AnyMissingOperand() const;

  ExpressionAnalyzer &context_;
  ActualArguments actuals_;
  parser::CharBlock source_;
  bool fatalErrors_{false};
  const bool isProcedureCall_; // false for user-defined op or assignment
};

// Wraps a data reference in a typed Designator<>, and a procedure
// or procedure pointer reference in a ProcedureDesignator.
MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
  const Symbol &last{ref.GetLastSymbol()};
  const Symbol &specific{BypassGeneric(last)};
  const Symbol &symbol{specific.GetUltimate()};
  if (semantics::IsProcedure(symbol)) {
    if (symbol.attrs().test(semantics::Attr::ABSTRACT)) {
      Say("Abstract procedure interface '%s' may not be used as a designator"_err_en_US,
          last.name());
    }
    if (auto *component{std::get_if<Component>(&ref.u)}) {
      if (!CheckDataRef(ref)) {
        return std::nullopt;
      }
      return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};
    } else if (!std::holds_alternative<SymbolRef>(ref.u)) {
      DIE("unexpected alternative in DataRef");
    } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {
      if (symbol.has<semantics::GenericDetails>()) {
        Say("'%s' is not a specific procedure"_err_en_US, last.name());
      } else if (IsProcedurePointer(specific)) {
        // For procedure pointers, retain associations so that data accesses
        // from client modules will work.
        return Expr<SomeType>{ProcedureDesignator{specific}};
      } else {
        return Expr<SomeType>{ProcedureDesignator{symbol}};
      }
    } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
                   symbol.name().ToString())};
               interface && !interface->isRestrictedSpecific) {
      SpecificIntrinsic intrinsic{
          symbol.name().ToString(), std::move(*interface)};
      intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
      return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
    } else {
      Say("'%s' is not an unrestricted specific intrinsic procedure"_err_en_US,
          last.name());
    }
    return std::nullopt;
  } else if (MaybeExpr result{AsGenericExpr(std::move(ref))}) {
    return result;
  } else if (semantics::HadUseError(
                 context_, GetContextualMessages().at(), &symbol)) {
    return std::nullopt;
  } else {
    if (!context_.HasError(last) && !context_.HasError(symbol)) {
      AttachDeclaration(
          Say("'%s' is not an object that can appear in an expression"_err_en_US,
              last.name()),
          symbol);
      context_.SetError(last);
    }
    return std::nullopt;
  }
}

// Returns false if any dimension could be empty (e.g. A(1:0)) or has an error
static bool FoldSubscripts(semantics::SemanticsContext &context,
    const Symbol &arraySymbol, std::vector<Subscript> &subscripts, Shape &lb,
    Shape &ub) {
  FoldingContext &foldingContext{context.foldingContext()};
  lb = GetLBOUNDs(foldingContext, NamedEntity{arraySymbol});
  CHECK(lb.size() >= subscripts.size());
  ub = GetUBOUNDs(foldingContext, NamedEntity{arraySymbol});
  CHECK(ub.size() >= subscripts.size());
  bool anyPossiblyEmptyDim{false};
  int dim{0};
  for (Subscript &ss : subscripts) {
    if (Triplet * triplet{std::get_if<Triplet>(&ss.u)}) {
      auto expr{Fold(foldingContext, triplet->stride())};
      auto stride{ToInt64(expr)};
      triplet->set_stride(std::move(expr));
      std::optional<ConstantSubscript> lower, upper;
      if (auto expr{triplet->lower()}) {
        *expr = Fold(foldingContext, std::move(*expr));
        lower = ToInt64(*expr);
        triplet->set_lower(std::move(*expr));
      } else {
        lower = ToInt64(lb[dim]);
      }
      if (auto expr{triplet->upper()}) {
        *expr = Fold(foldingContext, std::move(*expr));
        upper = ToInt64(*expr);
        triplet->set_upper(std::move(*expr));
      } else {
        upper = ToInt64(ub[dim]);
      }
      if (stride) {
        if (*stride == 0) {
          foldingContext.messages().Say(
              "Stride of triplet must not be zero"_err_en_US);
          return false; // error
        }
        if (lower && upper) {
          if (*stride > 0) {
            anyPossiblyEmptyDim |= *lower > *upper;
          } else {
            anyPossiblyEmptyDim |= *lower < *upper;
          }
        } else {
          anyPossiblyEmptyDim = true;
        }
      } else { // non-constant stride
        if (lower && upper && *lower == *upper) {
          // stride is not relevant
        } else {
          anyPossiblyEmptyDim = true;
        }
      }
    } else { // not triplet
      auto &expr{std::get<IndirectSubscriptIntegerExpr>(ss.u).value()};
      expr = Fold(foldingContext, std::move(expr));
      anyPossiblyEmptyDim |= expr.Rank() > 0; // vector subscript
    }
    ++dim;
  }
  return !anyPossiblyEmptyDim;
}

static void ValidateSubscriptValue(semantics::SemanticsContext &context,
    const Symbol &symbol, ConstantSubscript val,
    std::optional<ConstantSubscript> lb, std::optional<ConstantSubscript> ub,
    int dim, const char *co = "") {
  std::optional<parser::MessageFixedText> msg;
  std::optional<ConstantSubscript> bound;
  if (lb && val < *lb) {
    msg =
        "%ssubscript %jd is less than lower %sbound %jd for %sdimension %d of array"_errUnlessDead_en_US;
    bound = *lb;
  } else if (ub && val > *ub) {
    msg =
        "%ssubscript %jd is greater than upper %sbound %jd for %sdimension %d of array"_errUnlessDead_en_US;
    bound = *ub;
    if (dim + 1 == symbol.Rank() && IsDummy(symbol) && *bound == 1) {
      // Old-school overindexing of a dummy array isn't fatal when
      // it's on the last dimension and the extent is 1.
      msg->set_severity(parser::Severity::Warning);
    }
  }
  if (!msg) {
    return;
  }
  parser::ContextualMessages &messages{context.foldingContext().messages()};
  if (msg->severity() == parser::Severity::ErrorUnlessDeadCode && *co == '\0' &&
      context.IsEnabled(common::LanguageFeature::OutOfBoundsSubscripts)) {
    // A subscript value is required to be within its bounds only when the
    // reference is executed (F'2023 9.5.3.1 p2), so a reference that appears
    // in code that never runs does not render the program nonconforming.
    // That case can't be recognized in general -- consider a procedure whose
    // only call site is in dead code, or one that is never called at all --
    // so by default these references are accepted with a warning, and
    // -fno-out-of-bounds-subscripts restores a hard error.  The endpoints of
    // array sections are validated here too and get the same treatment.
    //
    // Cosubscripts (a nonempty 'co') are deliberately excluded: their
    // requirement is F'2023 9.6 p2 rather than 9.5.3.1 p2, and a cosubscript
    // list determines an image index, so an out-of-cobounds constant
    // cosubscript remains a hard error.
    msg->set_severity(parser::Severity::Warning);
    AttachDeclaration(
        context.Warn(messages, common::LanguageFeature::OutOfBoundsSubscripts,
            std::move(*msg), co, static_cast<std::intmax_t>(val), co,
            static_cast<std::intmax_t>(bound.value()), co, dim + 1),
        symbol);
  } else {
    AttachDeclaration(
        messages.Say(std::move(*msg), co, static_cast<std::intmax_t>(val), co,
            static_cast<std::intmax_t>(bound.value()), co, dim + 1),
        symbol);
  }
}

static void ValidateSubscripts(semantics::SemanticsContext &context,
    const Symbol &arraySymbol, const std::vector<Subscript> &subscripts,
    const Shape &lb, const Shape &ub) {
  int dim{0};
  for (const Subscript &ss : subscripts) {
    auto dimLB{ToInt64(lb[dim])};
    auto dimUB{ToInt64(ub[dim])};
    if (dimUB && dimLB && *dimUB < *dimLB) {
      AttachDeclaration(
          context.Warn(common::UsageWarning::SubscriptedEmptyArray,
              context.foldingContext().messages().at(),
              "Empty array dimension %d should not be subscripted as an element or non-empty array section"_err_en_US,
              dim + 1),
          arraySymbol);
      break;
    }
    std::optional<ConstantSubscript> val[2];
    int vals{0};
    if (auto *triplet{std::get_if<Triplet>(&ss.u)}) {
      auto stride{ToInt64(triplet->stride())};
      std::optional<ConstantSubscript> lower, upper;
      if (const auto *lowerExpr{triplet->GetLower()}) {
        lower = ToInt64(*lowerExpr);
      } else if (lb[dim]) {
        lower = ToInt64(*lb[dim]);
      }
      if (const auto *upperExpr{triplet->GetUpper()}) {
        upper = ToInt64(*upperExpr);
      } else if (ub[dim]) {
        upper = ToInt64(*ub[dim]);
      }
      if (lower) {
        val[vals++] = *lower;
        if (upper && *upper != lower && (stride && *stride != 0)) {
          // Normalize upper bound for non-unit stride
          // 1:10:2 -> 1:9:2, 10:1:-2 -> 10:2:-2
          val[vals++] = *lower + *stride * ((*upper - *lower) / *stride);
        }
      }
    } else {
      val[vals++] =
          ToInt64(std::get<IndirectSubscriptIntegerExpr>(ss.u).value());
    }
    for (int j{0}; j < vals; ++j) {
      if (val[j]) {
        ValidateSubscriptValue(
            context, arraySymbol, *val[j], dimLB, dimUB, dim);
      }
    }
    ++dim;
  }
}

static void CheckSubscripts(
    semantics::SemanticsContext &context, ArrayRef &ref) {
  const Symbol &arraySymbol{ref.base().GetLastSymbol()};
  Shape lb, ub;
  if (FoldSubscripts(context, arraySymbol, ref.subscript(), lb, ub)) {
    ValidateSubscripts(context, arraySymbol, ref.subscript(), lb, ub);
  }
}

static void CheckCosubscripts(
    semantics::SemanticsContext &context, CoarrayRef &ref) {
  const Symbol &coarraySymbol{ref.GetLastSymbol()};
  FoldingContext &foldingContext{context.foldingContext()};
  int dim{0};
  for (auto &expr : ref.cosubscript()) {
    expr = Fold(foldingContext, std::move(expr));
    if (auto val{ToInt64(expr)}) {
      ValidateSubscriptValue(context, coarraySymbol, *val,
          ToInt64(GetLCOBOUND(coarraySymbol, dim)),
          ToInt64(GetUCOBOUND(coarraySymbol, dim)), dim, "co");
    }
    ++dim;
  }
}

// Some subscript semantic checks must be deferred until all of the
// subscripts are in hand.
MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) {
  const Symbol &symbol{ref.GetLastSymbol().GetUltimate()};
  int symbolRank{symbol.Rank()};
  int subscripts{static_cast<int>(ref.size())};
  if (subscripts == 0) {
    return std::nullopt; // error recovery
  } else if (subscripts != symbolRank) {
    if (symbolRank != 0) {
      Say("Reference to rank-%d object '%s' has %d subscripts"_err_en_US,
          symbolRank, symbol.name(), subscripts);
    }
    return std::nullopt;
  } else if (symbol.has<semantics::ObjectEntityDetails>() ||
      symbol.has<semantics::AssocEntityDetails>()) {
    // C928 & C1002
    if (Triplet * last{std::get_if<Triplet>(&ref.subscript().back().u)}) {
      if (!last->upper() && IsAssumedSizeArray(symbol)) {
        Say("Assumed-size array '%s' must have explicit final subscript upper bound value"_err_en_US,
            symbol.name());
        return std::nullopt;
      }
    }
  } else {
    // Shouldn't get here from Analyze(ArrayElement) without a valid base,
    // which, if not an object, must be a construct entity from
    // SELECT TYPE/RANK or ASSOCIATE.
    CHECK(symbol.has<semantics::AssocEntityDetails>());
  }
  if (!semantics::IsNamedConstant(symbol) && !inDataStmtObject_) {
    // Subscripts of named constants are checked in folding.
    // Subscripts of DATA statement objects are checked in data statement
    // conversion to initializers.
    CheckSubscripts(context_, ref);
  }
  return Designate(DataRef{std::move(ref)});
}

// Applies subscripts to a data reference.
MaybeExpr ExpressionAnalyzer::ApplySubscripts(
    DataRef &&dataRef, std::vector<Subscript> &&subscripts) {
  if (subscripts.empty()) {
    return std::nullopt; // error recovery
  }
  return common::visit(common::visitors{
                           [&](SymbolRef &&symbol) {
                             return CompleteSubscripts(
                                 ArrayRef{symbol, std::move(subscripts)});
                           },
                           [&](Component &&c) {
                             return CompleteSubscripts(
                                 ArrayRef{std::move(c), std::move(subscripts)});
                           },
                           [&](auto &&) -> MaybeExpr {
                             DIE("bad base for ArrayRef");
                             return std::nullopt;
                           },
                       },
      std::move(dataRef.u));
}

// C919a - only one part-ref of a data-ref may have rank > 0
bool ExpressionAnalyzer::CheckRanks(const DataRef &dataRef) {
  return common::visit(
      common::visitors{
          [this](const Component &component) {
            const Symbol &symbol{component.GetLastSymbol()};
            if (int componentRank{symbol.Rank()}; componentRank > 0) {
              if (int baseRank{component.base().Rank()}; baseRank > 0) {
                Say("Reference to whole rank-%d component '%s' of rank-%d array of derived type is not allowed"_err_en_US,
                    componentRank, symbol.name(), baseRank);
                return false;
              }
            } else {
              return CheckRanks(component.base());
            }
            return true;
          },
          [this](const ArrayRef &arrayRef) {
            if (const auto *component{arrayRef.base().UnwrapComponent()}) {
              int subscriptRank{0};
              for (const Subscript &subscript : arrayRef.subscript()) {
                subscriptRank += subscript.Rank();
              }
              if (subscriptRank > 0) {
                if (int componentBaseRank{component->base().Rank()};
                    componentBaseRank > 0) {
                  Say("Subscripts of component '%s' of rank-%d derived type array have rank %d but must all be scalar"_err_en_US,
                      component->GetLastSymbol().name(), componentBaseRank,
                      subscriptRank);
                  return false;
                }
              } else {
                return CheckRanks(component->base());
              }
            }
            return true;
          },
          [](const SymbolRef &) { return true; },
          [](const CoarrayRef &) { return true; },
      },
      dataRef.u);
}

// C911 - if the last name in a data-ref has an abstract derived type,
// it must also be polymorphic.
bool ExpressionAnalyzer::CheckPolymorphic(const DataRef &dataRef) {
  if (auto type{DynamicType::From(dataRef.GetLastSymbol())}) {
    if (type->category() == TypeCategory::Derived && !type->IsPolymorphic()) {
      const Symbol &typeSymbol{
          type->GetDerivedTypeSpec().typeSymbol().GetUltimate()};
      if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) {
        AttachDeclaration(
            Say("Reference to object with abstract derived type '%s' must be polymorphic"_err_en_US,
                typeSymbol.name()),
            typeSymbol);
        return false;
      }
    }
  }
  return true;
}

bool ExpressionAnalyzer::CheckDataRef(const DataRef &dataRef) {
  // Always check both, don't short-circuit
  bool ranksOk{CheckRanks(dataRef)};
  bool polyOk{CheckPolymorphic(dataRef)};
  return ranksOk && polyOk;
}

// Parse tree correction after a substring S(j:k) was misparsed as an
// array section.  Fortran substrings must have a range, not a
// single index.
static std::optional<parser::Substring> FixMisparsedSubstringDataRef(
    parser::DataRef &dataRef) {
  if (auto *ae{
          std::get_if<common::Indirection<parser::ArrayElement>>(&dataRef.u)}) {
    // ...%a(j:k) and "a" is a character scalar
    parser::ArrayElement &arrElement{ae->value()};
    if (arrElement.Subscripts().size() == 1) {
      if (auto *triplet{std::get_if<parser::SubscriptTriplet>(
              &arrElement.Subscripts().front().u)}) {
        if (!std::get<2 /*stride*/>(triplet->t).has_value()) {
          if (const Symbol *symbol{
                  parser::GetLastName(arrElement.Base()).symbol}) {
            const Symbol &ultimate{symbol->GetUltimate()};
            if (const semantics::DeclTypeSpec *type{ultimate.GetType()}) {
              if (ultimate.Rank() == 0 &&
                  type->category() == semantics::DeclTypeSpec::Character) {
                // The ambiguous S(j:k) was parsed as an array section
                // reference, but it's now clear that it's a substring.
                // Fix the parse tree in situ.
                return arrElement.ConvertToSubstring();
              }
            }
          }
        }
      }
    }
  }
  return std::nullopt;
}

// When a designator is a misparsed type-param-inquiry of a misparsed
// substring -- it looks like a structure component reference of an array
// slice -- fix the substring and then convert to an intrinsic function
// call to KIND() or LEN().  And when the designator is a misparsed
// substring, convert it into a substring reference in place.
MaybeExpr ExpressionAnalyzer::FixMisparsedSubstring(
    const parser::Designator &d) {
  auto &mutate{const_cast<parser::Designator &>(d)};
  if (auto *dataRef{std::get_if<parser::DataRef>(&mutate.u)}) {
    if (auto *sc{std::get_if<common::Indirection<parser::StructureComponent>>(
            &dataRef->u)}) {
      parser::StructureComponent &structComponent{sc->value()};
      parser::CharBlock which{structComponent.Component().source};
      if (which == "kind" || which == "len") {
        if (auto substring{FixMisparsedSubstringDataRef(
                std::get<parser::DataRef>(structComponent.t))}) {
          // ...%a(j:k)%kind or %len and "a" is a character scalar
          mutate.u = std::move(*substring);
          if (MaybeExpr substringExpr{Analyze(d)}) {
            return MakeFunctionRef(which,
                ActualArguments{ActualArgument{std::move(*substringExpr)}});
          }
        }
      }
    } else if (auto substring{FixMisparsedSubstringDataRef(*dataRef)}) {
      mutate.u = std::move(*substring);
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Designator &d) {
  auto restorer{GetContextualMessages().SetLocation(d.source)};
  if (auto substringInquiry{FixMisparsedSubstring(d)}) {
    return substringInquiry;
  }
  // These checks have to be deferred to these "top level" data-refs where
  // we can be sure that there are no following subscripts (yet).
  MaybeExpr result{Analyze(d.u)};
  if (result) {
    std::optional<DataRef> dataRef{ExtractDataRef(std::move(result))};
    if (!dataRef) {
      dataRef = ExtractDataRef(std::move(result), /*intoSubstring=*/true);
    }
    if (!dataRef) {
      dataRef = ExtractDataRef(std::move(result),
          /*intoSubstring=*/false, /*intoComplexPart=*/true);
    }
    if (dataRef) {
      if (!CheckDataRef(*dataRef)) {
        result.reset();
      } else if (ExtractCoarrayRef(*dataRef).has_value()) {
        if (auto dyType{result->GetType()};
            dyType && dyType->category() == TypeCategory::Derived) {
          if (!std::holds_alternative<CoarrayRef>(dataRef->u) &&
              dyType->IsPolymorphic()) { // F'2023 C918
            Say("The base of a polymorphic object may not be coindexed"_err_en_US);
          }
          if (const auto *derived{GetDerivedTypeSpec(*dyType)}) {
            if (auto bad{FindPolymorphicAllocatablePotentialComponent(
                    *derived)}) { // F'2023 C917
              Say("A coindexed designator may not have a type with the polymorphic potential subobject component '%s'"_err_en_US,
                  bad.BuildResultDesignatorName());
            }
          }
        }
      }
    }
  }
  return result;
}

// A utility subroutine to repackage optional expressions of various levels
// of type specificity as fully general MaybeExpr values.
template <typename A> common::IfNoLvalue<MaybeExpr, A> AsMaybeExpr(A &&x) {
  return AsGenericExpr(std::move(x));
}
template <typename A> MaybeExpr AsMaybeExpr(std::optional<A> &&x) {
  if (x) {
    return AsMaybeExpr(std::move(*x));
  }
  return std::nullopt;
}

// Type kind parameter values for literal constants.
int ExpressionAnalyzer::AnalyzeKindParam(
    const std::optional<parser::KindParam> &kindParam, int defaultKind) {
  if (!kindParam) {
    return defaultKind;
  }
  std::int64_t kind{common::visit(
      common::visitors{
          [](std::uint64_t k) { return static_cast<std::int64_t>(k); },
          [&](const parser::Scalar<
              parser::Integer<parser::Constant<parser::Name>>> &n) {
            if (MaybeExpr ie{Analyze(n)}) {
              return ToInt64(*ie).value_or(defaultKind);
            }
            return static_cast<std::int64_t>(defaultKind);
          },
      },
      kindParam->u)};
  if (kind != static_cast<int>(kind)) {
    Say("Unsupported type kind value (%jd)"_err_en_US,
        static_cast<std::intmax_t>(kind));
    kind = defaultKind;
  }
  return static_cast<int>(kind);
}

// Common handling of parser::IntLiteralConstant, SignedIntLiteralConstant,
// and UnsignedLiteralConstant
template <typename TYPES, TypeCategory CAT> struct IntTypeVisitor {
  using Result = MaybeExpr;
  using Types = TYPES;
  template <typename T> Result Test() {
    if (T::kind >= kind) {
      const char *p{digits.begin()};
      using Int = typename T::Scalar;
      typename Int::ValueWithOverflow num{0, false};
      const char *typeName{
          CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
      if (isNegated) {
        auto unsignedNum{Int::Read(p, 10, false /*unsigned*/)};
        num.value = unsignedNum.value.Negate().value;
        num.overflow = unsignedNum.overflow ||
            (CAT == TypeCategory::Integer && num.value > Int{0});
        if (!num.overflow && num.value.Negate().overflow) {
          analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
              "negated maximum INTEGER(KIND=%d) literal"_port_en_US, T::kind);
        }
      } else {
        num = Int::Read(p, 10, /*isSigned=*/CAT == TypeCategory::Integer);
      }
      if (num.overflow) {
        if constexpr (CAT == TypeCategory::Unsigned) {
          analyzer.Warn(common::UsageWarning::UnsignedLiteralTruncation,
              "Unsigned literal too large for UNSIGNED(KIND=%d); truncated"_warn_en_US,
              kind);
          return Expr<SomeType>{
              Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};
        }
      } else {
        if (T::kind > kind) {
          if (!isDefaultKind ||
              !analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {
            return std::nullopt;
          } else {
            analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
                "Integer literal is too large for default %s(KIND=%d); "
                "assuming %s(KIND=%d)"_port_en_US,
                typeName, kind, typeName, T::kind);
          }
        }
        return Expr<SomeType>{
            Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};
      }
    }
    return std::nullopt;
  }
  ExpressionAnalyzer &analyzer;
  parser::CharBlock digits;
  std::int64_t kind;
  bool isDefaultKind;
  bool isNegated;
};

template <typename TYPES, TypeCategory CAT, typename PARSED>
MaybeExpr ExpressionAnalyzer::IntLiteralConstant(
    const PARSED &x, bool isNegated) {
  const auto &kindParam{std::get<std::optional<parser::KindParam>>(x.t)};
  bool isDefaultKind{!kindParam};
  int kind{AnalyzeKindParam(kindParam, GetDefaultKind(CAT))};
  const char *typeName{CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
  if (CheckIntrinsicKind(CAT, kind)) {
    auto digits{std::get<parser::CharBlock>(x.t)};
    if (MaybeExpr result{common::SearchTypes(IntTypeVisitor<TYPES, CAT>{
            *this, digits, kind, isDefaultKind, isNegated})}) {
      return result;
    } else if (isDefaultKind) {
      Say(digits,
          "Integer literal is too large for any allowable kind of %s"_err_en_US,
          typeName);
    } else {
      Say(digits, "Integer literal is too large for %s(KIND=%d)"_err_en_US,
          typeName, kind);
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::IntLiteralConstant &x, bool isNegated) {
  auto restorer{
      GetContextualMessages().SetLocation(std::get<parser::CharBlock>(x.t))};
  return IntLiteralConstant<IntegerTypes, TypeCategory::Integer>(x, isNegated);
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::SignedIntLiteralConstant &x) {
  auto restorer{GetContextualMessages().SetLocation(x.source)};
  return IntLiteralConstant<IntegerTypes, TypeCategory::Integer>(x);
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::UnsignedLiteralConstant &x) {
  parser::CharBlock at{std::get<parser::CharBlock>(x.t)};
  auto restorer{GetContextualMessages().SetLocation(at)};
  if (!context().IsEnabled(common::LanguageFeature::Unsigned) &&
      !context().AnyFatalError()) {
    context().Say(
        at, "-funsigned is required to enable UNSIGNED constants"_err_en_US);
  }
  return IntLiteralConstant<UnsignedTypes, TypeCategory::Unsigned>(x);
}

template <typename TYPE>
Constant<TYPE> ReadRealLiteral(
    parser::CharBlock source, FoldingContext &context, bool isDefaultKind) {
  const char *p{source.begin()};
  auto valWithFlags{
      Scalar<TYPE>::Read(p, context.targetCharacteristics().roundingMode())};
  CHECK(p == source.end());
  context.RealFlagWarnings(valWithFlags.flags, "conversion of REAL literal");
  auto value{valWithFlags.value};
  if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
    value = value.FlushSubnormalToZero();
  }
  typename Constant<TYPE>::Result resultInfo;
  resultInfo.set_isFromInexactLiteralConversion(
      isDefaultKind && valWithFlags.flags.test(RealFlag::Inexact));
  return {value, resultInfo};
}

struct RealTypeVisitor {
  using Result = std::optional<Expr<SomeReal>>;
  using Types = RealTypes;

  RealTypeVisitor(
      int k, parser::CharBlock lit, FoldingContext &ctx, bool isDeftKind)
      : kind{k}, literal{lit}, context{ctx}, isDefaultKind{isDeftKind} {}

  template <typename T> Result Test() {
    if (kind == T::kind) {
      return {
          AsCategoryExpr(ReadRealLiteral<T>(literal, context, isDefaultKind))};
    }
    return std::nullopt;
  }

  int kind;
  parser::CharBlock literal;
  FoldingContext &context;
  bool isDefaultKind;
};

// Reads a real literal constant and encodes it with the right kind.
MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
  const auto &[xreal, xkind](x.t);
  // Use a local message context around the real literal for better
  // provenance on any messages.
  auto restorer{GetContextualMessages().SetLocation(xreal.source)};
  // If a kind parameter appears, it defines the kind of the literal and the
  // letter used in an exponent part must be 'E' (e.g., the 'E' in
  // "6.02214E+23").  In the absence of an explicit kind parameter, any
  // exponent letter determines the kind.  Otherwise, defaults apply.
  auto &defaults{context_.defaultKinds()};
  int defaultKind{defaults.GetDefaultKind(TypeCategory::Real)};
  const char *end{xreal.source.end()};
  char expoLetter{' '};
  std::optional<int> letterKind;
  for (const char *p{xreal.source.begin()}; p < end; ++p) {
    if (parser::IsLetter(*p)) {
      expoLetter = *p;
      switch (expoLetter) {
      case 'e':
        letterKind = defaults.GetDefaultKind(TypeCategory::Real);
        break;
      case 'd':
        letterKind = defaults.doublePrecisionKind();
        break;
      case 'q':
        letterKind = defaults.quadPrecisionKind();
        break;
      default:
        Say("Unknown exponent letter '%c'"_err_en_US, expoLetter);
      }
      break;
    }
  }
  if (letterKind) {
    defaultKind = *letterKind;
  }
  // C716 requires 'E' as an exponent.
  // Extension: allow exponent-letter matching the kind-param.
  auto kind{AnalyzeKindParam(xkind, defaultKind)};
  if (letterKind && expoLetter != 'e') {
    if (kind != *letterKind) {
      Warn(common::LanguageFeature::ExponentMatchingKindParam,
          "Explicit kind parameter on real constant disagrees with exponent letter '%c'"_warn_en_US,
          expoLetter);
    } else if (xkind) {
      Warn(common::LanguageFeature::ExponentMatchingKindParam,
          "Explicit kind parameter together with non-'E' exponent letter is not standard"_port_en_US);
    }
  }
  bool isDefaultKind{!xkind && letterKind.value_or('e') == 'e'};
  auto result{common::SearchTypes(
      RealTypeVisitor{kind, xreal.source, GetFoldingContext(), isDefaultKind})};
  if (!result) { // C717
    Say("Unsupported REAL(KIND=%d)"_err_en_US, kind);
  }
  return AsMaybeExpr(std::move(result));
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::SignedRealLiteralConstant &x) {
  if (auto result{Analyze(std::get<parser::RealLiteralConstant>(x.t))}) {
    auto &realExpr{std::get<Expr<SomeReal>>(result->u)};
    if (auto sign{std::get<std::optional<parser::Sign>>(x.t)}) {
      if (sign == parser::Sign::Negative) {
        return AsGenericExpr(-std::move(realExpr));
      }
    }
    return result;
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::SignedComplexLiteralConstant &x) {
  auto result{Analyze(std::get<parser::ComplexLiteralConstant>(x.t))};
  if (!result) {
    return std::nullopt;
  } else if (std::get<parser::Sign>(x.t) == parser::Sign::Negative) {
    return AsGenericExpr(-std::move(std::get<Expr<SomeComplex>>(result->u)));
  } else {
    return result;
  }
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexPart &x) {
  return Analyze(x.u);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexLiteralConstant &z) {
  return AnalyzeComplex(Analyze(std::get<0>(z.t)), Analyze(std::get<1>(z.t)),
      "complex literal constant");
}

// CHARACTER literal processing.
MaybeExpr ExpressionAnalyzer::AnalyzeString(std::string &&string, int kind) {
  if (!CheckIntrinsicKind(TypeCategory::Character, kind)) {
    return std::nullopt;
  }
  switch (kind) {
  case 1:
    return AsGenericExpr(Constant<Type<TypeCategory::Character, 1>>{
        parser::DecodeString<std::string, parser::Encoding::LATIN_1>(
            string, true)});
  case 2:
    return AsGenericExpr(Constant<Type<TypeCategory::Character, 2>>{
        parser::DecodeString<std::u16string, parser::Encoding::UTF_8>(
            string, true)});
  case 4:
    return AsGenericExpr(Constant<Type<TypeCategory::Character, 4>>{
        parser::DecodeString<std::u32string, parser::Encoding::UTF_8>(
            string, true)});
  default:
    CRASH_NO_CASE;
  }
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::CharLiteralConstant &x) {
  int kind{
      AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t), 1)};
  auto value{std::get<std::string>(x.t)};
  return AnalyzeString(std::move(value), kind);
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::HollerithLiteralConstant &x) {
  int kind{GetDefaultKind(TypeCategory::Character)};
  auto result{AnalyzeString(std::string{x.v}, kind)};
  if (auto *constant{UnwrapConstantValue<Ascii>(result)}) {
    constant->set_wasHollerith(true);
  }
  return result;
}

// .TRUE. and .FALSE. of various kinds
MaybeExpr ExpressionAnalyzer::Analyze(const parser::LogicalLiteralConstant &x) {
  auto kind{AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t),
      GetDefaultKind(TypeCategory::Logical))};
  bool value{std::get<bool>(x.t)};
  auto result{common::SearchTypes(
      TypeKindVisitor<TypeCategory::Logical, Constant, bool>{
          kind, std::move(value)})};
  if (!result) {
    Say("unsupported LOGICAL(KIND=%d)"_err_en_US, kind); // C728
  }
  return result;
}

// BOZ typeless literals
MaybeExpr ExpressionAnalyzer::Analyze(const parser::BOZLiteralConstant &x) {
  const char *p{x.v.c_str()};
  std::uint64_t base{16};
  switch (*p++) {
  case 'b':
    base = 2;
    break;
  case 'o':
    base = 8;
    break;
  case 'z':
    break;
  case 'x':
    break;
  default:
    CRASH_NO_CASE;
  }
  CHECK(*p == '"');
  ++p;
  auto value{BOZLiteralConstant::Read(p, base, false /*unsigned*/)};
  if (*p != '"') {
    Say("Invalid digit ('%c') in BOZ literal '%s'"_err_en_US, *p,
        x.v); // C7107, C7108
    return std::nullopt;
  }
  if (value.overflow) {
    Say("BOZ literal '%s' too large"_err_en_US, x.v);
    return std::nullopt;
  }
  return AsGenericExpr(std::move(value.value));
}

// Names and named constants
static void WarnForNumericStorageSize(
    semantics::SemanticsContext &context, const parser::Name &name) {
  const semantics::Symbol *associated{name.symbol};
  const semantics::UseDetails *use{nullptr};
  bool isNumericStorageSize{false};
  while (associated) {
    if (const auto *host{
            associated->detailsIf<semantics::HostAssocDetails>()}) {
      associated = &host->symbol();
    } else if (const auto *nextUse{
                   associated->detailsIf<semantics::UseDetails>()}) {
      if (!use) {
        use = nextUse;
      }
      const semantics::Symbol &used{nextUse->symbol()};
      const semantics::Symbol &module{semantics::GetUsedModule(*nextUse)};
      isNumericStorageSize |= used.name() == "numeric_storage_size" &&
          module.name() == "iso_fortran_env" &&
          module.attrs().test(semantics::Attr::INTRINSIC);
      associated = &used;
    } else {
      break;
    }
  }
  if (!isNumericStorageSize) {
    return;
  }
  const auto &defaults{context.defaultKinds()};
  const auto &targetCharacteristics{context.targetCharacteristics()};
  const int intKind{defaults.GetDefaultKind(TypeCategory::Integer)};
  const int realKind{defaults.GetDefaultKind(TypeCategory::Real)};
  const std::size_t intBytes{
      targetCharacteristics.GetByteSize(TypeCategory::Integer, intKind)};
  const std::size_t realBytes{
      targetCharacteristics.GetByteSize(TypeCategory::Real, realKind)};
  if (intBytes != realBytes) {
    if (auto *message{context.messages().Warn(
            /*isInModuleFile=*/false, context.languageFeatures(),
            common::UsageWarning::FoldingValueChecks, name.source,
            "NUMERIC_STORAGE_SIZE from ISO_FORTRAN_ENV is not well-defined because compiler options make default INTEGER(KIND=%d) and REAL(KIND=%d) have different storage sizes (%zu and %zu bytes, respectively)"_warn_en_US,
            intKind, realKind, intBytes, realBytes)}) {
      if (use) {
        message->Attach(use->location(), "USE-associated here"_en_US);
      }
    }
  }
}

class NumericStorageSizeWarningVisitor {
public:
  explicit NumericStorageSizeWarningVisitor(
      semantics::SemanticsContext &context)
      : context_{context} {}
  template <typename A> bool Pre(const A &) { return true; }
  bool Pre(const parser::Name &name) {
    if (!context_.HasError(name.symbol)) {
      WarnForNumericStorageSize(context_, name);
    }
    return false;
  }
  template <typename A> void Post(const A &) {}

private:
  semantics::SemanticsContext &context_;
};

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
  auto restorer{GetContextualMessages().SetLocation(n.source)};
  if (std::optional<int> kind{IsImpliedDo(n.source)}) {
    return AsMaybeExpr(ConvertToKind<TypeCategory::Integer>(
        *kind, AsExpr(ImpliedDoIndex{n.source})));
  }
  if (context_.HasError(n.symbol)) { // includes case of no symbol
    return std::nullopt;
  } else {
    // Most expression references are diagnosed here. Analyze(Expr) below
    // performs the same check explicitly when returning a saved typed
    // expression, since that path does not call Analyze(Name).
    WarnForNumericStorageSize(context_, n);
    const Symbol &ultimate{n.symbol->GetUltimate()};
    if (ultimate.has<semantics::TypeParamDetails>()) {
      // A bare reference to a derived type parameter within a parameterized
      // derived type definition.
      auto dyType{DynamicType::From(ultimate)};
      if (!dyType) {
        // When the integer kind of this type parameter is not known now,
        // it's either an error or because it depends on earlier-declared kind
        // type parameters.  So assume that it's a subscript integer for now
        // while processing other specification expressions in the PDT
        // definition; the right kind value will be used later in each of its
        // instantiations.
        int kind{SubscriptInteger::kind};
        if (const auto *typeSpec{ultimate.GetType()}) {
          if (const semantics::IntrinsicTypeSpec *
              intrinType{typeSpec->AsIntrinsic()}) {
            if (auto k{ToInt64(Fold(semantics::KindExpr{intrinType->kind()}))};
                k &&
                common::IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {
              kind = *k;
            }
          }
        }
        dyType = DynamicType{TypeCategory::Integer, kind};
      }
      return Fold(ConvertToType(
          *dyType, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));
    } else {
      if (n.symbol->attrs().test(semantics::Attr::VOLATILE)) {
        if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(
                context_.FindScope(n.source))}) {
          SayAt(n,
              "VOLATILE variable '%s' may not be referenced in pure subprogram '%s'"_err_en_US,
              n.source, DEREF(pure->symbol()).name());
          n.symbol->attrs().reset(semantics::Attr::VOLATILE);
        }
      }
      CheckForWholeAssumedSizeArray(n.source, n.symbol);
      return Designate(DataRef{*n.symbol});
    }
  }
}

void ExpressionAnalyzer::CheckForWholeAssumedSizeArray(
    parser::CharBlock at, const Symbol *symbol) {
  if (!isWholeAssumedSizeArrayOk_ && symbol &&
      semantics::IsAssumedSizeArray(ResolveAssociations(*symbol))) {
    AttachDeclaration(
        SayAt(at,
            "Whole assumed-size array '%s' may not appear here without subscripts"_err_en_US,
            symbol->name()),
        *symbol);
  }
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::NamedConstant &n) {
  auto restorer{GetContextualMessages().SetLocation(n.v.source)};
  if (MaybeExpr value{Analyze(n.v)}) {
    Expr<SomeType> folded{Fold(std::move(*value))};
    if (IsConstantExpr(folded)) {
      return folded;
    }
    Say(n.v.source, "must be a constant"_err_en_US); // C718
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &n) {
  auto restorer{AllowNullPointer()};
  if (MaybeExpr value{Analyze(n.v.value())}) {
    // Subtle: when the NullInit is a DataStmtConstant, it might
    // be a misparse of a structure constructor without parameters
    // or components (e.g., T()).  Checking the result to ensure
    // that a "=>" data entity initializer actually resolved to
    // a null pointer has to be done by the caller.
    return Fold(std::move(*value));
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::StmtFunctionStmt &stmtFunc) {
  inStmtFunctionDefinition_ = true;
  return Analyze(std::get<parser::Scalar<parser::Expr>>(stmtFunc.t));
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) {
  return Analyze(x.value());
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) {
  if (const auto &repeat{
          std::get<std::optional<parser::DataStmtRepeat>>(x.t)}) {
    x.repetitions = -1;
    if (MaybeExpr expr{Analyze(repeat->u)}) {
      Expr<SomeType> folded{Fold(std::move(*expr))};
      if (auto value{ToInt64(folded)}) {
        if (*value >= 0) { // C882
          x.repetitions = *value;
        } else {
          Say(FindSourceLocation(repeat),
              "Repeat count (%jd) for data value must not be negative"_err_en_US,
              *value);
        }
      }
    }
  }
  return Analyze(std::get<parser::DataStmtConstant>(x.t));
}

// Substring references
std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::GetSubstringBound(
    const std::optional<parser::ScalarIntExpr> &bound) {
  if (bound) {
    if (MaybeExpr expr{Analyze(*bound)}) {
      if (expr->Rank() > 1) {
        Say("substring bound expression has rank %d"_err_en_US, expr->Rank());
      }
      if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
        if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {
          return {std::move(*ssIntExpr)};
        }
        return {Expr<SubscriptInteger>{
            Convert<SubscriptInteger, TypeCategory::Integer>{
                std::move(*intExpr)}}};
      } else {
        Say("substring bound expression is not INTEGER"_err_en_US);
      }
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Substring &ss) {
  if (MaybeExpr baseExpr{Analyze(std::get<parser::DataRef>(ss.t))}) {
    if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(*baseExpr))}) {
      if (MaybeExpr newBaseExpr{Designate(std::move(*dataRef))}) {
        if (std::optional<DataRef> checked{
                ExtractDataRef(std::move(*newBaseExpr))}) {
          const parser::SubstringRange &range{
              std::get<parser::SubstringRange>(ss.t)};
          std::optional<Expr<SubscriptInteger>> first{
              Fold(GetSubstringBound(std::get<0>(range.t)))};
          std::optional<Expr<SubscriptInteger>> last{
              Fold(GetSubstringBound(std::get<1>(range.t)))};
          const Symbol &symbol{checked->GetLastSymbol()};
          if (std::optional<DynamicType> dynamicType{
                  DynamicType::From(symbol)}) {
            if (dynamicType->category() == TypeCategory::Character) {
              auto lbValue{ToInt64(first)};
              if (!lbValue) {
                lbValue = 1;
              }
              auto ubValue{ToInt64(last)};
              auto len{dynamicType->knownLength()};
              if (!ubValue) {
                ubValue = len;
              }
              if ((len && *len == 0) ||
                  (lbValue && ubValue && *lbValue > *ubValue)) {
                // valid, substring is empty
              } else if (lbValue && *lbValue < 1 && (ubValue || !last)) {
                Say("Substring must begin at 1 or later, not %jd"_err_en_US,
                    static_cast<std::intmax_t>(*lbValue));
                return std::nullopt;
              } else if (ubValue && len && *ubValue > *len &&
                  (lbValue || !first)) {
                Say("Substring must end at %jd or earlier, not %jd"_err_en_US,
                    static_cast<std::intmax_t>(*len),
                    static_cast<std::intmax_t>(*ubValue));
                return std::nullopt;
              }
              return WrapperHelper<TypeCategory::Character, Designator,
                  Substring>(dynamicType->kind(),
                  Substring{std::move(checked.value()), std::move(first),
                      std::move(last)});
            }
          }
          Say("substring may apply only to CHARACTER"_err_en_US);
        }
      }
    }
  }
  return std::nullopt;
}

// CHARACTER literal substrings
MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::CharLiteralConstantSubstring &x) {
  const parser::SubstringRange &range{std::get<parser::SubstringRange>(x.t)};
  std::optional<Expr<SubscriptInteger>> lower{
      GetSubstringBound(std::get<0>(range.t))};
  std::optional<Expr<SubscriptInteger>> upper{
      GetSubstringBound(std::get<1>(range.t))};
  if (MaybeExpr string{Analyze(std::get<parser::CharLiteralConstant>(x.t))}) {
    if (auto *charExpr{std::get_if<Expr<SomeCharacter>>(&string->u)}) {
      Expr<SubscriptInteger> length{
          common::visit([](const auto &ckExpr) { return ckExpr.LEN().value(); },
              charExpr->u)};
      if (!lower) {
        lower = Expr<SubscriptInteger>{1};
      }
      if (!upper) {
        upper = Expr<SubscriptInteger>{
            static_cast<std::int64_t>(ToInt64(length).value())};
      }
      return common::visit(
          [&](auto &&ckExpr) -> MaybeExpr {
            using Result = ResultType<decltype(ckExpr)>;
            auto *cp{std::get_if<Constant<Result>>(&ckExpr.u)};
            CHECK(DEREF(cp).size() == 1);
            StaticDataObject::Pointer staticData{StaticDataObject::Create()};
            staticData->set_alignment(Result::kind)
                .set_itemBytes(Result::kind)
                .Push(cp->GetScalarValue().value(),
                    foldingContext_.targetCharacteristics().isBigEndian());
            Substring substring{std::move(staticData), std::move(lower.value()),
                std::move(upper.value())};
            return AsGenericExpr(
                Expr<Result>{Designator<Result>{std::move(substring)}});
          },
          std::move(charExpr->u));
    }
  }
  return std::nullopt;
}

// substring%KIND/LEN
MaybeExpr ExpressionAnalyzer::Analyze(const parser::SubstringInquiry &x) {
  if (MaybeExpr substring{Analyze(x.v)}) {
    CHECK(x.source.size() >= 8);
    int nameLen{x.source.back() == 'n' ? 3 /*LEN*/ : 4 /*KIND*/};
    parser::CharBlock name{
        x.source.end() - nameLen, static_cast<std::size_t>(nameLen)};
    CHECK(name == "len" || name == "kind");
    return MakeFunctionRef(
        name, ActualArguments{ActualArgument{std::move(*substring)}});
  } else {
    return std::nullopt;
  }
}

// Subscripted array references
std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::AsSubscript(
    MaybeExpr &&expr) {
  if (expr) {
    if (expr->Rank() > 1) {
      Say("Subscript expression has rank %d greater than 1"_err_en_US,
          expr->Rank());
    }
    if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
      if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {
        return std::move(*ssIntExpr);
      } else {
        return Expr<SubscriptInteger>{
            Convert<SubscriptInteger, TypeCategory::Integer>{
                std::move(*intExpr)}};
      }
    } else {
      Say("Subscript expression is not INTEGER"_err_en_US);
    }
  }
  return std::nullopt;
}

std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::TripletPart(
    const std::optional<parser::Subscript> &s) {
  if (s) {
    return AsSubscript(Analyze(*s));
  } else {
    return std::nullopt;
  }
}

std::optional<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscript(
    const parser::SectionSubscript &ss) {
  return common::visit(
      common::visitors{
          [&](const parser::SubscriptTriplet &t) -> std::optional<Subscript> {
            const auto &lower{std::get<0>(t.t)};
            const auto &upper{std::get<1>(t.t)};
            const auto &stride{std::get<2>(t.t)};
            auto result{Triplet{
                TripletPart(lower), TripletPart(upper), TripletPart(stride)}};
            if ((lower && !result.lower()) || (upper && !result.upper())) {
              return std::nullopt;
            } else {
              return std::make_optional<Subscript>(result);
            }
          },
          [&](const auto &s) -> std::optional<Subscript> {
            if (auto subscriptExpr{AsSubscript(Analyze(s))}) {
              return Subscript{std::move(*subscriptExpr)};
            } else {
              return std::nullopt;
            }
          },
      },
      ss.u);
}

// Empty result means an error occurred
std::vector<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscripts(
    const std::list<parser::SectionSubscript> &sss) {
  bool error{false};
  std::vector<Subscript> subscripts;
  for (const auto &s : sss) {
    if (auto subscript{AnalyzeSectionSubscript(s)}) {
      subscripts.emplace_back(std::move(*subscript));
    } else {
      error = true;
    }
  }
  return !error ? subscripts : std::vector<Subscript>{};
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayElement &ae) {
  MaybeExpr baseExpr;
  {
    auto restorer{AllowWholeAssumedSizeArray()};
    baseExpr = Analyze(ae.Base());
  }
  if (baseExpr) {
    if (ae.Subscripts().empty()) {
      // will be converted to function call later or error reported
    } else if (baseExpr->Rank() == 0) {
      if (const Symbol *symbol{GetLastSymbol(*baseExpr)}) {
        if (!context_.HasError(symbol)) {
          if (inDataStmtConstant_) {
            // Better error for NULL(X) with a MOLD= argument
            Say("'%s' must be an array or structure constructor if used with non-empty parentheses as a DATA statement constant"_err_en_US,
                symbol->name());
          } else {
            Say("'%s' is not an array"_err_en_US, symbol->name());
          }
          context_.SetError(*symbol);
        }
      }
    } else if (std::optional<DataRef> dataRef{
                   ExtractDataRef(std::move(*baseExpr))}) {
      return ApplySubscripts(
          std::move(*dataRef), AnalyzeSectionSubscripts(ae.Subscripts()));
    } else {
      Say("Subscripts may be applied only to an object, component, or array constant"_err_en_US);
    }
  }
  // error was reported: analyze subscripts without reporting more errors
  auto restorer{GetContextualMessages().DiscardMessages()};
  AnalyzeSectionSubscripts(ae.Subscripts());
  return std::nullopt;
}

// Type parameter inquiries apply to data references, but don't depend
// on any trailing (co)subscripts.
static NamedEntity IgnoreAnySubscripts(Designator<SomeDerived> &&designator) {
  return common::visit(
      common::visitors{
          [](SymbolRef &&symbol) { return NamedEntity{symbol}; },
          [](Component &&component) {
            return NamedEntity{std::move(component)};
          },
          [](ArrayRef &&arrayRef) { return std::move(arrayRef.base()); },
          [](CoarrayRef &&coarrayRef) {
            return NamedEntity{coarrayRef.GetLastSymbol()};
          },
      },
      std::move(designator.u));
}

// Components, but not bindings, of parent derived types are explicitly
// represented as such.
std::optional<Component> ExpressionAnalyzer::CreateComponent(DataRef &&base,
    const Symbol &component, const semantics::Scope &scope,
    bool C919bAlreadyEnforced) {
  if (!C919bAlreadyEnforced && IsAllocatableOrPointer(component) &&
      base.Rank() > 0) { // C919b
    Say("An allocatable or pointer component reference must be applied to a scalar base"_err_en_US);
  }
  if (&component.owner() == &scope ||
      component.has<semantics::ProcBindingDetails>()) {
    return Component{std::move(base), component};
  }
  if (const Symbol *typeSymbol{scope.GetSymbol()}) {
    if (const Symbol *parentComponent{typeSymbol->GetParentComponent(&scope)}) {
      if (const auto *object{
              parentComponent->detailsIf<semantics::ObjectEntityDetails>()}) {
        if (const auto *parentType{object->type()}) {
          if (const semantics::Scope *parentScope{
                  parentType->derivedTypeSpec().scope()}) {
            return CreateComponent(
                DataRef{Component{std::move(base), *parentComponent}},
                component, *parentScope, C919bAlreadyEnforced);
          }
        }
      }
    }
  }
  return std::nullopt;
}

// Derived type component references and type parameter inquiries
MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
  Symbol *sym{sc.Component().symbol};
  if (context_.HasError(sym)) {
    return std::nullopt;
  }
  const auto *misc{sym->detailsIf<semantics::MiscDetails>()};
  bool isTypeParamInquiry{sym->has<semantics::TypeParamDetails>() ||
      (misc &&
          (misc->kind() == semantics::MiscDetails::Kind::KindParamInquiry ||
              misc->kind() == semantics::MiscDetails::Kind::LenParamInquiry))};
  MaybeExpr base;
  if (isTypeParamInquiry) {
    auto restorer{AllowWholeAssumedSizeArray()};
    base = Analyze(sc.Base());
  } else {
    base = Analyze(sc.Base());
  }
  if (!base) {
    return std::nullopt;
  }
  const auto &name{sc.Component().source};
  if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
    const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
    if (dtSpec && dtSpec->IsEnumerationType()) {
      Say(name,
          "Component reference is not allowed for enumeration type '%s'"_err_en_US,
          dtSpec->typeSymbol().name());
      return std::nullopt;
    }
    if (isTypeParamInquiry) {
      if (auto *designator{UnwrapExpr<Designator<SomeDerived>>(*dtExpr)}) {
        if (std::optional<DynamicType> dyType{DynamicType::From(*sym)}) {
          if (dyType->category() == TypeCategory::Integer) {
            auto restorer{GetContextualMessages().SetLocation(name)};
            return Fold(ConvertToType(*dyType,
                AsGenericExpr(TypeParamInquiry{
                    IgnoreAnySubscripts(std::move(*designator)), *sym})));
          }
        }
        Say(name, "Type parameter is not INTEGER"_err_en_US);
      } else {
        Say(name,
            "A type parameter inquiry must be applied to a designator"_err_en_US);
      }
    } else if (!dtSpec || !dtSpec->GetScope()) {
      CHECK(context_.AnyFatalError() || !foldingContext_.messages().empty());
      return std::nullopt;
    } else if (std::optional<DataRef> dataRef{
                   ExtractDataRef(std::move(*dtExpr))}) {
      // The base may use a forked DerivedTypeSpec (e.g. OpenACC use_device with
      // CUDA) while the parse tree still points at host-associated component
      // symbols; resolve the component in the base type's instantiated scope.
      const semantics::Scope &typeScope{DEREF(dtSpec->GetScope())};
      Symbol *compSym{sym};
      if (sym && sym->owner().IsDerivedType() && &sym->owner() != &typeScope) {
        if (Symbol * via{typeScope.FindComponent(sym->name())}) {
          compSym = via;
        }
      }
      auto restorer{GetContextualMessages().SetLocation(name)};
      if (auto component{
              CreateComponent(std::move(*dataRef), *compSym, typeScope)}) {
        return Designate(DataRef{std::move(*component)});
      } else {
        Say(name, "Component is not in scope of derived TYPE(%s)"_err_en_US,
            dtSpec->typeSymbol().name());
      }
    } else {
      Say(name,
          "Base of component reference must be a data reference"_err_en_US);
    }
  } else if (auto *details{sym->detailsIf<semantics::MiscDetails>()}) {
    // special part-ref: %re, %im, %kind, %len
    // Type errors on the base of %re/%im/%len are detected and
    // reported in name resolution.
    using MiscKind = semantics::MiscDetails::Kind;
    MiscKind kind{details->kind()};
    if (kind == MiscKind::ComplexPartRe || kind == MiscKind::ComplexPartIm) {
      if (auto *zExpr{std::get_if<Expr<SomeComplex>>(&base->u)}) {
        if (std::optional<DataRef> dataRef{ExtractDataRef(*zExpr)}) {
          // Represent %RE/%IM as a designator
          Expr<SomeReal> realExpr{common::visit(
              [&](const auto &z) {
                using PartType = typename ResultType<decltype(z)>::Part;
                auto part{kind == MiscKind::ComplexPartRe
                        ? ComplexPart::Part::RE
                        : ComplexPart::Part::IM};
                return AsCategoryExpr(Designator<PartType>{
                    ComplexPart{std::move(*dataRef), part}});
              },
              zExpr->u)};
          return AsGenericExpr(std::move(realExpr));
        }
      }
    } else if (isTypeParamInquiry) { // %kind or %len
      ActualArgument arg{std::move(*base)};
      SetArgSourceLocation(arg, name);
      return MakeFunctionRef(name, ActualArguments{std::move(arg)});
    } else {
      DIE("unexpected MiscDetails::Kind");
    }
  } else {
    Say(name, "derived type required before component reference"_err_en_US);
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {
  const auto &[base, selector]{x.t};
  if (auto dataRef{ExtractDataRef(Analyze(base))}) {
    if (!std::holds_alternative<ArrayRef>(dataRef->u) &&
        dataRef->GetLastSymbol().Rank() > 0) { // F'2023 C916
      Say("Subscripts must appear in a coindexed reference when its base is an array"_err_en_US);
    }
    std::vector<Expr<SubscriptInteger>> cosubscripts;
    bool cosubsOk{true};
    for (const auto &cosub :
        std::get<std::list<parser::Cosubscript>>(selector.t)) {
      MaybeExpr coex{Analyze(cosub)};
      if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(coex)}) {
        cosubscripts.push_back(
            ConvertToType<SubscriptInteger>(std::move(*intExpr)));
      } else {
        cosubsOk = false;
      }
    }
    if (cosubsOk) {
      int numCosubscripts{static_cast<int>(cosubscripts.size())};
      const Symbol &symbol{dataRef->GetLastSymbol()};
      if (numCosubscripts != GetCorank(symbol)) {
        Say("'%s' has corank %d, but coindexed reference has %d cosubscripts"_err_en_US,
            symbol.name(), GetCorank(symbol), numCosubscripts);
      }
    }
    CoarrayRef coarrayRef{std::move(*dataRef), std::move(cosubscripts)};
    for (const auto &imageSelSpec :
        std::get<std::list<parser::ImageSelectorSpec>>(selector.t)) {
      common::visit(
          common::visitors{
              [&](const parser::ImageSelectorSpec::Notify &x) {
                Analyze(x.v);
                if (const auto *expr{GetExpr(context_, x.v)}) {
                  if (coarrayRef.notify()) {
                    Say("coindexed reference has multiple NOTIFY= specifiers"_err_en_US);
                  } else if (auto dyType{expr->GetType()};
                      dyType && IsNotifyType(GetDerivedTypeSpec(*dyType))) {
                    coarrayRef.set_notify(Expr<SomeType>{*expr});
                  } else {
                    Say("NOTIFY= specifier must have type NOTIFY_TYPE from ISO_FORTRAN_ENV"_err_en_US);
                  }
                }
              },
              [&](const parser::ImageSelectorSpec::Stat &x) {
                Analyze(x.v);
                if (const auto *expr{GetExpr(context_, x.v)}) {
                  if (const auto *intExpr{
                          std::get_if<Expr<SomeInteger>>(&expr->u)}) {
                    if (coarrayRef.stat()) {
                      Say("coindexed reference has multiple STAT= specifiers"_err_en_US);
                    } else if (!IsVariable(*intExpr)) {
                      // A parser::Variable may resolve to a nonpointer
                      // function reference.
                      SayAt(x.v,
                          "STAT= specifier must be a scalar integer variable"_err_en_US);
                    } else {
                      coarrayRef.set_stat(Expr<SomeInteger>{*intExpr});
                    }
                  }
                }
              },
              [&](const parser::TeamValue &x) {
                Analyze(x.v);
                if (const auto *expr{GetExpr(context_, x.v)}) {
                  if (coarrayRef.team()) {
                    Say("coindexed reference has multiple TEAM= or TEAM_NUMBER= specifiers"_err_en_US);
                  } else if (auto dyType{expr->GetType()};
                      dyType && IsTeamType(GetDerivedTypeSpec(*dyType))) {
                    coarrayRef.set_team(Expr<SomeType>{*expr});
                  } else {
                    Say("TEAM= specifier must have type TEAM_TYPE from ISO_FORTRAN_ENV"_err_en_US);
                  }
                }
              },
              [&](const parser::ImageSelectorSpec::Team_Number &x) {
                Analyze(x.v);
                if (const auto *expr{GetExpr(context_, x.v)}) {
                  if (coarrayRef.team()) {
                    Say("coindexed reference has multiple TEAM= or TEAM_NUMBER= specifiers"_err_en_US);
                  } else {
                    coarrayRef.set_team(Expr<SomeType>{*expr});
                  }
                }
              }},
          imageSelSpec.u);
    }
    CheckCosubscripts(context_, coarrayRef);
    return Designate(DataRef{std::move(coarrayRef)});
  }
  return std::nullopt;
}

int ExpressionAnalyzer::IntegerTypeSpecKind(
    const parser::IntegerTypeSpec &spec) {
  Expr<SubscriptInteger> value{
      AnalyzeKindSelector(TypeCategory::Integer, spec.v)};
  if (auto kind{ToInt64(value)}) {
    return static_cast<int>(*kind);
  }
  SayAt(spec, "Constant INTEGER kind value required here"_err_en_US);
  return GetDefaultKind(TypeCategory::Integer);
}

// Array constructors

// Inverts a collection of generic ArrayConstructorValues<SomeType> that
// all happen to have the same actual type T into one ArrayConstructor<T>.
template <typename T>
ArrayConstructorValues<T> MakeSpecific(
    ArrayConstructorValues<SomeType> &&from) {
  ArrayConstructorValues<T> to;
  for (ArrayConstructorValue<SomeType> &x : from) {
    common::visit(
        common::visitors{
            [&](common::CopyableIndirection<Expr<SomeType>> &&expr) {
              auto *typed{UnwrapExpr<Expr<T>>(expr.value())};
              to.Push(std::move(DEREF(typed)));
            },
            [&](ImpliedDo<SomeType> &&impliedDo) {
              to.Push(ImpliedDo<T>{impliedDo.name(),
                  std::move(impliedDo.lower()), std::move(impliedDo.upper()),
                  std::move(impliedDo.stride()),
                  MakeSpecific<T>(std::move(impliedDo.values()))});
            },
        },
        std::move(x.u));
  }
  return to;
}

class ArrayConstructorContext {
public:
  ArrayConstructorContext(
      ExpressionAnalyzer &c, std::optional<DynamicTypeWithLength> &&t)
      : exprAnalyzer_{c}, type_{std::move(t)} {}

  void Add(const parser::AcValue &);
  MaybeExpr ToExpr();

  // These interfaces allow *this to be used as a type visitor argument to
  // common::SearchTypes() to convert the array constructor to a typed
  // expression in ToExpr().
  using Result = MaybeExpr;
  using Types = AllTypes;
  template <typename T> Result Test() {
    if (type_ && type_->category() == T::category) {
      if constexpr (T::category == TypeCategory::Derived) {
        if (!type_->IsUnlimitedPolymorphic()) {
          return AsMaybeExpr(ArrayConstructor<T>{type_->GetDerivedTypeSpec(),
              MakeSpecific<T>(std::move(values_))});
        }
      } else if (type_->kind() == T::kind) {
        ArrayConstructor<T> result{MakeSpecific<T>(std::move(values_))};
        if constexpr (T::category == TypeCategory::Character) {
          if (auto len{LengthIfGood()}) {
            // The ac-do-variables may be treated as constant expressions,
            // if some conditions on ac-implied-do-control hold (10.1.12 (12)).
            // At the same time, they may be treated as constant expressions
            // only in the context of the ac-implied-do, but setting
            // the character length here may result in complete elimination
            // of the ac-implied-do. For example:
            //   character(10) :: c
            //   ... len([(c(i:i), integer(8)::i = 1,4)])
            // would be evaulated into:
            //   ... int(max(0_8,i-i+1_8),kind=4)
            // with a dangling reference to the ac-do-variable.
            // Prevent this by checking for the ac-do-variable references
            // in the 'len' expression.
            result.set_LEN(std::move(*len));
          }
        }
        return AsMaybeExpr(std::move(result));
      }
    }
    return std::nullopt;
  }

private:
  using ImpliedDoIntType = ResultType<ImpliedDoIndex>;

  std::optional<Expr<SubscriptInteger>> LengthIfGood() const {
    if (type_) {
      auto len{type_->LEN()};
      if (explicitType_ ||
          (len &&
              IsConstantExpr(
                  *len, &exprAnalyzer_.context().foldingContext()))) {
        return len;
      }
    }
    return std::nullopt;
  }
  bool NeedLength() const {
    return type_ && type_->category() == TypeCategory::Character &&
        !LengthIfGood();
  }
  void Push(MaybeExpr &&);
  void Add(const parser::AcValue::Triplet &);
  void Add(const parser::Expr &);
  void Add(const parser::AcImpliedDo &);
  void UnrollConstantImpliedDo(const parser::AcImpliedDo &,
      parser::CharBlock name, std::int64_t lower, std::int64_t upper,
      std::int64_t stride);

  template <int KIND>
  std::optional<Expr<Type<TypeCategory::Integer, KIND>>> ToSpecificInt(
      MaybeExpr &&y) {
    if (y) {
      Expr<SomeInteger> *intExpr{UnwrapExpr<Expr<SomeInteger>>(*y)};
      return Fold(exprAnalyzer_.GetFoldingContext(),
          ConvertToType<Type<TypeCategory::Integer, KIND>>(
              std::move(DEREF(intExpr))));
    } else {
      return std::nullopt;
    }
  }

  template <int KIND, typename A>
  std::optional<Expr<Type<TypeCategory::Integer, KIND>>> GetSpecificIntExpr(
      const A &x) {
    return ToSpecificInt<KIND>(exprAnalyzer_.Analyze(x));
  }

  // Nested array constructors all reference the same ExpressionAnalyzer,
  // which represents the nest of active implied DO loop indices.
  ExpressionAnalyzer &exprAnalyzer_;
  std::optional<DynamicTypeWithLength> type_;
  bool explicitType_{type_.has_value()};
  std::optional<std::int64_t> constantLength_;
  ArrayConstructorValues<SomeType> values_;
  std::uint64_t messageDisplayedSet_{0};
};

void ArrayConstructorContext::Push(MaybeExpr &&x) {
  if (!x) {
    return;
  }
  if (!type_) {
    if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {
      // Treat an array constructor of BOZ as if default integer.
      exprAnalyzer_.Warn(common::LanguageFeature::BOZAsDefaultInteger,
          "BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);
      x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(
          exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),
          std::move(*boz)));
    }
  }
  std::optional<DynamicType> dyType{x->GetType()};
  if (!dyType) {
    if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {
      if (!type_) {
        // Treat an array constructor of BOZ as if default integer.
        exprAnalyzer_.Warn(common::LanguageFeature::BOZAsDefaultInteger,
            "BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);
        x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(
            exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),
            std::move(*boz)));
        dyType = x.value().GetType();
      } else if (auto cast{ConvertToType(*type_, std::move(*x))}) {
        x = std::move(cast);
        dyType = *type_;
      } else {
        if (!(messageDisplayedSet_ & 0x80)) {
          exprAnalyzer_.Say(
              "BOZ literal is not suitable for use in this array constructor"_err_en_US);
          messageDisplayedSet_ |= 0x80;
        }
        return;
      }
    } else { // procedure name, &c.
      if (!(messageDisplayedSet_ & 0x40)) {
        exprAnalyzer_.Say(
            "Item is not suitable for use in an array constructor"_err_en_US);
        messageDisplayedSet_ |= 0x40;
      }
      return;
    }
  } else if (dyType->IsUnlimitedPolymorphic()) {
    if (!(messageDisplayedSet_ & 8)) {
      exprAnalyzer_.Say(
          "Cannot have an unlimited polymorphic value in an array constructor"_err_en_US); // C7113
      messageDisplayedSet_ |= 8;
    }
    return;
  } else if (dyType->category() == TypeCategory::Derived &&
      dyType->GetDerivedTypeSpec().typeSymbol().attrs().test(
          semantics::Attr::ABSTRACT)) { // F'2023 C7125
    if (!(messageDisplayedSet_ & 0x200)) {
      exprAnalyzer_.Say(
          "An item whose declared type is ABSTRACT may not appear in an array constructor"_err_en_US);
      messageDisplayedSet_ |= 0x200;
    }
  }
  DynamicTypeWithLength xType{dyType.value()};
  if (Expr<SomeCharacter> * charExpr{UnwrapExpr<Expr<SomeCharacter>>(*x)}) {
    CHECK(xType.category() == TypeCategory::Character);
    xType.length =
        common::visit([](const auto &kc) { return kc.LEN(); }, charExpr->u);
  }
  if (!type_) {
    // If there is no explicit type-spec in an array constructor, the type
    // of the array is the declared type of all of the elements, which must
    // be well-defined and all match.
    // TODO: Possible language extension: use the most general type of
    // the values as the type of a numeric constructed array, convert all
    // of the other values to that type.  Alternative: let the first value
    // determine the type, and convert the others to that type.
    CHECK(!explicitType_);
    type_ = std::move(xType);
    constantLength_ = ToInt64(type_->length);
    values_.Push(std::move(*x));
  } else if (!explicitType_) {
    if (type_->IsTkCompatibleWith(xType) && xType.IsTkCompatibleWith(*type_)) {
      values_.Push(std::move(*x));
      auto xLen{xType.LEN()};
      if (auto thisLen{ToInt64(xLen)}) {
        if (constantLength_) {
          if (*thisLen != *constantLength_ && !(messageDisplayedSet_ & 1)) {
            exprAnalyzer_.Warn(
                common::LanguageFeature::DistinctArrayConstructorLengths,
                "Character literal in array constructor without explicit type has different length than earlier elements"_port_en_US);
            messageDisplayedSet_ |= 1;
          }
          if (*thisLen > *constantLength_) {
            // Language extension: use the longest literal to determine the
            // length of the array constructor's character elements, not the
            // first, when there is no explicit type.
            *constantLength_ = *thisLen;
            type_->length = std::move(xLen);
          }
        } else {
          constantLength_ = *thisLen;
          type_->length = std::move(xLen);
        }
      } else if (xLen && NeedLength()) {
        type_->length = std::move(xLen);
      }
    } else {
      if (!(messageDisplayedSet_ & 2)) {
        exprAnalyzer_.Say(
            "Values in array constructor must have the same declared type when no explicit type appears"_err_en_US); // C7110
        messageDisplayedSet_ |= 2;
      }
    }
  } else {
    CheckRealWidening(*x, *type_, exprAnalyzer_.GetFoldingContext());
    if (auto cast{ConvertToType(*type_, std::move(*x))}) {
      values_.Push(std::move(*cast));
    } else if (!(messageDisplayedSet_ & 4)) {
      exprAnalyzer_.Say(
          "Value in array constructor of type '%s' could not be converted to the type of the array '%s'"_err_en_US,
          x->GetType()->AsFortran(), type_->AsFortran()); // C7111, C7112
      messageDisplayedSet_ |= 4;
    }
  }
}

void ArrayConstructorContext::Add(const parser::AcValue &x) {
  common::visit(
      common::visitors{
          [&](const parser::AcValue::Triplet &triplet) { Add(triplet); },
          [&](const common::Indirection<parser::Expr> &expr) {
            Add(expr.value());
          },
          [&](const common::Indirection<parser::AcImpliedDo> &impliedDo) {
            Add(impliedDo.value());
          },
      },
      x.u);
}

// Transforms l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_'
void ArrayConstructorContext::Add(const parser::AcValue::Triplet &triplet) {
  MaybeExpr lowerExpr{exprAnalyzer_.Analyze(std::get<0>(triplet.t))};
  MaybeExpr upperExpr{exprAnalyzer_.Analyze(std::get<1>(triplet.t))};
  MaybeExpr strideExpr{exprAnalyzer_.Analyze(std::get<2>(triplet.t))};
  if (lowerExpr && upperExpr) {
    auto lowerType{lowerExpr->GetType()};
    auto upperType{upperExpr->GetType()};
    auto strideType{strideExpr ? strideExpr->GetType() : lowerType};
    if (lowerType && upperType && strideType) {
      int kind{lowerType->kind()};
      if (upperType->kind() > kind) {
        kind = upperType->kind();
      }
      if (strideType->kind() > kind) {
        kind = strideType->kind();
      }
      auto lower{ToSpecificInt<ImpliedDoIntType::kind>(std::move(lowerExpr))};
      auto upper{ToSpecificInt<ImpliedDoIntType::kind>(std::move(upperExpr))};
      if (lower && upper) {
        auto stride{
            ToSpecificInt<ImpliedDoIntType::kind>(std::move(strideExpr))};
        if (!stride) {
          stride = Expr<ImpliedDoIntType>{1};
        }
        DynamicType type{TypeCategory::Integer, kind};
        if (!type_) {
          type_ = DynamicTypeWithLength{type};
        }
        parser::CharBlock anonymous;
        if (auto converted{ConvertToType(type,
                AsGenericExpr(
                    Expr<ImpliedDoIntType>{ImpliedDoIndex{anonymous}}))}) {
          auto v{std::move(values_)};
          Push(std::move(converted));
          std::swap(v, values_);
          values_.Push(ImpliedDo<SomeType>{anonymous, std::move(*lower),
              std::move(*upper), std::move(*stride), std::move(v)});
        }
      }
    }
  }
}

void ArrayConstructorContext::Add(const parser::Expr &expr) {
  auto restorer1{
      exprAnalyzer_.GetContextualMessages().SetLocation(expr.source)};
  auto restorer2{exprAnalyzer_.AllowWholeAssumedSizeArray(false)};
  Push(exprAnalyzer_.Analyze(expr));
}

void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
  const auto &control{std::get<parser::AcImpliedDoControl>(impliedDo.t)};
  const auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)};
  exprAnalyzer_.Analyze(bounds.Name());
  const auto &parsedName{parser::UnwrapRef<parser::Name>(bounds.Name())};
  parser::CharBlock name{parsedName.source};
  int kind{ImpliedDoIntType::kind};
  if (const Symbol *symbol{parsedName.symbol}) {
    if (auto dynamicType{DynamicType::From(symbol)}) {
      if (dynamicType->category() == TypeCategory::Integer) {
        kind = dynamicType->kind();
      }
    }
  }
  std::optional<Expr<ImpliedDoIntType>> lower{
      GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.Lower())};
  std::optional<Expr<ImpliedDoIntType>> upper{
      GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.Upper())};
  if (lower && upper) {
    std::optional<Expr<ImpliedDoIntType>> stride{
        GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.Step())};
    if (!stride) {
      stride = Expr<ImpliedDoIntType>{1};
    }
    if (exprAnalyzer_.AddImpliedDo(name, kind)) {
      // Check for constant bounds; the loop may require complete unrolling
      // of the parse tree if all bounds are constant in order to allow the
      // implied DO loop index to qualify as a constant expression.
      auto cLower{ToInt64(lower)};
      auto cUpper{ToInt64(upper)};
      auto cStride{ToInt64(stride)};
      if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) {
        exprAnalyzer_.SayAt(
            parser::UnwrapRef<parser::Expr>(bounds.Step()).source,
            "The stride of an implied DO loop must not be zero"_err_en_US);
        messageDisplayedSet_ |= 0x10;
      }
      bool isConstant{cLower && cUpper && cStride && *cStride != 0};
      bool isNonemptyConstant{isConstant &&
          ((*cStride > 0 && *cLower <= *cUpper) ||
              (*cStride < 0 && *cLower >= *cUpper))};
      bool isEmpty{isConstant && !isNonemptyConstant};
      bool unrollConstantLoop{false};
      parser::Messages buffer;
      auto saveMessagesDisplayed{messageDisplayedSet_};
      {
        auto messageRestorer{
            exprAnalyzer_.GetContextualMessages().SetMessages(buffer)};
        auto v{std::move(values_)};
        for (const auto &value :
            std::get<std::list<parser::AcValue>>(impliedDo.t)) {
          Add(value);
        }
        std::swap(v, values_);
        if (isNonemptyConstant && buffer.AnyFatalError()) {
          unrollConstantLoop = true;
        } else {
          values_.Push(ImpliedDo<SomeType>{name, std::move(*lower),
              std::move(*upper), std::move(*stride), std::move(v)});
        }
      }
      // F'2023 7.8 p5
      if (!(messageDisplayedSet_ & 0x100) && isEmpty && NeedLength()) {
        exprAnalyzer_.SayAt(name,
            "Array constructor implied DO loop has no iterations and indeterminate character length"_err_en_US);
        messageDisplayedSet_ |= 0x100;
      }
      if (unrollConstantLoop) {
        messageDisplayedSet_ = saveMessagesDisplayed;
        UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride);
      } else if (auto *messages{
                     exprAnalyzer_.GetContextualMessages().messages()}) {
        messages->Annex(std::move(buffer));
      }
      exprAnalyzer_.RemoveImpliedDo(name);
    } else if (!(messageDisplayedSet_ & 0x20)) {
      exprAnalyzer_.SayAt(name,
          "Implied DO index '%s' is active in a surrounding implied DO loop and may not have the same name"_err_en_US,
          name); // C7115
      messageDisplayedSet_ |= 0x20;
    }
  }
}

// Fortran considers an implied DO index of an array constructor to be
// a constant expression if the bounds of the implied DO loop are constant.
// Usually this doesn't matter, but if we emitted spurious messages as a
// result of not using constant values for the index while analyzing the
// items, we need to do it again the "hard" way with multiple iterations over
// the parse tree.
void ArrayConstructorContext::UnrollConstantImpliedDo(
    const parser::AcImpliedDo &impliedDo, parser::CharBlock name,
    std::int64_t lower, std::int64_t upper, std::int64_t stride) {
  auto &foldingContext{exprAnalyzer_.GetFoldingContext()};
  auto restorer{exprAnalyzer_.DoNotUseSavedTypedExprs()};
  for (auto &at{foldingContext.StartImpliedDo(name, lower)};
       (stride > 0 && at <= upper) || (stride < 0 && at >= upper);
       at += stride) {
    for (const auto &value :
        std::get<std::list<parser::AcValue>>(impliedDo.t)) {
      Add(value);
    }
  }
  foldingContext.EndImpliedDo(name);
}

MaybeExpr ArrayConstructorContext::ToExpr() {
  return common::SearchTypes(std::move(*this));
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayConstructor &array) {
  const parser::AcSpec &acSpec{array.v};
  const auto &[type, values]{acSpec.t};
  bool hadAnyFatalError{context_.AnyFatalError()};
  ArrayConstructorContext acContext{
      *this, AnalyzeTypeSpec(type, GetFoldingContext())};
  for (const parser::AcValue &value : values) {
    acContext.Add(value);
  }
  if (!hadAnyFatalError && context_.AnyFatalError()) {
    return std::nullopt;
  }
  return acContext.ToExpr();
}

// Check if implicit conversion of expr to the symbol type is legal (if needed),
// and make it explicit if requested.
static MaybeExpr ImplicitConvertTo(const Symbol &sym, Expr<SomeType> &&expr,
    bool keepConvertImplicit, FoldingContext &foldingContext) {
  CheckRealWidening(expr, DynamicType::From(sym), foldingContext);
  if (!keepConvertImplicit) {
    return ConvertToType(sym, std::move(expr));
  } else {
    // Test if a convert could be inserted, but do not make it explicit to
    // preserve the information that expr is a variable.
    if (ConvertToType(sym, common::Clone(expr))) {
      return MaybeExpr{std::move(expr)};
    }
  }
  // Illegal implicit convert.
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::CheckStructureConstructor(
    parser::CharBlock typeName, const semantics::DerivedTypeSpec &spec0,
    std::list<ComponentSpec> &&componentSpecs) {
  semantics::Scope &scope{context_.FindScope(typeName)};
  FoldingContext &foldingContext{GetFoldingContext()};
  const semantics::DerivedTypeSpec *effectiveSpec{&spec0};
  if (foldingContext.pdtInstance() && spec0.MightBeParameterized()) {
    // We're processing a structure constructor in the context of a derived
    // type instantiation, and the derived type of the structure constructor
    // is parameterized.  Evaluate its parameters in the context of the
    // instantiation in progress so that the components in constructor's scope
    // have the correct types.
    semantics::DerivedTypeSpec newSpec{spec0};
    newSpec.ReevaluateParameters(context());
    const semantics::DeclTypeSpec &instantiatedType{
        semantics::FindOrInstantiateDerivedType(
            scope, std::move(newSpec), semantics::DeclTypeSpec::TypeDerived)};
    effectiveSpec = &instantiatedType.derivedTypeSpec();
  }
  const semantics::DerivedTypeSpec &spec{*effectiveSpec};
  const Symbol &typeSymbol{spec.typeSymbol()};
  if (!spec.scope() || !typeSymbol.has<semantics::DerivedTypeDetails>()) {
    return std::nullopt; // error recovery
  }
  const semantics::Scope *pureContext{FindPureProcedureContaining(scope)};
  const auto &typeDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
  const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};
  if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796
    AttachDeclaration(
        Say(typeName,
            "ABSTRACT derived type '%s' may not be used in a structure constructor"_err_en_US,
            typeName),
        typeSymbol); // C7114
  }

  // This iterator traverses all of the components in the derived type and its
  // parents.  The symbols for whole parent components appear after their
  // own components and before the components of the types that extend them.
  // E.g., TYPE :: A; REAL X; END TYPE
  //       TYPE, EXTENDS(A) :: B; REAL Y; END TYPE
  // produces the component list X, A, Y.
  // The order is important below because a structure constructor can
  // initialize X or A by name, but not both.
  auto components{semantics::OrderedComponentIterator{spec}};
  auto nextAnonymous{components.begin()};
  auto afterLastParentComponentIter{components.end()};
  if (parentComponent) {
    for (auto iter{components.begin()}; iter != components.end(); ++iter) {
      if (iter->test(Symbol::Flag::ParentComp)) {
        afterLastParentComponentIter = iter;
        ++afterLastParentComponentIter;
      }
    }
  }

  std::set<parser::CharBlock> unavailable;
  bool anyKeyword{false};
  StructureConstructor result{spec};
  bool checkConflicts{true}; // until we hit one
  auto &messages{GetContextualMessages()};

  for (ComponentSpec &componentSpec : componentSpecs) {
    parser::CharBlock source{componentSpec.source};
    parser::CharBlock exprSource{componentSpec.exprSource};
    auto restorer{messages.SetLocation(source)};
    const Symbol *symbol{componentSpec.keywordSymbol};
    if (symbol) {
      symbol = spec.scope()->FindComponent(symbol->name());
    }
    MaybeExpr &maybeValue{componentSpec.expr};
    if (!maybeValue.has_value()) {
      return std::nullopt;
    }
    Expr<SomeType> &value{*maybeValue};
    std::optional<DynamicType> valueType{DynamicType::From(value)};
    if (componentSpec.hasKeyword) {
      anyKeyword = true;
      if (!symbol) {
        // Skip overridden inaccessible parent components in favor of
        // their later overrides.
        for (const Symbol &sym : components) {
          if (sym.name() == source) {
            symbol = &sym;
          }
        }
      }
      if (!symbol) { // C7101
        Say(source,
            "Keyword '%s=' does not name a component of derived type '%s'"_err_en_US,
            source, typeName);
      }
    } else {
      if (anyKeyword) { // C7100
        Say(source,
            "Value in structure constructor lacks a component name"_err_en_US);
        checkConflicts = false; // stem cascade
      }
      // Here's a regrettably common extension of the standard: anonymous
      // initialization of parent components, e.g., T(PT(1)) rather than
      // T(1) or T(PT=PT(1)).  There may be multiple parent components.
      if (nextAnonymous == components.begin() && parentComponent && valueType &&
          context().IsEnabled(LanguageFeature::AnonymousParents)) {
        auto parent{components.begin()};
        if (!parent->test(Symbol::Flag::ParentComp)) {
          // Ensure that the first value can't initialize the first actual
          // component.
          if (auto firstComponentType{DynamicType::From(*parent)}) {
            if (firstComponentType->IsTkCompatibleWith(*valueType) &&
                value.Rank() == parent->Rank()) {
              parent = afterLastParentComponentIter; // skip next loop
            }
          }
        }
        for (; parent != afterLastParentComponentIter; ++parent) {
          if (auto parentType{DynamicType::From(*parent)}) {
            if (parent->test(Symbol::Flag::ParentComp) &&
                valueType->IsEquivalentTo(*parentType) &&
                value.Rank() == 0 /* scalar only */) {
              symbol = &*parent;
              nextAnonymous = ++parent;
              Warn(LanguageFeature::AnonymousParents, source,
                  "Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
                  symbol->name());
              break;
            }
          }
        }
      }
      while (!symbol && nextAnonymous != components.end()) {
        const Symbol &next{*nextAnonymous};
        ++nextAnonymous;
        if (!next.test(Symbol::Flag::ParentComp)) {
          symbol = &next;
        }
      }
      if (!symbol) {
        Say(source, "Unexpected value in structure constructor"_err_en_US);
      }
    }
    if (symbol) {
      const semantics::Scope &innermost{context_.FindScope(exprSource)};
      if (auto msg{CheckAccessibleSymbol(
              innermost, *symbol, /*inStructureConstructor=*/true)}) {
        Say(exprSource, std::move(*msg));
      }
      if (checkConflicts) {
        auto componentIter{
            std::find(components.begin(), components.end(), *symbol)};
        if (unavailable.find(symbol->name()) != unavailable.cend()) {
          // C797, C798
          Say(source,
              "Component '%s' conflicts with another component earlier in this structure constructor"_err_en_US,
              symbol->name());
        } else if (symbol->test(Symbol::Flag::ParentComp)) {
          // Make earlier components unavailable once a whole parent appears.
          for (auto it{components.begin()}; it != componentIter; ++it) {
            unavailable.insert(it->name());
          }
        } else {
          // Make whole parent components unavailable after any of their
          // constituents appear.
          for (auto it{componentIter}; it != components.end(); ++it) {
            if (it->test(Symbol::Flag::ParentComp)) {
              unavailable.insert(it->name());
            }
          }
        }
      }
      unavailable.insert(symbol->name());
      if (symbol->has<semantics::TypeParamDetails>()) {
        Say(exprSource,
            "Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US,
            symbol->name());
      }
      if (!(symbol->has<semantics::ProcEntityDetails>() ||
              symbol->has<semantics::ObjectEntityDetails>())) {
        continue; // recovery
      }
      if (IsPointer(*symbol)) { // C7104, C7105, C1594(4)
        semantics::CheckStructConstructorPointerComponent(
            context_, *symbol, value, innermost);
        result.Add(*symbol, Fold(std::move(value)));
        continue;
      }
      if (IsNullPointer(&value)) {
        if (IsAllocatable(*symbol)) {
          if (IsBareNullPointer(&value)) {
            // NULL() with no arguments allowed by 7.5.10 para 6 for
            // ALLOCATABLE.
            result.Add(*symbol, Expr<SomeType>{NullPointer{}});
            continue;
          }
          if (IsNullObjectPointer(&value)) {
            AttachDeclaration(
                Warn(common::LanguageFeature::NullMoldAllocatableComponentValue,
                    exprSource,
                    "NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,
                    symbol->name()),
                *symbol);
            // proceed to check type & shape
          } else {
            AttachDeclaration(
                Say(exprSource,
                    "A NULL procedure pointer may not be used as the value for component '%s'"_err_en_US,
                    symbol->name()),
                *symbol);
            continue;
          }
        } else {
          AttachDeclaration(
              Say(exprSource,
                  "A NULL pointer may not be used as the value for component '%s'"_err_en_US,
                  symbol->name()),
              *symbol);
          continue;
        }
      } else if (IsNullAllocatable(&value) && IsAllocatable(*symbol)) {
        result.Add(*symbol, Expr<SomeType>{NullPointer{}});
        continue;
      } else if (auto *derived{evaluate::GetDerivedTypeSpec(
                     evaluate::DynamicType::From(*symbol))}) {
        if (auto iter{FindPointerPotentialComponent(*derived)};
            iter && pureContext) { // F'2023 C15104(4)
          if (const Symbol *
              visible{semantics::FindExternallyVisibleObject(
                  value, *pureContext)}) {
            Say(exprSource,
                "The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
                visible->name(), symbol->name(),
                iter.BuildResultDesignatorName());
          } else if (ExtractCoarrayRef(value)) {
            Say(exprSource,
                "A coindexed object may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
                symbol->name(), iter.BuildResultDesignatorName());
          }
        }
      }
      // Make implicit conversion explicit to allow folding of the structure
      // constructors and help semantic checking, unless the component is
      // allocatable, in which case the value could be an unallocated
      // allocatable (see Fortran 2018 7.5.10 point 7). The explicit
      // convert would cause a segfault. Lowering will deal with
      // conditionally converting and preserving the lower bounds in this
      // case.
      if (MaybeExpr converted{ImplicitConvertTo(*symbol, std::move(value),
              /*keepConvertImplicit=*/IsAllocatable(*symbol),
              foldingContext)}) {
        if (auto componentShape{GetShape(foldingContext, *symbol)}) {
          if (auto valueShape{GetShape(foldingContext, *converted)}) {
            if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
              AttachDeclaration(
                  Say(exprSource,
                      "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
                      GetRank(*valueShape), symbol->name()),
                  *symbol);
            } else {
              auto checked{CheckConformance(messages, *componentShape,
                  *valueShape, CheckConformanceFlags::RightIsExpandableDeferred,
                  "component", "value")};
              if (checked.value_or(false) && GetRank(*componentShape) > 0 &&
                  GetRank(*valueShape) == 0 &&
                  (IsDeferredShape(*symbol) ||
                      !IsExpandableScalar(*converted, foldingContext,
                          *componentShape, true /*admit PURE call*/))) {
                AttachDeclaration(
                    Say(exprSource,
                        "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
                        symbol->name()),
                    *symbol);
              }
              if (checked.value_or(true)) {
                result.Add(*symbol, std::move(*converted));
              }
            }
          } else {
            Say(exprSource, "Shape of value cannot be determined"_err_en_US);
          }
        } else {
          AttachDeclaration(
              Say(exprSource,
                  "Shape of component '%s' cannot be determined"_err_en_US,
                  symbol->name()),
              *symbol);
        }
      } else if (auto symType{DynamicType::From(symbol)}) {
        if (IsAllocatable(*symbol) && symType->IsUnlimitedPolymorphic() &&
            valueType) {
          // ok
        } else if (valueType) {
          AttachDeclaration(
              Say(exprSource,
                  "Value in structure constructor of type '%s' is incompatible with component '%s' of type '%s'"_err_en_US,
                  valueType->AsFortran(), symbol->name(), symType->AsFortran()),
              *symbol);
        } else {
          AttachDeclaration(
              Say(exprSource,
                  "Value in structure constructor is incompatible with component '%s' of type %s"_err_en_US,
                  symbol->name(), symType->AsFortran()),
              *symbol);
        }
      }
    }
  }

  // Ensure that unmentioned component objects have default initializers.
  for (const Symbol &symbol : components) {
    if (!symbol.test(Symbol::Flag::ParentComp) &&
        unavailable.find(symbol.name()) == unavailable.cend()) {
      if (const auto *object{
              symbol.detailsIf<semantics::ObjectEntityDetails>()};
          object && object->init()) {
        result.Add(symbol, common::Clone(*object->init()));
      } else if (const auto *proc{
                     symbol.detailsIf<semantics::ProcEntityDetails>()};
          proc && proc->init() && *proc->init()) {
        result.Add(symbol, Expr<SomeType>{ProcedureDesignator{**proc->init()}});
      } else if (IsAllocatableOrPointer(symbol)) {
        result.Add(symbol, Expr<SomeType>{NullPointer{}});
        if (IsPointer(symbol)) {
          AttachDeclaration(
              Warn(common::LanguageFeature::DefaultStructConstructorNullPointer,
                  typeName,
                  "Structure constructor lacks a value for pointer component '%s', NULL() assumed"_warn_en_US,
                  symbol.name()),
              symbol);
        }
      } else {
        AttachDeclaration(
            Say(typeName,
                "Structure constructor lacks a value for component '%s'"_err_en_US,
                symbol.name()),
            symbol);
      }
    }
  }

  return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
}

// F2023 R771: enumeration-constructor is enumeration-type-spec (
// scalar-int-expr ) The scalar-int-expr shall have a value that is positive and
// less than or equal to the number of enumerators in the enumeration type.
MaybeExpr ExpressionAnalyzer::AnalyzeEnumerationConstructor(
    parser::CharBlock typeName, const semantics::DerivedTypeSpec &spec,
    const std::list<parser::ComponentSpec> &components) {
  const semantics::Symbol &typeSymbol{spec.typeSymbol()};
  const auto &typeDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
  int enumeratorCount{typeDetails.enumeratorCount()};
  // Validate: exactly one positional argument, no keywords
  if (components.size() != 1) {
    Say(typeName,
        "Enumeration constructor for '%s' requires exactly one argument"_err_en_US,
        typeName);
    return std::nullopt;
  }
  const auto &component{components.front()};
  if (std::get<std::optional<parser::Keyword>>(component.t)) {
    Say(typeName,
        "Enumeration constructor for '%s' may not have a keyword argument"_err_en_US,
        typeName);
    return std::nullopt;
  }
  // Analyze the argument as a scalar integer expression
  const parser::Expr &argExpr{
      std::get<parser::ComponentDataSource>(component.t).v.value()};
  auto restorer{GetContextualMessages().SetLocation(argExpr.source)};
  MaybeExpr analyzed{Analyze(argExpr)};
  if (!analyzed) {
    return std::nullopt;
  }
  auto folded{Fold(std::move(*analyzed))};
  auto argType{folded.GetType()};
  if (!argType || argType->category() != TypeCategory::Integer) {
    Say(argExpr.source,
        "Enumeration constructor argument must be INTEGER, but is %s"_err_en_US,
        argType ? argType->AsFortran() : std::string{"typeless"});
    return std::nullopt;
  }
  // F2023 R771: the argument shall be a scalar-int-expr.
  if (folded.Rank() > 0) {
    Say(argExpr.source,
        "Enumeration constructor argument for '%s' must be scalar"_err_en_US,
        typeName);
    return std::nullopt;
  }
  // If the value is known at compile time, validate the range
  if (auto value{ToInt64(folded)}) {
    if (*value < 1 || *value > enumeratorCount) {
      Say(argExpr.source,
          "Enumeration constructor value (%jd) for '%s' must be positive and less than or equal to the number of enumerators (%d)"_err_en_US,
          static_cast<std::intmax_t>(*value), typeName, enumeratorCount);
      return std::nullopt;
    }
  }
  // Produce an Expr<SomeDerived> with the ordinal in the __ordinal component,
  // converted to the component's declared integer kind.
  StructureConstructor result{spec};
  if (const auto *scope{spec.GetScope()}) {
    auto ordinalIter{scope->find(semantics::SourceName{
        semantics::DerivedTypeDetails::ordinalComponentName,
        sizeof(semantics::DerivedTypeDetails::ordinalComponentName) - 1})};
    if (ordinalIter != scope->end()) {
      const Symbol &ordinalSymbol{*ordinalIter->second};
      if (auto converted{ConvertToType(ordinalSymbol, std::move(folded))}) {
        result.Add(ordinalSymbol, std::move(*converted));
      }
    }
  }
  return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::StructureConstructor &structure) {
  const auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};
  parser::Name structureType{std::get<parser::Name>(parsedType.t)};
  parser::CharBlock &typeName{structureType.source};
  if (semantics::Symbol * typeSymbol{structureType.symbol}) {
    if (typeSymbol->has<semantics::DerivedTypeDetails>()) {
      semantics::DerivedTypeSpec dtSpec{typeName, typeSymbol->GetUltimate()};
      if (!CheckIsValidForwardReference(dtSpec)) {
        return std::nullopt;
      }
    }
  }
  if (!parsedType.derivedTypeSpec) {
    return std::nullopt;
  }
  // F2023 R771: Enumeration constructor — enum_name(scalar-int-expr)
  if (parsedType.derivedTypeSpec->IsEnumerationType()) {
    return AnalyzeEnumerationConstructor(typeName, *parsedType.derivedTypeSpec,
        std::get<std::list<parser::ComponentSpec>>(structure.t));
  }
  auto restorer{AllowNullPointer()}; // NULL() can be a valid component
  std::list<ComponentSpec> componentSpecs;
  for (const auto &component :
      std::get<std::list<parser::ComponentSpec>>(structure.t)) {
    const parser::Expr &expr{
        std::get<parser::ComponentDataSource>(component.t).v.value()};
    auto restorer{GetContextualMessages().SetLocation(expr.source)};
    ComponentSpec compSpec;
    compSpec.exprSource = expr.source;
    compSpec.expr = Analyze(expr);
    if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
      compSpec.source = kw->v.source;
      compSpec.hasKeyword = true;
      compSpec.keywordSymbol = kw->v.symbol;
    } else {
      compSpec.source = expr.source;
    }
    componentSpecs.emplace_back(std::move(compSpec));
  }
  return CheckStructureConstructor(
      typeName, DEREF(parsedType.derivedTypeSpec), std::move(componentSpecs));
}

static std::optional<parser::CharBlock> GetPassName(
    const semantics::Symbol &proc) {
  return common::visit(
      [](const auto &details) {
        if constexpr (std::is_base_of_v<semantics::WithPassArg,
                          std::decay_t<decltype(details)>>) {
          return details.passName();
        } else {
          return std::optional<parser::CharBlock>{};
        }
      },
      proc.details());
}

static std::optional<int> GetPassIndex(const Symbol &proc) {
  CHECK(!proc.attrs().test(semantics::Attr::NOPASS));
  std::optional<parser::CharBlock> passName{GetPassName(proc)};
  const auto *interface {
    semantics::FindInterface(proc)
  };
  if (!passName || !interface) {
    return 0; // first argument is passed-object
  }
  const auto &subp{interface->get<semantics::SubprogramDetails>()};
  int index{0};
  for (const auto *arg : subp.dummyArgs()) {
    if (arg && arg->name() == passName) {
      return index;
    }
    ++index;
  }
  return std::nullopt;
}

// Injects an expression into an actual argument list as the "passed object"
// for a type-bound procedure reference that is not NOPASS.  Adds an
// argument keyword if possible, but not when the passed object goes
// before a positional argument.
// e.g., obj%tbp(x) -> tbp(obj,x).
static void AddPassArg(ActualArguments &actuals, const Expr<SomeDerived> &expr,
    const Symbol &component, bool isPassedObject = true) {
  if (component.attrs().test(semantics::Attr::NOPASS)) {
    return;
  }
  std::optional<int> passIndex{GetPassIndex(component)};
  if (!passIndex) {
    return; // error recovery
  }
  auto iter{actuals.begin()};
  int at{0};
  while (iter < actuals.end() && at < *passIndex) {
    if (*iter && (*iter)->keyword()) {
      iter = actuals.end();
      break;
    }
    ++iter;
    ++at;
  }
  ActualArgument passed{AsGenericExpr(common::Clone(expr))};
  passed.set_isPassedObject(isPassedObject);
  if (iter == actuals.end()) {
    if (auto passName{GetPassName(component)}) {
      passed.set_keyword(*passName);
    }
  }
  actuals.emplace(iter, std::move(passed));
}

// Return the compile-time resolution of a procedure binding, if possible.
static const Symbol *GetBindingResolution(
    const std::optional<DynamicType> &baseType, const Symbol &component) {
  const auto *binding{component.detailsIf<semantics::ProcBindingDetails>()};
  if (!binding) {
    return nullptr;
  }
  if (!component.attrs().test(semantics::Attr::NON_OVERRIDABLE) &&
      (!baseType || baseType->IsPolymorphic())) {
    return nullptr;
  }
  return &binding->symbol();
}

auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
    const parser::ProcComponentRef &pcr, ActualArguments &&arguments,
    bool isSubroutine) -> std::optional<CalleeAndArguments> {
  const auto &sc{parser::UnwrapRef<parser::StructureComponent>(pcr)};
  if (MaybeExpr base{Analyze(sc.Base())}) {
    if (const Symbol *sym{sc.Component().symbol}) {
      if (context_.HasError(sym)) {
        return std::nullopt;
      }
      if (!IsProcedure(*sym)) {
        AttachDeclaration(
            Say(sc.Component().source, "'%s' is not a procedure"_err_en_US,
                sc.Component().source),
            *sym);
        return std::nullopt;
      }
      const bool isGeneric{sym->has<semantics::GenericDetails>()};
      auto withGenericName{[&](ProcedureDesignator proc) {
        if (isGeneric) {
          proc.set_genericName(sc.Component().source);
        }
        return proc;
      }};
      if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
        if (sym->has<semantics::GenericDetails>()) {
          const Symbol &generic{*sym};
          auto dyType{dtExpr->GetType()};
          AdjustActuals adjustment{
              [&](const Symbol &proc, ActualArguments &actuals) {
                if (!proc.attrs().test(semantics::Attr::NOPASS)) {
                  AddPassArg(actuals, std::move(*dtExpr), proc);
                }
                return true;
              }};
          auto result{CheckAndResolveGenericReference(
              generic, arguments, adjustment, isSubroutine, SymbolVector{})};
          sym = result.specific;
          if (!sym) {
            if (!result.errorReported) {
              EmitGenericResolutionError(generic, result.failedDueToAmbiguity,
                  isSubroutine, arguments, result.tried, adjustment);
            }
            return std::nullopt;
          }
          // re-resolve the name to the specific binding
          CHECK(sym->has<semantics::ProcBindingDetails>());
          // Use the most recent override of a binding, respecting
          // the rule that inaccessible bindings may not be overridden
          // outside their module.  Fortran doesn't allow a PUBLIC
          // binding to be overridden by a PRIVATE one.
          CHECK(dyType && dyType->category() == TypeCategory::Derived &&
              !dyType->IsUnlimitedPolymorphic());
          if (const Symbol *
              latest{DEREF(dyType->GetDerivedTypeSpec().typeSymbol().scope())
                         .FindComponent(sym->name())}) {
            if (sym->attrs().test(semantics::Attr::PRIVATE)) {
              const auto *bindingModule{FindModuleContaining(sym->owner())};
              const Symbol *s{latest};
              while (s && FindModuleContaining(s->owner()) != bindingModule) {
                if (const auto *parent{s->owner().GetDerivedTypeParent()}) {
                  s = parent->FindComponent(sym->name());
                } else {
                  s = nullptr;
                }
              }
              if (s && !s->attrs().test(semantics::Attr::PRIVATE)) {
                // The latest override in the same module as the binding
                // is public, so it can be overridden.
              } else {
                latest = s;
              }
            }
            if (latest) {
              sym = latest;
            }
          }
          sc.Component().symbol = const_cast<Symbol *>(sym);
        }
        std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};
        if (dataRef && !CheckDataRef(*dataRef)) {
          return std::nullopt;
        }
        if (dataRef && dataRef->Rank() > 0) {
          if (sym->has<semantics::ProcBindingDetails>() &&
              sym->attrs().test(semantics::Attr::NOPASS)) {
            // F'2023 C1529 seems unnecessary and most compilers don't
            // enforce it.
            AttachDeclaration(
                Warn(common::LanguageFeature::NopassScalarBase,
                    sc.Component().source,
                    "Base of NOPASS type-bound procedure reference should be scalar"_port_en_US),
                *sym);
          } else if (IsProcedurePointer(*sym)) { // C919
            Say(sc.Component().source,
                "Base of procedure component reference must be scalar"_err_en_US);
          }
        }
        if (IsFunction(*sym) == isSubroutine &&
            sym->has<semantics::ProcBindingDetails>()) {
          AttachDeclaration(
              Say(sc.Component().source, "Binding '%s' is not a %s"_err_en_US,
                  sym->name(), isSubroutine ? "subroutine" : "function"),
              *sym);
        }
        if (const Symbol *resolution{
                GetBindingResolution(dtExpr->GetType(), *sym)}) {
          AddPassArg(arguments, std::move(*dtExpr), *sym, false);
          return CalleeAndArguments{
              withGenericName(ProcedureDesignator{*resolution}),
              std::move(arguments)};
        } else if (dataRef.has_value()) {
          if (ExtractCoarrayRef(*dataRef)) {
            if (IsProcedurePointer(*sym)) {
              Say(sc.Component().source,
                  "Base of procedure component reference may not be coindexed"_err_en_US);
            } else {
              Say(sc.Component().source,
                  "A procedure binding may not be coindexed unless it can be resolved at compilation time"_err_en_US);
            }
          }
          if (sym->attrs().test(semantics::Attr::NOPASS)) {
            const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
            if (dtSpec && dtSpec->scope()) {
              if (auto component{CreateComponent(std::move(*dataRef), *sym,
                      *dtSpec->scope(), /*C919bAlreadyEnforced=*/true)}) {
                return CalleeAndArguments{
                    withGenericName(ProcedureDesignator{std::move(*component)}),
                    std::move(arguments)};
              }
            }
            Say(sc.Component().source,
                "Component is not in scope of base derived type"_err_en_US);
            return std::nullopt;
          } else {
            AddPassArg(arguments,
                Expr<SomeDerived>{Designator<SomeDerived>{std::move(*dataRef)}},
                *sym);
            return CalleeAndArguments{
                withGenericName(ProcedureDesignator{*sym}),
                std::move(arguments)};
          }
        }
      }
      Say(sc.Component().source,
          "Base of procedure component reference is not a derived-type object"_err_en_US);
    }
  }
  CHECK(context_.AnyFatalError());
  return std::nullopt;
}

// Can actual be argument associated with dummy?
static bool CheckCompatibleArgument(bool isElemental,
    const ActualArgument &actual, const characteristics::DummyArgument &dummy,
    FoldingContext &foldingContext) {
  const auto *expr{actual.UnwrapExpr()};
  return common::visit(
      common::visitors{
          [&](const characteristics::DummyDataObject &x) {
            if ((x.attrs.test(
                     characteristics::DummyDataObject::Attr::Pointer) ||
                    x.attrs.test(
                        characteristics::DummyDataObject::Attr::Allocatable)) &&
                IsBareNullPointer(expr)) {
              // NULL() without MOLD= is compatible with any dummy data pointer
              // or allocatable, but cannot be allowed to lead to ambiguity.
              return true;
            } else if (!isElemental && actual.Rank() != x.type.Rank() &&
                !x.type.attrs().test(
                    characteristics::TypeAndShape::Attr::AssumedRank) &&
                !x.ignoreTKR.test(common::IgnoreTKR::Rank) &&
                !(x.type.type().IsAssumedType() &&
                    x.type.attrs().test(
                        characteristics::TypeAndShape::Attr::AssumedSize))) {
              return false;
            } else if (auto actualType{actual.GetType()}) {
              return x.type.type().IsTkCompatibleWith(*actualType, x.ignoreTKR);
            }
            return false;
          },
          [&](const characteristics::DummyProcedure &dummy) {
            if ((dummy.attrs.test(
                     characteristics::DummyProcedure::Attr::Optional) ||
                    dummy.attrs.test(
                        characteristics::DummyProcedure::Attr::Pointer)) &&
                IsBareNullPointer(expr)) {
              // NULL() is compatible with any dummy pointer
              // or optional dummy procedure.
              return true;
            }
            if (!expr || !IsProcedurePointerTarget(*expr)) {
              return false;
            }
            if (auto actualProc{characteristics::Procedure::Characterize(
                    *expr, foldingContext)}) {
              const auto &dummyResult{dummy.procedure.value().functionResult};
              const auto *dummyTypeAndShape{
                  dummyResult ? dummyResult->GetTypeAndShape() : nullptr};
              const auto &actualResult{actualProc->functionResult};
              const auto *actualTypeAndShape{
                  actualResult ? actualResult->GetTypeAndShape() : nullptr};
              if (dummyTypeAndShape && actualTypeAndShape) {
                // Return false when the function results' types are both
                // known and not compatible.
                return actualTypeAndShape->type().IsTkCompatibleWith(
                    dummyTypeAndShape->type());
              }
            }
            return true;
          },
          [&](const characteristics::AlternateReturn &) {
            return actual.isAlternateReturn();
          },
      },
      dummy.u);
}

// Are the actual arguments compatible with the dummy arguments of procedure?
static bool CheckCompatibleArguments(
    const characteristics::Procedure &procedure, const ActualArguments &actuals,
    FoldingContext &foldingContext) {
  bool isElemental{procedure.IsElemental()};
  const auto &dummies{procedure.dummyArguments};
  CHECK(dummies.size() == actuals.size());
  for (std::size_t i{0}; i < dummies.size(); ++i) {
    const characteristics::DummyArgument &dummy{dummies[i]};
    const std::optional<ActualArgument> &actual{actuals[i]};
    if (actual &&
        !CheckCompatibleArgument(isElemental, *actual, dummy, foldingContext)) {
      return false;
    }
  }
  return true;
}

static constexpr int cudaInfMatchingValue{common::numeric_limits<int>::max()};

struct CudaMatchingDistance {
  std::vector<int> perArg;
  bool isInfinite{false};
};

// Compare CUDA matching distances using lexicographical comparison of
// per-argument distances. This is needed to differentiate procedures that would
// have similar total distance when summing the per-argument weights, allowing
// the compiler to select the best match based on argument-by-argument
// comparison.
static int CompareCudaMatchingDistance(
    const CudaMatchingDistance &x, const CudaMatchingDistance &y) {
  if (x.isInfinite != y.isInfinite) {
    return x.isInfinite ? 1 : -1;
  }
  if (x.isInfinite) {
    return 0;
  }
  CHECK(x.perArg.size() == y.perArg.size());
  if (std::lexicographical_compare(
          x.perArg.begin(), x.perArg.end(), y.perArg.begin(), y.perArg.end())) {
    return -1;
  }
  if (std::lexicographical_compare(
          y.perArg.begin(), y.perArg.end(), x.perArg.begin(), x.perArg.end())) {
    return 1;
  }
  return 0;
}

// Compute the matching distance for one (dummy, actual) pair as described
// in section 3.2.3 ("Table 2: Attributed Argument Matching Distance Values")
// of the CUDA Fortran Programming Guide. The column applied for the actual
// depends on its CUDA data attribute and (for unattributed actuals) on the
// active -gpu=mem:{unified,managed} mode.
//
// Distance values returned (smaller is a better match; INF means
// incompatible and disqualifies the candidate):
//
//                       Actual argument attribute
//                 None                              ACC      gpu=    gpu=
//   Dummy attr   (Host)  Device  Managed  Unified  use_dev  unified  managed
//   ----------+--------+-------+--------+--------+--------+--------+--------+
//   None(host)|    0   |  INF  |   3    |   3    |   3    |   3    |   3    |
//   Device    |   INF  |   0   |   2    |   2    |   0    |   2    |   2    |
//   Managed   |   INF  |  INF  |   0    |   1    |  INF   |   1    |   0    |
//   Unified   |   INF  |  INF  |   1    |   0    |  INF   |   0    |   1    |
//
// Constant and Shared actuals use the Device column (all are device memory).
//
// In addition: a dummy declared TYPE(*) (assumed-size/rank opaque buffer)
// is "CUDA address space agnostic" and accepts any attributed actual at a
// non-zero distance (3) so an explicit Device overload still wins. The
// "ACC use_dev" column applies to actuals appearing in a surrounding
// ACC HOST_DATA USE_DEVICE clause.
static int GetMatchingDistance(const common::LanguageFeatureControl &features,
    semantics::SemanticsContext &context,
    const characteristics::DummyArgument &dummy,
    const std::optional<ActualArgument> &actual) {
  bool isCudaManaged{features.IsEnabled(common::LanguageFeature::CudaManaged)};
  bool isCudaUnified{features.IsEnabled(common::LanguageFeature::CudaUnified)};
  CHECK(!(isCudaUnified && isCudaManaged) && "expect only one enabled.");

  std::optional<common::CUDADataAttr> actualDataAttr, dummyDataAttr;
  // True when an unattributed actual may use the implicit CUDA memory mode
  // matching enabled by -gpu=mem:unified (any variable) or -gpu=mem:managed
  // (allocatable/pointer objects only).
  bool actualCanUseImplicitCudaMemoryMode{false};
  if (actual) {
    if (auto *expr{actual->UnwrapExpr()}) {
      if (evaluate::IsVariable(*expr)) {
        bool actualIsAllocatableOrPointer{false};
        // Match check-call.cpp: walk the whole designator so e.g. b%a picks up
        // ATTRIBUTES(DEVICE) from the base b when the component a has no CUDA
        // attribute (OpenACC use_device(b) + doit(b%a)), not only from the
        // last symbol (GetLastSymbol would only see a).
        for (const Symbol &s : evaluate::GetSymbolVector(*expr)) {
          if (semantics::IsAllocatableOrPointer(
                  semantics::ResolveAssociations(s))) {
            actualIsAllocatableOrPointer = true;
          }
          if (const auto *object{
                  s.detailsIf<semantics::ObjectEntityDetails>()}) {
            if (auto cudaAttr{object->cudaDataAttr()}) {
              actualDataAttr = *cudaAttr;
            }
          }
        }
        actualCanUseImplicitCudaMemoryMode =
            isCudaUnified || (isCudaManaged && actualIsAllocatableOrPointer);
        // An object mapped by an enclosing structured OpenACC data construct
        // has a device copy that a Device dummy can be associated with, but
        // ordinary references to it still denote the host object.
        if (!actualDataAttr && context.AnyOpenACCDataMapping()) {
          if (std::optional<parser::CharBlock> source{
                  actual->sourceLocation()}) {
            if (const semantics::Scope *scope{
                    context.FindScopeIfAny(*source)}) {
              for (const Symbol &symbol : evaluate::GetSymbolVector(*expr)) {
                if (semantics::IsOpenACCMapped(symbol, *scope)) {
                  actualDataAttr = common::CUDADataAttr::UseDevice;
                  break;
                }
              }
            }
          }
        }
      } else if (const auto *actualLastSymbol{evaluate::GetLastSymbol(*expr)}) {
        // Propagate any explicit CUDA data attribute from the referenced
        // symbol (e.g. a device array operand inside RESHAPE()) so that
        // Device-attributed dummies still match. Do NOT set
        // actualCanUseImplicitCudaMemoryMode: the expression result is a
        // temporary, not a user variable with unified/managed storage.
        const Symbol &resolved{
            semantics::ResolveAssociations(*actualLastSymbol)};
        if (const auto *actualObject{
                resolved.detailsIf<semantics::ObjectEntityDetails>()}) {
          actualDataAttr = actualObject->cudaDataAttr();
        }
      }
    }
  }

  bool dummyIsCudaAddressSpaceAgnostic{false};
  common::visit(common::visitors{
                    [&](const characteristics::DummyDataObject &object) {
                      dummyDataAttr = object.cudaDataAttr;
                      dummyIsCudaAddressSpaceAgnostic =
                          semantics::IsCUDAAddressSpaceAgnostic(object);
                    },
                    [&](const auto &) {},
                },
      dummy.u);

  if (actualDataAttr && dummyIsCudaAddressSpaceAgnostic) {
    // TYPE(*) assumed-size/rank dummies model opaque buffers, so they can
    // accept host or device storage. Keep a non-zero distance so an explicit
    // DEVICE overload remains a better CUDA match.
    return 3;
  }

  auto actualIsDeviceMemory{[&]() {
    return actualDataAttr &&
        (*actualDataAttr == common::CUDADataAttr::Device ||
            *actualDataAttr == common::CUDADataAttr::Constant ||
            *actualDataAttr == common::CUDADataAttr::Shared);
  }};

  if (!dummyDataAttr) {
    if (!actualDataAttr) {
      if ((isCudaUnified || isCudaManaged) &&
          actualCanUseImplicitCudaMemoryMode) {
        return 3;
      }
      return 0;
    } else if (actualIsDeviceMemory()) {
      return cudaInfMatchingValue;
    } else if (*actualDataAttr == common::CUDADataAttr::Managed ||
        *actualDataAttr == common::CUDADataAttr::Unified) {
      return 3;
    }
  } else if (*dummyDataAttr == common::CUDADataAttr::Device) {
    if (!actualDataAttr) {
      if ((isCudaUnified || isCudaManaged) &&
          actualCanUseImplicitCudaMemoryMode) {
        return 2;
      }
      return cudaInfMatchingValue;
    } else if (actualIsDeviceMemory()) {
      return 0;
    } else if (*actualDataAttr == common::CUDADataAttr::Managed ||
        *actualDataAttr == common::CUDADataAttr::Unified) {
      return 2;
    }
  } else if (*dummyDataAttr == common::CUDADataAttr::Managed) {
    if (!actualDataAttr) {
      if (!actualCanUseImplicitCudaMemoryMode) {
        return cudaInfMatchingValue;
      }
      return isCudaUnified ? 1 : isCudaManaged ? 0 : cudaInfMatchingValue;
    }
    if (actualIsDeviceMemory()) {
      return cudaInfMatchingValue;
    } else if (*actualDataAttr == common::CUDADataAttr::Managed) {
      return 0;
    } else if (*actualDataAttr == common::CUDADataAttr::Unified) {
      return 1;
    }
  } else if (*dummyDataAttr == common::CUDADataAttr::Unified) {
    if (!actualDataAttr) {
      if (!actualCanUseImplicitCudaMemoryMode) {
        return cudaInfMatchingValue;
      }
      return isCudaUnified ? 0 : isCudaManaged ? 1 : cudaInfMatchingValue;
    }
    if (actualIsDeviceMemory()) {
      return cudaInfMatchingValue;
    } else if (*actualDataAttr == common::CUDADataAttr::Managed) {
      return 1;
    } else if (*actualDataAttr == common::CUDADataAttr::Unified) {
      return 0;
    }
  }
  // An actual argument with the UseDevice attribute comes from an OpenACC
  // host_data use_device clause: the variable itself is host-resident, but
  // inside the host_data region it is referenced via its device address.
  // It matches a Device dummy with distance 0, a host dummy (no attribute)
  // with distance 1, and is incompatible with any other dummy attribute.
  if (actualDataAttr && *actualDataAttr == common::CUDADataAttr::UseDevice) {
    if (!dummyDataAttr)
      return 1;
    if (*dummyDataAttr == common::CUDADataAttr::Device)
      return 0;
  }
  return cudaInfMatchingValue;
}

static CudaMatchingDistance ComputeCudaMatchingDistance(
    semantics::SemanticsContext &context,
    const characteristics::Procedure &procedure,
    const ActualArguments &actuals) {
  const auto &dummies{procedure.dummyArguments};
  CHECK(dummies.size() == actuals.size());
  CudaMatchingDistance distance;
  distance.perArg.reserve(dummies.size());
  for (std::size_t i{0}; i < dummies.size(); ++i) {
    const characteristics::DummyArgument &dummy{dummies[i]};
    const std::optional<ActualArgument> &actual{actuals[i]};
    if (!actual) {
      // Omitted optional arguments do not affect CUDA matching distances.
      continue;
    }
    int d{GetMatchingDistance(
        context.languageFeatures(), context, dummy, actual)};
    if (d == cudaInfMatchingValue) {
      distance.isInfinite = true;
      return distance;
    }
    distance.perArg.push_back(d);
  }
  return distance;
}

// Handles a forward reference to a module function from what must
// be a specification expression.  Return false if the symbol is
// an invalid forward reference.
const Symbol *ExpressionAnalyzer::ResolveForward(const Symbol &symbol) {
  if (context_.HasError(symbol)) {
    return nullptr;
  }
  if (const auto *details{
          symbol.detailsIf<semantics::SubprogramNameDetails>()}) {
    if (details->kind() == semantics::SubprogramKind::Module) {
      // If this symbol is still a SubprogramNameDetails, we must be
      // checking a specification expression in a sibling module
      // procedure.  Resolve its names now so that its interface
      // is known.
      const semantics::Scope &scope{symbol.owner()};
      semantics::ResolveSpecificationParts(context_, symbol);
      const Symbol *resolved{nullptr};
      if (auto iter{scope.find(symbol.name())}; iter != scope.cend()) {
        resolved = &*iter->second;
      }
      if (!resolved || resolved->has<semantics::SubprogramNameDetails>()) {
        // When the symbol hasn't had its details updated, we must have
        // already been in the process of resolving the function's
        // specification part; but recursive function calls are not
        // allowed in specification parts (10.1.11 para 5).
        Say("The module function '%s' may not be referenced recursively in a specification expression"_err_en_US,
            symbol.name());
        context_.SetError(symbol);
      }
      return resolved;
    } else if (inStmtFunctionDefinition_) {
      semantics::ResolveSpecificationParts(context_, symbol);
      CHECK(symbol.has<semantics::SubprogramDetails>());
    } else { // 10.1.11 para 4
      Say("The internal function '%s' may not be referenced in a specification expression"_err_en_US,
          symbol.name());
      context_.SetError(symbol);
      return nullptr;
    }
  }
  return &symbol;
}

// Resolve a call to a generic procedure with given actual arguments.
// adjustActuals is called on procedure bindings to handle pass arg.
static bool IsCUDADeviceCallable(const Symbol &symbol) {
  const auto *subprogram{
      symbol.GetUltimate().detailsIf<semantics::SubprogramDetails>()};
  if (!subprogram) {
    return false;
  }
  auto attrs{subprogram->cudaSubprogramAttrs()};
  return attrs &&
      (*attrs == common::CUDASubprogramAttrs::Device ||
          *attrs == common::CUDASubprogramAttrs::HostDevice);
}

static bool IsCudaDeviceIntrinsicShadowedByHostProcedure(
    const parser::CharBlock &callSite, semantics::SemanticsContext &context,
    const Symbol *resolution, bool isSubroutine) {
  if (isSubroutine ||
      !context.languageFeatures().IsEnabled(common::LanguageFeature::CUDA) ||
      !resolution || !IsProcedure(*resolution) ||
      resolution->attrs().test(semantics::Attr::INTRINSIC) ||
      !semantics::FindCUDADeviceContext(&context.FindScope(callSite))) {
    return false;
  }
  // Keep use-associated names visible in device code, but do not let a
  // host-only procedure hide a valid intrinsic with the same generic name.
  return !IsCUDADeviceCallable(*resolution);
}

auto ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
    const ActualArguments &actuals, const AdjustActuals &adjustActuals,
    bool isSubroutine, SymbolVector &&tried, bool mightBeStructureConstructor)
    -> GenericResolution {
  const Symbol &ultimate{symbol.GetUltimate()};
  // Check for a match with an explicit INTRINSIC
  const Symbol *explicitIntrinsic{nullptr};
  if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
    parser::Messages buffer;
    auto restorer{GetContextualMessages().SetMessages(buffer)};
    ActualArguments localActuals{actuals};
    if (context_.intrinsics().Probe(
            CallCharacteristics{ultimate.name().ToString(), isSubroutine},
            localActuals, foldingContext_) &&
        !buffer.AnyFatalError()) {
      explicitIntrinsic = &ultimate;
    }
  }
  const Symbol *elemental{nullptr}; // matching elemental specific proc
  const Symbol *nonElemental{nullptr}; // matching non-elemental specific
  const auto *genericDetails{ultimate.detailsIf<semantics::GenericDetails>()};
  if (genericDetails) {
    std::optional<CudaMatchingDistance> crtMatchingDistance;
    for (const Symbol &specific0 : genericDetails->specificProcs()) {
      const Symbol &specific1{BypassGeneric(specific0)};
      if (isSubroutine != !IsFunction(specific1)) {
        continue;
      }
      const Symbol *specific{ResolveForward(specific1)};
      if (!specific) {
        continue;
      }
      if (std::optional<characteristics::Procedure> procedure{
              characteristics::Procedure::Characterize(
                  ProcedureDesignator{*specific}, context_.foldingContext(),
                  /*emitError=*/false)}) {
        ActualArguments localActuals{actuals};
        if (specific->has<semantics::ProcBindingDetails>()) {
          if (!adjustActuals.value()(*specific, localActuals)) {
            continue;
          }
        }
        tried.push_back(*specific);
        if (semantics::CheckInterfaceForGeneric(*procedure, localActuals,
                context_, false /* no integer conversions */) &&
            CheckCompatibleArguments(
                *procedure, localActuals, foldingContext_)) {
          CudaMatchingDistance d{
              ComputeCudaMatchingDistance(context_, *procedure, localActuals)};
          if ((procedure->IsElemental() && elemental) ||
              (!procedure->IsElemental() && nonElemental)) {
            if (crtMatchingDistance) {
              int cmp{CompareCudaMatchingDistance(d, *crtMatchingDistance)};
              if (cmp > 0) {
                continue;
              }
              if (cmp == 0) {
                // 16.9.144(6): a bare NULL() is not allowed as an actual
                // argument to a generic procedure if the specific procedure
                // cannot be unambiguously distinguished
                // Underspecified external procedure actual arguments can
                // also lead to ambiguity.
                return {nullptr, true /* due to ambiguity */, std::move(tried)};
              }
              // Matching distance is smaller than the previously matched
              // specific. Let it go through so the current procedure is picked.
            }
          }
          if (!procedure->IsElemental()) {
            // takes priority over elemental match
            nonElemental = specific;
          } else {
            elemental = specific;
          }
          crtMatchingDistance = std::move(d);
        }
      }
    }
  }
  // Is there a derived type of the same name?
  const Symbol *derivedType{nullptr};
  if (mightBeStructureConstructor && !isSubroutine && genericDetails) {
    if (const Symbol * dt{genericDetails->derivedType()}) {
      const Symbol &ultimate{dt->GetUltimate()};
      if (ultimate.has<semantics::DerivedTypeDetails>()) {
        derivedType = &ultimate;
      }
    }
  }

  // Return the right resolution, if there is one. Non-elemental specifics
  // are preferred, then elementals, then explicit intrinsics, and lastly
  // structure constructors.
  if (nonElemental) {
    return {&AccessSpecific(symbol, *nonElemental), false};
  } else if (elemental) {
    return {&AccessSpecific(symbol, *elemental), false};
  } else if (explicitIntrinsic) {
    return {explicitIntrinsic, false};
  }
  // Check parent derived type
  if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
    if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {
      auto result{ResolveGeneric(*extended, actuals, adjustActuals,
          isSubroutine, std::move(tried), false)};
      if (result.specific != nullptr) {
        return result;
      }
      tried = std::move(result.tried);
    }
  }
  // Structure constructor?
  if (derivedType) {
    return {derivedType, false};
  }
  // Check for generic or explicit INTRINSIC of the same name in outer scopes.
  // See 15.5.5.2 for details.
  if (!symbol.owner().IsGlobal() && !symbol.owner().IsDerivedType()) {
    if (const Symbol *
        outer{symbol.owner().parent().FindSymbol(symbol.name())}) {
      auto result{ResolveGeneric(*outer, actuals, adjustActuals, isSubroutine,
          std::move(tried), mightBeStructureConstructor)};
      if (result.specific) {
        return result;
      }
      tried = std::move(result.tried);
    }
  }
  return {nullptr, false, std::move(tried)};
}

auto ExpressionAnalyzer::CheckAndResolveGenericReference(const Symbol &symbol,
    const ActualArguments &actuals, const AdjustActuals &adjustActuals,
    bool isSubroutine, SymbolVector &&tried, bool mightBeStructureConstructor)
    -> GenericResolution {
  const Symbol &ultimate{symbol.GetUltimate()};
  // Attr::INTRINSIC is set for specific intrinsic names such as DSIN as well,
  // and a reference to one of those is not a reference to a generic procedure.
  if ((ultimate.has<semantics::GenericDetails>() ||
          (ultimate.attrs().test(semantics::Attr::INTRINSIC) &&
              context_.intrinsics().IsGenericIntrinsic(
                  ultimate.name().ToString()))) &&
      semantics::CheckConditionalArgsInGenericReference(
          actuals, GetContextualMessages())) {
    // Not resolving also leaves the parse tree symbol generic, so a second
    // analysis of the expression reports the violation again.
    GenericResolution result;
    result.errorReported = true;
    return result;
  }
  return ResolveGeneric(symbol, actuals, adjustActuals, isSubroutine,
      std::move(tried), mightBeStructureConstructor);
}

const Symbol &ExpressionAnalyzer::AccessSpecific(
    const Symbol &originalGeneric, const Symbol &specific) {
  if (const auto *hosted{
          originalGeneric.detailsIf<semantics::HostAssocDetails>()}) {
    return AccessSpecific(hosted->symbol(), specific);
  } else if (const auto *used{
                 originalGeneric.detailsIf<semantics::UseDetails>()}) {
    const auto &scope{originalGeneric.owner()};
    if (auto iter{scope.find(specific.name())}; iter != scope.end()) {
      if (const auto *useDetails{
              iter->second->detailsIf<semantics::UseDetails>()}) {
        const Symbol &usedSymbol{useDetails->symbol()};
        const auto *usedGeneric{
            usedSymbol.detailsIf<semantics::GenericDetails>()};
        if (&usedSymbol == &specific ||
            (usedGeneric && usedGeneric->specific() == &specific)) {
          return specific;
        }
      }
    }
    // Create a renaming USE of the specific procedure.
    auto rename{context_.SaveTempName(
        used->symbol().owner().GetName().value().ToString() + "$" +
        specific.owner().GetName().value().ToString() + "$" +
        specific.name().ToString())};
    return *const_cast<semantics::Scope &>(scope)
                .try_emplace(rename, specific.attrs(),
                    semantics::UseDetails{rename, specific})
                .first->second;
  } else {
    return specific;
  }
}

void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol,
    bool dueToAmbiguity, bool isSubroutine, const ActualArguments &arguments,
    const SymbolVector &tried, const AdjustActuals &adjustment) {
  if (auto *msg{Say(dueToAmbiguity
              ? "The actual arguments to the generic procedure '%s' matched multiple specific procedures, perhaps due to use of NULL() without MOLD= or an actual procedure with an implicit interface"_err_en_US
              : semantics::IsGenericDefinedOp(symbol)
              ? "No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US
              : isSubroutine
              ? "No specific subroutine of generic '%s' matches the actual arguments"_err_en_US
              : "No specific function of generic '%s' matches the actual arguments"_err_en_US,
          symbol.name())}) {
    for (const Symbol &specific : tried) {
      if (auto procChars{characteristics::Procedure::Characterize(
              specific, GetFoldingContext())}) {
        if (procChars->HasExplicitInterface()) {
          ActualArguments adjusted{arguments};
          if (specific.has<semantics::ProcBindingDetails>() &&
              adjustment.has_value()) {
            (*adjustment)(specific, adjusted);
          }
          auto reasons{semantics::CheckExplicitInterface(*procChars, adjusted,
              context_, /*scope=*/nullptr, /*intrinsic=*/nullptr,
              /*allocActualArgumentConversions=*/false,
              /*extentErrors=*/false,
              /*ignoreImplicitVsExplicit=*/false)};
          if (reasons.AnyFatalError() != dueToAmbiguity) {
            if (dueToAmbiguity) {
              msg->Attach(specific.name(),
                  "Specific procedure '%s' matched the actual arguments"_en_US,
                  specific.name());
            } else {
              reasons.AttachTo(
                  msg->Attach(specific.name(),
                      "Specific procedure '%s' does not match the actual arguments because"_en_US,
                      specific.name()),
                  parser::Severity::None);
            }
          }
        }
      }
    }
  }
}

auto ExpressionAnalyzer::GetCalleeAndArguments(
    const parser::ProcedureDesignator &pd, ActualArguments &&arguments,
    bool isSubroutine, bool mightBeStructureConstructor)
    -> std::optional<CalleeAndArguments> {
  return common::visit(common::visitors{
                           [&](const parser::Name &name) {
                             return GetCalleeAndArguments(name,
                                 std::move(arguments), isSubroutine,
                                 mightBeStructureConstructor);
                           },
                           [&](const parser::ProcComponentRef &pcr) {
                             return AnalyzeProcedureComponentRef(
                                 pcr, std::move(arguments), isSubroutine);
                           },
                       },
      pd.u);
}

auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
    ActualArguments &&arguments, bool isSubroutine,
    bool mightBeStructureConstructor) -> std::optional<CalleeAndArguments> {
  const Symbol *symbol{name.symbol};
  if (context_.HasError(symbol)) {
    return std::nullopt; // also handles null symbol
  }
  symbol = ResolveForward(*symbol);
  if (!symbol) {
    return std::nullopt;
  }
  name.symbol = const_cast<Symbol *>(symbol);
  const Symbol &ultimate{symbol->GetUltimate()};
  CheckForBadRecursion(name.source, ultimate);
  bool dueToAmbiguity{false};
  bool isGenericInterface{ultimate.has<semantics::GenericDetails>()};
  bool isExplicitIntrinsic{ultimate.attrs().test(semantics::Attr::INTRINSIC)};
  const Symbol *resolution{nullptr};
  SymbolVector tried;
  if (isGenericInterface || isExplicitIntrinsic) {
    ExpressionAnalyzer::AdjustActuals noAdjustment;
    auto result{
        CheckAndResolveGenericReference(*symbol, arguments, noAdjustment,
            isSubroutine, SymbolVector{}, mightBeStructureConstructor)};
    if (result.errorReported) {
      return std::nullopt;
    }
    resolution = result.specific;
    dueToAmbiguity = result.failedDueToAmbiguity;
    tried = std::move(result.tried);
    if (IsCudaDeviceIntrinsicShadowedByHostProcedure(
            name.source, context_, resolution, isSubroutine)) {
      ActualArguments localArguments{arguments};
      if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(
              CallCharacteristics{name.source.ToString(), isSubroutine},
              localArguments, GetFoldingContext())}) {
        CheckBadExplicitType(*specificCall, *symbol);
        return CalleeAndArguments{
            ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
            std::move(specificCall->arguments)};
      }
    }
    if (resolution) {
      if (context_.GetPPCBuiltinsScope() &&
          resolution->name().ToString().rfind("__ppc_", 0) == 0) {
        // The PowerPC intrinsic checks and PowerPC lowering require constant
        // values for some arguments; now that the call is committed to this
        // resolution, fold any named-constant designators that were retained
        // for storage association.
        evaluate::FoldNamedConstantActualArguments(
            GetFoldingContext(), arguments);
        semantics::CheckPPCIntrinsic(
            *symbol, *resolution, arguments, GetFoldingContext());
      }
      // re-resolve name to the specific procedure
      name.symbol = const_cast<Symbol *>(resolution);
    }
  } else if (IsProcedure(ultimate) &&
      ultimate.attrs().test(semantics::Attr::ABSTRACT)) {
    Say("Abstract procedure interface '%s' may not be referenced"_err_en_US,
        name.source);
  } else {
    resolution = symbol;
  }
  if (resolution && context_.targetCharacteristics().isOSWindows()) {
    semantics::CheckWindowsIntrinsic(*resolution, GetFoldingContext());
  }
  if (!resolution || resolution->attrs().test(semantics::Attr::INTRINSIC)) {
    auto name{resolution ? resolution->name() : ultimate.name()};
    if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(
            CallCharacteristics{name.ToString(), isSubroutine}, arguments,
            GetFoldingContext())}) {
      CheckBadExplicitType(*specificCall, *symbol);
      return CalleeAndArguments{
          ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
          std::move(specificCall->arguments)};
    } else {
      if (isGenericInterface) {
        AdjustActuals noAdjustment;
        EmitGenericResolutionError(*symbol, dueToAmbiguity, isSubroutine,
            arguments, tried, noAdjustment);
      }
      return std::nullopt;
    }
  }
  if (resolution->GetUltimate().has<semantics::DerivedTypeDetails>()) {
    if (mightBeStructureConstructor) {
      return CalleeAndArguments{
          semantics::SymbolRef{*resolution}, std::move(arguments)};
    }
  } else if (IsProcedure(*resolution)) {
    ProcedureDesignator proc{*resolution};
    if (isGenericInterface) {
      proc.set_genericName(name.source);
    }
    return CalleeAndArguments{std::move(proc), std::move(arguments)};
  }
  if (!context_.HasError(*resolution)) {
    AttachDeclaration(
        Say(name.source, "'%s' is not a callable procedure"_err_en_US,
            name.source),
        *resolution);
  }
  return std::nullopt;
}

// Fortran 2018 expressly states (8.2 p3) that any declared type for a
// generic intrinsic function "has no effect" on the result type of a
// call to that intrinsic.  So one can declare "character*8 cos" and
// still get a real result from "cos(1.)".  This is a dangerous feature,
// especially since implementations are free to extend their sets of
// intrinsics, and in doing so might clash with a name in a program.
// So we emit a warning in this situation, and perhaps it should be an
// error -- any correctly working program can silence the message by
// simply deleting the pointless type declaration.
void ExpressionAnalyzer::CheckBadExplicitType(
    const SpecificCall &call, const Symbol &intrinsic) {
  if (intrinsic.GetUltimate().GetType()) {
    const auto &procedure{call.specificIntrinsic.characteristics.value()};
    if (const auto &result{procedure.functionResult}) {
      if (const auto *typeAndShape{result->GetTypeAndShape()}) {
        if (auto declared{
                typeAndShape->Characterize(intrinsic, GetFoldingContext())}) {
          if (!declared->type().IsTkCompatibleWith(typeAndShape->type())) {
            if (auto *msg{Warn(
                    common::UsageWarning::IgnoredIntrinsicFunctionType,
                    "The result type '%s' of the intrinsic function '%s' is not the explicit declared type '%s'"_warn_en_US,
                    typeAndShape->AsFortran(), intrinsic.name(),
                    declared->AsFortran())}) {
              msg->Attach(intrinsic.name(),
                  "Ignored declaration of intrinsic function '%s'"_en_US,
                  intrinsic.name());
            }
          }
        }
      }
    }
  }
}

void ExpressionAnalyzer::CheckForBadRecursion(
    parser::CharBlock callSite, const semantics::Symbol &proc) {
  if (const Symbol *mainEntry{GetMainEntry(&proc)}) {
    if (mainEntry != &proc) {
      CheckForBadRecursion(callSite, *mainEntry);
      return;
    }
  }
  if (const auto *scope{proc.scope()}) {
    if (scope->sourceRange().Contains(callSite)) {
      parser::Message *msg{nullptr};
      if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3)
        msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,
            callSite);
      } else if (IsAssumedLengthCharacter(proc) && IsExternal(proc)) {
        // TODO: Also catch assumed PDT type parameters
        msg = Say( // 15.6.2.1(3)
            "Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,
            callSite);
      } else if (FindCUDADeviceContext(scope)) {
        const auto *subp{
            proc.GetUltimate().detailsIf<semantics::SubprogramDetails>()};
        bool isGlobalCUDA{subp && subp->cudaSubprogramAttrs() &&
            *subp->cudaSubprogramAttrs() ==
                common::CUDASubprogramAttrs::Global};
        // CUDA global call diagnostics are handled by CUDA checks.
        if (!isGlobalCUDA) {
          msg = Say(
              "Device subprogram '%s' cannot call itself"_err_en_US, callSite);
        }
      }
      AttachDeclaration(msg, proc);
    }
  }
}

template <typename A> static const Symbol *AssumedTypeDummy(const A &x) {
  if (const auto *designator{
          std::get_if<common::Indirection<parser::Designator>>(&x.u)}) {
    if (const auto *dataRef{
            std::get_if<parser::DataRef>(&designator->value().u)}) {
      if (const auto *name{std::get_if<parser::Name>(&dataRef->u)}) {
        return AssumedTypeDummy(*name);
      }
    }
  }
  return nullptr;
}
template <>
const Symbol *AssumedTypeDummy<parser::Name>(const parser::Name &name) {
  if (const Symbol *symbol{name.symbol}) {
    if (const auto *type{symbol->GetType()}) {
      if (type->category() == semantics::DeclTypeSpec::TypeStar) {
        return symbol;
      }
    }
  }
  return nullptr;
}
template <typename A>
static const Symbol *AssumedTypePointerOrAllocatableDummy(const A &object) {
  // It is illegal for allocatable of pointer objects to be TYPE(*), but at that
  // point it is not guaranteed that it has been checked the object has
  // POINTER or ALLOCATABLE attribute, so do not assume nullptr can be directly
  // returned.
  return common::visit(
      common::visitors{
          [&](const parser::StructureComponent &x) {
            return AssumedTypeDummy(x.Component());
          },
          [&](const parser::Name &x) { return AssumedTypeDummy(x); },
      },
      object.u);
}
template <>
const Symbol *AssumedTypeDummy<parser::AllocateObject>(
    const parser::AllocateObject &x) {
  return AssumedTypePointerOrAllocatableDummy(x);
}
template <>
const Symbol *AssumedTypeDummy<parser::PointerObject>(
    const parser::PointerObject &x) {
  return AssumedTypePointerOrAllocatableDummy(x);
}

bool ExpressionAnalyzer::CheckIsValidForwardReference(
    const semantics::DerivedTypeSpec &dtSpec) {
  if (dtSpec.IsForwardReferenced()) {
    Say("Cannot construct value for derived type '%s' before it is defined"_err_en_US,
        dtSpec.name());
    return false;
  }
  return true;
}

std::optional<Chevrons> ExpressionAnalyzer::AnalyzeChevrons(
    const parser::CallStmt &call) {
  Chevrons result;
  auto checkLaunchArg{[&](const Expr<SomeType> &expr, const char *which) {
    if (auto dyType{expr.GetType()}) {
      if (dyType->category() == TypeCategory::Integer) {
        return true;
      }
      if (dyType->category() == TypeCategory::Derived &&
          !dyType->IsPolymorphic() &&
          IsBuiltinDerivedType(&dyType->GetDerivedTypeSpec(), "dim3")) {
        return true;
      }
    }
    Say("Kernel launch %s parameter must be either integer or TYPE(dim3)"_err_en_US,
        which);
    return false;
  }};
  if (const auto &chevrons{
          std::get<std::optional<parser::CallStmt::Chevrons>>(call.t)}) {
    auto &starOrExpr{std::get<0>(chevrons->t)};
    if (starOrExpr.v) {
      if (auto expr{Analyze(*starOrExpr.v)};
          expr && checkLaunchArg(*expr, "grid")) {
        result.emplace_back(*expr);
      } else {
        return std::nullopt;
      }
    } else {
      result.emplace_back(
          AsGenericExpr(evaluate::Constant<evaluate::CInteger>{-1}));
    }
    if (auto expr{Analyze(std::get<1>(chevrons->t))};
        expr && checkLaunchArg(*expr, "block")) {
      result.emplace_back(*expr);
    } else {
      return std::nullopt;
    }
    if (const auto &maybeExpr{std::get<2>(chevrons->t)}) {
      if (auto expr{Analyze(*maybeExpr)}) {
        result.emplace_back(*expr);
      } else {
        return std::nullopt;
      }
    }
    if (const auto &maybeExpr{std::get<3>(chevrons->t)}) {
      if (auto expr{Analyze(*maybeExpr)}) {
        result.emplace_back(*expr);
      } else {
        return std::nullopt;
      }
    }
  }
  return std::move(result);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::FunctionReference &funcRef,
    std::optional<parser::StructureConstructor> *structureConstructor) {
  const parser::Call &call{funcRef.v};
  auto restorer{GetContextualMessages().SetLocation(funcRef.source)};
  ArgumentAnalyzer analyzer{*this, funcRef.source, true /* isProcedureCall */};
  for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {
    analyzer.Analyze(arg, false /* not subroutine call */);
  }
  if (analyzer.fatalErrors()) {
    return std::nullopt;
  }
  bool mightBeStructureConstructor{structureConstructor != nullptr};
  if (std::optional<CalleeAndArguments> callee{GetCalleeAndArguments(
          std::get<parser::ProcedureDesignator>(call.t), analyzer.GetActuals(),
          false /* not subroutine */, mightBeStructureConstructor)}) {
    if (auto *proc{std::get_if<ProcedureDesignator>(&callee->u)}) {
      return MakeFunctionRef(
          funcRef.source, std::move(*proc), std::move(callee->arguments));
    }
    CHECK(std::holds_alternative<semantics::SymbolRef>(callee->u));
    const Symbol &symbol{*std::get<semantics::SymbolRef>(callee->u)};
    if (mightBeStructureConstructor) {
      // Structure constructor misparsed as function reference?
      const auto &designator{std::get<parser::ProcedureDesignator>(call.t)};
      if (const auto *name{std::get_if<parser::Name>(&designator.u)}) {
        semantics::Scope &scope{context_.FindScope(name->source)};
        semantics::DerivedTypeSpec dtSpec{name->source, symbol};
        if (!CheckIsValidForwardReference(dtSpec)) {
          return std::nullopt;
        }
        // Detect enumeration types and set the category accordingly.
        // Use the ultimate symbol so that a USE-associated enumeration type
        // (whose local symbol carries UseDetails) is recognized too.
        if (const auto *dtDetails{symbol.GetUltimate()
                    .detailsIf<semantics::DerivedTypeDetails>()}) {
          if (dtDetails->isEnumerationType()) {
            dtSpec.set_category(
                semantics::DerivedTypeSpec::Category::EnumerationType);
          }
        }
        const semantics::DeclTypeSpec &type{
            semantics::FindOrInstantiateDerivedType(scope, std::move(dtSpec))};
        auto &mutableRef{const_cast<parser::FunctionReference &>(funcRef)};
        *structureConstructor =
            mutableRef.ConvertToStructureConstructor(type.derivedTypeSpec());
        // Don't use saved typed expressions left over from argument
        // analysis; they might not be valid structure components
        // (e.g., a TYPE(*) argument)
        auto restorer{DoNotUseSavedTypedExprs()};
        return Analyze(structureConstructor->value());
      }
    }
    if (!context_.HasError(symbol)) {
      AttachDeclaration(
          Say("'%s' is called like a function but is not a procedure"_err_en_US,
              symbol.name()),
          symbol);
      context_.SetError(symbol);
    }
  }
  return std::nullopt;
}

static bool HasAlternateReturns(const evaluate::ActualArguments &args) {
  for (const auto &arg : args) {
    if (arg && arg->isAlternateReturn()) {
      return true;
    }
  }
  return false;
}

void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
  const auto &call{std::get<parser::Call>(callStmt.t)};
  auto restorer{GetContextualMessages().SetLocation(callStmt.source)};
  ArgumentAnalyzer analyzer{*this, callStmt.source, true /* isProcedureCall */};
  const auto &actualArgList{std::get<std::list<parser::ActualArgSpec>>(call.t)};
  for (const auto &arg : actualArgList) {
    analyzer.Analyze(arg, true /* is subroutine call */);
  }
  if (auto chevrons{AnalyzeChevrons(callStmt)};
      chevrons && !analyzer.fatalErrors()) {
    if (std::optional<CalleeAndArguments> callee{
            GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
                analyzer.GetActuals(), true /* subroutine */)}) {
      ProcedureDesignator *proc{std::get_if<ProcedureDesignator>(&callee->u)};
      CHECK(proc);
      bool isKernel{false};
      bool isBindC{false};
      if (const Symbol * procSym{proc->GetSymbol()}) {
        const Symbol &ultimate{procSym->GetUltimate()};
        isBindC = ultimate.attrs().test(semantics::Attr::BIND_C);
        if (const auto *subpDetails{
                ultimate.detailsIf<semantics::SubprogramDetails>()}) {
          if (auto attrs{subpDetails->cudaSubprogramAttrs()}) {
            isKernel = *attrs == common::CUDASubprogramAttrs::Global ||
                *attrs == common::CUDASubprogramAttrs::Grid_Global;
          }
          // Implicitly set the CUDA subprogram attributes to GLOBAL for bind(c)
          // subprograms that are not marked as kernel.
          if (!isKernel && isBindC && !chevrons->empty()) {
            const_cast<semantics::SubprogramDetails *>(subpDetails)
                ->set_cudaSubprogramAttrs(common::CUDASubprogramAttrs::Global);
          }
        } else if (const auto *procDetails{
                       ultimate.detailsIf<semantics::ProcEntityDetails>()}) {
          isKernel = procDetails->isCUDAKernel();
        }
        if (isKernel && chevrons->empty()) {
          Say("'%s' is a kernel subroutine and must be called with kernel launch parameters in chevrons"_err_en_US,
              procSym->name());
        }
      }
      if (!isKernel && !isBindC && !chevrons->empty()) {
        Say("Kernel launch parameters in chevrons may not be used unless calling a kernel subroutine"_err_en_US);
      }
      if (CheckCall(callStmt.source, *proc, callee->arguments)) {
        callStmt.typedCall.Reset(
            new ProcedureRef{std::move(*proc), std::move(callee->arguments),
                HasAlternateReturns(callee->arguments)},
            ProcedureRef::Deleter);
        DEREF(callStmt.typedCall.get()).set_chevrons(std::move(*chevrons));
        return;
      }
    }
    if (!context_.AnyFatalError()) {
      std::string buf;
      llvm::raw_string_ostream dump{buf};
      parser::DumpTree(dump, callStmt);
      Say("Internal error: Expression analysis failed on CALL statement: %s"_err_en_US,
          buf);
    }
  }
}

const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
  if (!x.typedAssignment) {
    ArgumentAnalyzer analyzer{*this};
    const auto &variable{std::get<parser::Variable>(x.t)};
    analyzer.Analyze(variable);
    const auto &rhsExpr{std::get<parser::Expr>(x.t)};
    analyzer.Analyze(rhsExpr);
    std::optional<Assignment> assignment;
    if (!analyzer.fatalErrors()) {
      auto restorer{GetContextualMessages().SetLocation(variable.GetSource())};
      std::optional<ProcedureRef> procRef{analyzer.TryDefinedAssignment()};
      if (!procRef) {
        analyzer.CheckForNullPointer(
            "in a non-pointer intrinsic assignment statement");
        analyzer.CheckForAssumedRank("in an assignment statement");
        const Expr<SomeType> &lhs{analyzer.GetExpr(0)};
        if (auto dyType{lhs.GetType()}) {
          if (dyType->IsPolymorphic()) { // 10.2.1.2p1(1)
            const Symbol *lastWhole0{UnwrapWholeSymbolOrComponentDataRef(lhs)};
            const Symbol *lastWhole{
                lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
            if (!lastWhole || !IsAllocatable(*lastWhole)) {
              Say("Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
            } else if (evaluate::IsCoarray(*lastWhole)) {
              Say("Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray"_err_en_US);
            } else if (context_.langOptions().NoReallocateLHS) {
              Warn(common::UsageWarning::IgnoredNoReallocateLHS,
                  "-fno-realloc-lhs is ignored for assignment to polymorphic allocatable"_warn_en_US);
            }
            const Expr<SomeType> &rhs{analyzer.GetExpr(1)};
            if (auto rhsType{rhs.GetType()}) {
              if (const auto *rhsDerived{GetDerivedTypeSpec(*rhsType)}) {
                if (rhsDerived->IsVectorType()) {
                  Say(rhsExpr.source,
                      "Vector type '%s' may not be used as the right-hand side of a polymorphic intrinsic assignment"_err_en_US,
                      rhsType->AsFortran());
                }
              }
            }
          }
          if (auto *derived{GetDerivedTypeSpec(*dyType)}) {
            if (auto iter{FindAllocatableUltimateComponent(*derived)}) {
              if (ExtractCoarrayRef(lhs)) {
                Say("Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
                    iter.BuildResultDesignatorName());
              }
            }
          }
        }
        CheckForWholeAssumedSizeArray(
            rhsExpr.source, UnwrapWholeSymbolDataRef(analyzer.GetExpr(1)));
      }
      assignment.emplace(analyzer.MoveExpr(0), analyzer.MoveExpr(1));
      if (procRef) {
        assignment->u = std::move(*procRef);
      }
    }
    x.typedAssignment.Reset(new GenericAssignmentWrapper{std::move(assignment)},
        GenericAssignmentWrapper::Deleter);
  }
  return common::GetPtrFromOptional(x.typedAssignment->v);
}

const Assignment *ExpressionAnalyzer::Analyze(
    const parser::PointerAssignmentStmt &x) {
  if (!x.typedAssignment) {
    MaybeExpr lhs{Analyze(std::get<parser::DataRef>(x.t))};
    MaybeExpr rhs;
    {
      auto restorer{AllowNullPointer()};
      rhs = Analyze(std::get<parser::Expr>(x.t));
    }
    if (!lhs || !rhs) {
      x.typedAssignment.Reset(
          new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter);
    } else {
      Assignment assignment{std::move(*lhs), std::move(*rhs)};
      common::visit(
          common::visitors{
              [&](const std::list<parser::BoundsRemapping> &list) {
                Assignment::BoundsRemapping bounds;
                for (const auto &elem : list) {
                  auto lower{AsSubscript(Analyze(std::get<0>(elem.t)))};
                  auto upper{AsSubscript(Analyze(std::get<1>(elem.t)))};
                  if (lower && upper) {
                    bounds.emplace_back(
                        Fold(std::move(*lower)), Fold(std::move(*upper)));
                  }
                }
                assignment.u = std::move(bounds);
              },
              [&](const std::list<parser::BoundsSpec> &list) {
                Assignment::BoundsSpec bounds;
                for (const auto &bound : list) {
                  if (auto lower{AsSubscript(Analyze(bound.v))}) {
                    bounds.emplace_back(Fold(std::move(*lower)));
                  }
                }
                assignment.u = std::move(bounds);
              },
          },
          std::get<parser::PointerAssignmentStmt::Bounds>(x.t).u);
      x.typedAssignment.Reset(
          new GenericAssignmentWrapper{std::move(assignment)},
          GenericAssignmentWrapper::Deleter);
    }
  }
  return common::GetPtrFromOptional(x.typedAssignment->v);
}

static bool IsExternalCalledImplicitly(
    parser::CharBlock callSite, const Symbol *symbol) {
  return symbol && symbol->owner().IsGlobal() &&
      symbol->has<semantics::SubprogramDetails>() &&
      (!symbol->scope() /*ENTRY*/ ||
          !symbol->scope()->sourceRange().Contains(callSite));
}

std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
    parser::CharBlock callSite, const ProcedureDesignator &proc,
    ActualArguments &arguments) {
  bool treatExternalAsImplicit{
      IsExternalCalledImplicitly(callSite, proc.GetSymbol())};
  const Symbol *procSymbol{proc.GetSymbol()};
  bool isStatementFunction{
      procSymbol && procSymbol->flags().test(Symbol::Flag::StmtFunction)};
  std::optional<characteristics::Procedure> chars;
  if (procSymbol && procSymbol->has<semantics::ProcEntityDetails>() &&
      procSymbol->owner().IsGlobal()) {
    // Unknown global external, implicit interface; assume
    // characteristics from the actual arguments, and check
    // for consistency with other references.
    chars = characteristics::Procedure::FromActuals(
        proc, arguments, context_.foldingContext());
    if (chars && procSymbol) {
      // Ensure calls over implicit interfaces are consistent
      auto name{procSymbol->name()};
      if (auto iter{implicitInterfaces_.find(name)};
          iter != implicitInterfaces_.end()) {
        std::string whyNot;
        if (!chars->IsCompatibleWith(iter->second.second,
                /*ignoreImplicitVsExplicit=*/false, &whyNot)) {
          if (auto *msg{Warn(
                  common::UsageWarning::IncompatibleImplicitInterfaces,
                  callSite,
                  "Reference to the procedure '%s' has an implicit interface that is distinct from another reference: %s"_warn_en_US,
                  name, whyNot)}) {
            msg->Attach(
                iter->second.first, "previous reference to '%s'"_en_US, name);
          }
        }
      } else {
        implicitInterfaces_.insert(
            std::make_pair(name, std::make_pair(callSite, *chars)));
      }
    }
  }
  if (!chars) {
    chars = characteristics::Procedure::Characterize(
        proc, context_.foldingContext(), /*emitError=*/true);
  }
  bool ok{true};
  if (chars) {
    std::string whyNot;
    if (treatExternalAsImplicit &&
        !chars->CanBeCalledViaImplicitInterface(&whyNot, /*checkCUDA=*/false)) {
      if (auto *msg{Say(callSite,
              "References to the procedure '%s' require an explicit interface"_err_en_US,
              DEREF(procSymbol).name())};
          msg && !whyNot.empty()) {
        msg->Attach(callSite, "%s"_because_en_US, whyNot);
      }
    }
    const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()};
    bool procIsDummy{procSymbol && IsDummy(*procSymbol)};
    if (chars->functionResult &&
        chars->functionResult->IsAssumedLengthCharacter() &&
        !specificIntrinsic && !procIsDummy) {
      Say(callSite,
          "Assumed-length character function must be defined with a length to be called"_err_en_US);
    }
    if (!chars->IsPure()) {
      if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(
              context_.FindScope(callSite))}) {
        std::string name;
        if (procSymbol) {
          name = "'"s + procSymbol->name().ToString() + "'";
        } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
          name = "'"s + intrinsic->name + "'";
        }
        Say(callSite,
            "Procedure %s referenced in pure subprogram '%s' must be pure too"_err_en_US,
            name, DEREF(pure->symbol()).name());
      }
    }
    if (isStatementFunction) {
      // Statement functions have implicit interfaces, so keyword actual
      // arguments are not allowed. They are exempt from the explicit-interface
      // requirements of F2023 15.4.2.2.
      parser::ContextualMessages &messages{
          context_.foldingContext().messages()};
      for (auto &arg : arguments) {
        if (arg) {
          semantics::CheckImplicitInterfaceArgKeywords(*arg, messages);
        }
      }
    }
    ok &= semantics::CheckArguments(*chars, arguments, context_,
        context_.FindScope(callSite), treatExternalAsImplicit,
        /*ignoreImplicitVsExplicit=*/false, specificIntrinsic);
  }
  if (ok && !treatExternalAsImplicit && procSymbol &&
      !(chars && chars->HasExplicitInterface())) {
    if (const Symbol *global{FindGlobal(*procSymbol)};
        global && global != procSymbol && IsProcedure(*global)) {
      // Check a known global definition behind a local interface
      if (auto globalChars{characteristics::Procedure::Characterize(
              *global, context_.foldingContext())}) {
        semantics::CheckArguments(*globalChars, arguments, context_,
            context_.FindScope(callSite), /*treatExternalAsImplicit=*/true,
            /*ignoreImplicitVsExplicit=*/false,
            nullptr /*not specific intrinsic*/);
      }
    }
  }
  return chars;
}

// Unary operations

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
  if (MaybeExpr operand{Analyze(x.v.value())}) {
    if (IsNullPointerOrAllocatable(&*operand)) {
      Say("NULL() may not be parenthesized"_err_en_US);
    } else if (semantics::IsAssumedRank(*operand)) {
      Say("An assumed-rank dummy argument may not be parenthesized"_err_en_US);
    } else if (const semantics::Symbol *symbol{GetLastSymbol(*operand)}) {
      if (const semantics::Symbol *result{FindFunctionResult(*symbol)}) {
        if (semantics::IsProcedurePointer(*result)) {
          Say("A function reference that returns a procedure pointer may not be parenthesized"_err_en_US); // C1003
        }
      }
    }
    return Parenthesize(std::move(*operand));
  }
  return std::nullopt;
}

static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
    NumericOperator opr, const parser::Expr::IntrinsicUnary &x) {
  ArgumentAnalyzer analyzer{context};
  analyzer.Analyze(x.v);
  if (!analyzer.fatalErrors()) {
    if (analyzer.IsIntrinsicNumeric(opr)) {
      analyzer.CheckForNullPointer();
      analyzer.CheckForAssumedRank();
      if (opr == NumericOperator::Add) {
        // +x -> (x), not a bare x, because the bounds of the argument must
        // not be exposed to allocatable assignments or structure constructor
        // components.
        return Parenthesize(analyzer.MoveExpr(0));
      } else {
        return Negation(context.GetContextualMessages(), analyzer.MoveExpr(0));
      }
    } else {
      return analyzer.TryDefinedOp(AsFortran(opr),
          "Operand of unary %s must be numeric; have %s"_err_en_US);
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {
  return NumericUnaryHelper(*this, NumericOperator::Add, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Negate &x) {
  if (const auto *litConst{
          std::get_if<parser::LiteralConstant>(&x.v.value().u)}) {
    if (const auto *intConst{
            std::get_if<parser::IntLiteralConstant>(&litConst->u)}) {
      return Analyze(*intConst, true);
    }
  }
  return NumericUnaryHelper(*this, NumericOperator::Subtract, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
  ArgumentAnalyzer analyzer{*this};
  analyzer.Analyze(x.v);
  if (!analyzer.fatalErrors()) {
    if (analyzer.IsIntrinsicLogical()) {
      analyzer.CheckForNullPointer();
      analyzer.CheckForAssumedRank();
      return AsGenericExpr(
          LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u)));
    } else {
      return analyzer.TryDefinedOp(LogicalOperator::Not,
          "Operand of %s must be LOGICAL; have %s"_err_en_US);
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
  // Represent %LOC() exactly as if it had been a call to the LOC() extension
  // intrinsic function.
  // Use the actual source for the name of the call for error reporting.
  std::optional<ActualArgument> arg;
  if (const Symbol *assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {
    arg = ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
  } else if (MaybeExpr argExpr{Analyze(x.v.value())}) {
    arg = ActualArgument{std::move(*argExpr)};
  } else {
    return std::nullopt;
  }
  parser::CharBlock at{GetContextualMessages().at()};
  CHECK(at.size() >= 4);
  parser::CharBlock loc{at.begin() + 1, 3};
  CHECK(loc == "loc");
  return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::ConditionalExpr &x) {
  // Chained else-expressions recurse automatically through Analyze(Expr).
  MaybeExpr condExpr{Analyze(std::get<0>(x.t))};
  MaybeExpr thenExpr{Analyze(std::get<1>(x.t).value())};
  MaybeExpr elseExpr{Analyze(std::get<2>(x.t).value())};
  if (!condExpr || !thenExpr || !elseExpr) {
    return std::nullopt;
  }
  if (std::holds_alternative<BOZLiteralConstant>(thenExpr->u) ||
      std::holds_alternative<BOZLiteralConstant>(elseExpr->u)) {
    Say("BOZ literal constant in conditional expression must have explicit "
        "type (e.g., INT(z'FF'), REAL(z'3F800000'))"_err_en_US);
    return std::nullopt;
  }
  if (IsNullPointerOrAllocatable(&*thenExpr) ||
      IsNullPointerOrAllocatable(&*elseExpr)) {
    Say("NULL() not allowed in a conditional expression"_err_en_US);
    return std::nullopt;
  }
  if (semantics::IsAssumedRank(*thenExpr) ||
      semantics::IsAssumedRank(*elseExpr)) {
    Say("An assumed-rank dummy argument may not be used as a value in a conditional expression"_err_en_US);
    return std::nullopt;
  }
  if ((ExtractDataRef(thenExpr) &&
          ExtractCoarrayRef(*ExtractDataRef(thenExpr))) ||
      (ExtractDataRef(elseExpr) &&
          ExtractCoarrayRef(*ExtractDataRef(elseExpr)))) {
    Say("Conditional expression values may not be coindexed"_err_en_US);
    return std::nullopt;
  }
  // F2023 C1004: then-expr and else-expr must have the same declared type,
  // kind type parameters, and rank.
  if (thenExpr->Rank() != elseExpr->Rank()) {
    Say("All values in conditional expression must have the same rank; have rank %d and %d"_err_en_US,
        thenExpr->Rank(), elseExpr->Rank());
    return std::nullopt;
  }
  const std::optional<DynamicType> thenType{thenExpr->GetType()};
  const std::optional<DynamicType> elseType{elseExpr->GetType()};
  if (!thenType || !elseType) {
    Say("Cannot determine type of conditional expression"_err_en_US);
    return std::nullopt;
  }
  const TypeCategory thenCat{thenType->category()};
  const TypeCategory elseCat{elseType->category()};
  if (thenCat != elseCat ||
      (thenCat != TypeCategory::Derived &&
          thenType->kind() != elseType->kind())) {
    Say("All values in conditional expression must have the same type and kind; have %s and %s"_err_en_US,
        thenType->AsFortran(), elseType->AsFortran());
    return std::nullopt;
  }
  if (thenCat == TypeCategory::Derived) {
    if (thenType->IsUnlimitedPolymorphic() ||
        elseType->IsUnlimitedPolymorphic()) {
      Say("Unlimited polymorphic types (CLASS(*)) not allowed in conditional expression"_err_en_US);
      return std::nullopt;
    }
    if (!AreSameDerivedType(
            thenType->GetDerivedTypeSpec(), elseType->GetDerivedTypeSpec())) {
      Say("All values in conditional expression must be the same derived type; have %s and %s"_err_en_US,
          thenType->AsFortran(), elseType->AsFortran());
      return std::nullopt;
    }
  }

  // Dispatch on the else-expr to recover the concrete kind type T.
  return common::visit(
      common::visitors{
          [&](Expr<SomeDerived> &&elseVal) -> MaybeExpr {
            Expr<LogicalResult> cond{ConvertToType<LogicalResult>(
                std::move(std::get<Expr<SomeLogical>>(condExpr->u)))};
            Expr<SomeDerived> thenVal{
                std::move(std::get<Expr<SomeDerived>>(thenExpr->u))};
            return AsGenericExpr(
                Expr<SomeDerived>{evaluate::ConditionalExpr<SomeDerived>{
                    std::move(cond), std::move(thenVal), std::move(elseVal)}});
          },
          [&](auto &&elseCatExpr) -> MaybeExpr {
            using CategoryType = std::decay_t<decltype(elseCatExpr)>;
            if constexpr (std::is_same_v<CategoryType, BOZLiteralConstant> ||
                std::is_same_v<CategoryType, NullPointer> ||
                std::is_same_v<CategoryType, ProcedureDesignator> ||
                std::is_same_v<CategoryType, ProcedureRef>) {
              DIE("Invalid expression type in conditional expression");
            } else {
              return common::visit(
                  [&](auto &&elseKindExpr) -> MaybeExpr {
                    using T =
                        typename std::decay_t<decltype(elseKindExpr)>::Result;
                    Expr<LogicalResult> cond{ConvertToType<LogicalResult>(
                        std::move(std::get<Expr<SomeLogical>>(condExpr->u)))};
                    Expr<T> thenVal{std::move(std::get<Expr<T>>(
                        std::get<CategoryType>(thenExpr->u).u))};
                    return AsGenericExpr(CategoryType{
                        Expr<T>{evaluate::ConditionalExpr<T>{std::move(cond),
                            std::move(thenVal), std::move(elseKindExpr)}}});
                  },
                  elseCatExpr.u);
            }
          },
      },
      std::move(elseExpr->u));
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {
  const auto &name{std::get<parser::DefinedOpName>(x.t).v};
  ArgumentAnalyzer analyzer{*this, name.source};
  analyzer.Analyze(std::get<1>(x.t));
  return analyzer.TryDefinedOp(name.source.ToString().c_str(),
      "No operator %s defined for %s"_err_en_US, /*isUserOp=*/true);
}

// Binary (dyadic) operations

template <template <typename> class OPR, NumericOperator opr>
MaybeExpr NumericBinaryHelper(
    ExpressionAnalyzer &context, const parser::Expr::IntrinsicBinary &x) {
  ArgumentAnalyzer analyzer{context};
  analyzer.Analyze(std::get<0>(x.t));
  analyzer.Analyze(std::get<1>(x.t));
  if (!analyzer.fatalErrors()) {
    if (analyzer.IsIntrinsicNumeric(opr)) {
      analyzer.CheckForNullPointer();
      analyzer.CheckForAssumedRank();
      analyzer.CheckConformance();
      return NumericOperation<OPR>(context.GetContextualMessages(),
          analyzer.MoveExpr(0), analyzer.MoveExpr(1),
          context.GetDefaultKind(TypeCategory::Real));
    } else {
      return analyzer.TryDefinedOp(AsFortran(opr),
          "Operands of %s must be numeric; have %s and %s"_err_en_US);
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Power &x) {
  return NumericBinaryHelper<Power, NumericOperator::Power>(*this, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Multiply &x) {
  return NumericBinaryHelper<Multiply, NumericOperator::Multiply>(*this, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Divide &x) {
  return NumericBinaryHelper<Divide, NumericOperator::Divide>(*this, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Add &x) {
  return NumericBinaryHelper<Add, NumericOperator::Add>(*this, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Subtract &x) {
  return NumericBinaryHelper<Subtract, NumericOperator::Subtract>(*this, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(
    const parser::Expr::ComplexConstructor &z) {
  Warn(common::LanguageFeature::ComplexConstructor,
      "nonstandard usage: generalized COMPLEX constructor"_port_en_US);
  return AnalyzeComplex(Analyze(std::get<0>(z.t).value()),
      Analyze(std::get<1>(z.t).value()), "complex constructor");
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {
  ArgumentAnalyzer analyzer{*this};
  analyzer.Analyze(std::get<0>(x.t));
  analyzer.Analyze(std::get<1>(x.t));
  if (!analyzer.fatalErrors()) {
    if (analyzer.IsIntrinsicConcat()) {
      analyzer.CheckForNullPointer();
      analyzer.CheckForAssumedRank();
      return common::visit(
          [&](auto &&x, auto &&y) -> MaybeExpr {
            using T = ResultType<decltype(x)>;
            if constexpr (std::is_same_v<T, ResultType<decltype(y)>>) {
              return AsGenericExpr(Concat<T::kind>{std::move(x), std::move(y)});
            } else {
              DIE("different types for intrinsic concat");
            }
          },
          std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(0).u).u),
          std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(1).u).u));
    } else {
      return analyzer.TryDefinedOp("//",
          "Operands of %s must be CHARACTER with the same kind; have %s and %s"_err_en_US);
    }
  }
  return std::nullopt;
}

// The Name represents a user-defined intrinsic operator.
// If the actuals match one of the specific procedures, return a function ref.
// Otherwise report the error in messages.
MaybeExpr ExpressionAnalyzer::AnalyzeDefinedOp(const parser::Name &name,
    ActualArguments &&actuals, const Symbol *&symbol) {
  if (auto callee{GetCalleeAndArguments(name, std::move(actuals))}) {
    auto &proc{std::get<evaluate::ProcedureDesignator>(callee->u)};
    symbol = proc.GetSymbol();
    return MakeFunctionRef(
        name.source, std::move(proc), std::move(callee->arguments));
  } else {
    return std::nullopt;
  }
}

MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
    const parser::Expr::IntrinsicBinary &x) {
  ArgumentAnalyzer analyzer{context};
  analyzer.Analyze(std::get<0>(x.t));
  analyzer.Analyze(std::get<1>(x.t));
  if (!analyzer.fatalErrors()) {
    std::optional<DynamicType> leftType{analyzer.GetType(0)};
    std::optional<DynamicType> rightType{analyzer.GetType(1)};
    analyzer.ConvertBOZOperand(&leftType, 0, rightType);
    analyzer.ConvertBOZOperand(&rightType, 1, leftType);
    if (leftType && rightType &&
        analyzer.IsIntrinsicRelational(opr, *leftType, *rightType)) {
      analyzer.CheckForNullPointer("as a relational operand");
      analyzer.CheckForAssumedRank("as a relational operand");
      if (auto cmp{Relate(context.GetContextualMessages(), opr,
              analyzer.MoveExpr(0), analyzer.MoveExpr(1))}) {
        return AsMaybeExpr(ConvertToKind<TypeCategory::Logical>(
            context.GetDefaultKind(TypeCategory::Logical),
            AsExpr(std::move(*cmp))));
      }
    } else {
      return analyzer.TryDefinedOp(opr,
          leftType && leftType->category() == TypeCategory::Logical &&
                  rightType && rightType->category() == TypeCategory::Logical
              ? "LOGICAL operands must be compared using .EQV. or .NEQV."_err_en_US
              : "Operands of %s must have comparable types; have %s and %s"_err_en_US);
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LT &x) {
  return RelationHelper(*this, RelationalOperator::LT, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LE &x) {
  return RelationHelper(*this, RelationalOperator::LE, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQ &x) {
  return RelationHelper(*this, RelationalOperator::EQ, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NE &x) {
  return RelationHelper(*this, RelationalOperator::NE, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GE &x) {
  return RelationHelper(*this, RelationalOperator::GE, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GT &x) {
  return RelationHelper(*this, RelationalOperator::GT, x);
}

MaybeExpr LogicalBinaryHelper(ExpressionAnalyzer &context, LogicalOperator opr,
    const parser::Expr::IntrinsicBinary &x) {
  ArgumentAnalyzer analyzer{context};
  analyzer.Analyze(std::get<0>(x.t));
  analyzer.Analyze(std::get<1>(x.t));
  if (!analyzer.fatalErrors()) {
    if (analyzer.IsIntrinsicLogical()) {
      analyzer.CheckForNullPointer("as a logical operand");
      analyzer.CheckForAssumedRank("as a logical operand");
      return AsGenericExpr(BinaryLogicalOperation(opr,
          std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u),
          std::get<Expr<SomeLogical>>(analyzer.MoveExpr(1).u)));
    } else {
      return analyzer.TryDefinedOp(
          opr, "Operands of %s must be LOGICAL; have %s and %s"_err_en_US);
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::AND &x) {
  return LogicalBinaryHelper(*this, LogicalOperator::And, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::OR &x) {
  return LogicalBinaryHelper(*this, LogicalOperator::Or, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQV &x) {
  return LogicalBinaryHelper(*this, LogicalOperator::Eqv, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NEQV &x) {
  return LogicalBinaryHelper(*this, LogicalOperator::Neqv, x);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {
  const auto &name{std::get<parser::DefinedOpName>(x.t).v};
  ArgumentAnalyzer analyzer{*this, name.source};
  analyzer.Analyze(std::get<1>(x.t));
  analyzer.Analyze(std::get<2>(x.t));
  return analyzer.TryDefinedOp(name.source.ToString().c_str(),
      "No operator %s defined for %s and %s"_err_en_US, true);
}

// Returns true if a parsed function reference should be converted
// into an array element reference.
static bool CheckFuncRefToArrayElement(semantics::SemanticsContext &context,
    const parser::FunctionReference &funcRef) {
  // Emit message if the function reference fix will end up an array element
  // reference with no subscripts, or subscripts on a scalar, because it will
  // not be possible to later distinguish in expressions between an empty
  // subscript list due to bad subscripts error recovery or because the
  // user did not put any.
  auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
  const auto *name{std::get_if<parser::Name>(&proc.u)};
  if (!name) {
    name = &parser::UnwrapRef<parser::StructureComponent>(
        std::get<parser::ProcComponentRef>(proc.u))
                .Component();
  }
  if (!name->symbol) {
    return false;
  } else if (name->symbol->Rank() == 0) {
    // The OpenMP special variables in DECLARE REDUCTION combiners and
    // initializers are data objects, so a parenthesized reference to one
    // of them can only be an (invalid) array element reference.
    if (name->symbol->test(Symbol::Flag::OmpInVar) ||
        name->symbol->test(Symbol::Flag::OmpOutVar) ||
        name->symbol->test(Symbol::Flag::OmpPrivVar) ||
        name->symbol->test(Symbol::Flag::OmpOrigVar)) {
      return true;
    }
    if (const Symbol *function{
            semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)}) {
      auto &msg{context.Say(funcRef.source,
          function->flags().test(Symbol::Flag::StmtFunction)
              ? "Recursive call to statement function '%s' is not allowed"_err_en_US
              : "Recursive call to '%s' requires a distinct RESULT in its declaration"_err_en_US,
          name->source)};
      AttachDeclaration(&msg, *function);
      name->symbol = const_cast<Symbol *>(function);
    }
    return false;
  } else {
    if (std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t).empty()) {
      auto &msg{context.Say(funcRef.source,
          "Reference to array '%s' with empty subscript list"_err_en_US,
          name->source)};
      if (name->symbol) {
        AttachDeclaration(&msg, *name->symbol);
      }
    }
    return true;
  }
}

// Converts, if appropriate, an original misparse of ambiguous syntax like
// A(1) as a function reference into an array reference.
// Misparsed structure constructors are detected elsewhere after generic
// function call resolution fails.
template <typename... A>
static void FixMisparsedFunctionReference(
    semantics::SemanticsContext &context, const std::variant<A...> &constU) {
  // The parse tree is updated in situ when resolving an ambiguous parse.
  using uType = std::decay_t<decltype(constU)>;
  auto &u{const_cast<uType &>(constU)};
  if (auto *func{
          std::get_if<common::Indirection<parser::FunctionReference>>(&u)}) {
    parser::FunctionReference &funcRef{func->value()};
    if (semantics::CheckMisparsedArrayElement(context, funcRef)) {
      if constexpr (common::HasMember<common::Indirection<parser::Designator>,
                        uType>) {
        u = common::Indirection{funcRef.ConvertToArrayElementRef()};
      } else {
        DIE("can't fix misparsed function as array reference");
      }
    }
  }
}

// Common handling of parse tree node types that retain the
// representation of the analyzed expression.
template <typename PARSED>
MaybeExpr ExpressionAnalyzer::ExprOrVariable(
    const PARSED &x, parser::CharBlock source) {
  auto restorer{GetContextualMessages().SetLocation(source)};
  if constexpr (std::is_same_v<PARSED, parser::Expr> ||
      std::is_same_v<PARSED, parser::Variable>) {
    FixMisparsedFunctionReference(context_, x.u);
  }
  // F2018 C710 (F2023 C715)
  if (AssumedTypeDummy(x) && !isAssumedTypeDummyOk_) {
    Say("TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
    ResetExpr(x);
    return std::nullopt;
  }
  MaybeExpr result;
  if constexpr (common::HasMember<parser::StructureConstructor,
                    std::decay_t<decltype(x.u)>> &&
      common::HasMember<common::Indirection<parser::FunctionReference>,
          std::decay_t<decltype(x.u)>>) {
    if (const auto *funcRef{
            std::get_if<common::Indirection<parser::FunctionReference>>(
                &x.u)}) {
      // Function references in Exprs might turn out to be misparsed structure
      // constructors; we have to try generic procedure resolution
      // first to be sure.
      std::optional<parser::StructureConstructor> ctor;
      result = Analyze(funcRef->value(), &ctor);
      if (ctor) {
        // A misparsed function reference is really a structure
        // constructor.  Repair the parse tree in situ.
        const_cast<PARSED &>(x).u = std::move(*ctor);
      }
    } else {
      result = Analyze(x.u);
    }
  } else {
    result = Analyze(x.u);
  }
  if (result) {
    if constexpr (std::is_same_v<PARSED, parser::Expr>) {
      if (!isNullPointerOk_ && IsNullPointerOrAllocatable(&*result)) {
        Say(source,
            "NULL() may not be used as an expression in this context"_err_en_US);
      }
    }
    SetExpr(x, Fold(std::move(*result)));
    return x.typedExpr->v;
  } else {
    ResetExpr(x);
    if (!context_.AnyFatalError()) {
      std::string buf;
      llvm::raw_string_ostream dump{buf};
      parser::DumpTree(dump, x);
      Say("Internal error: Expression analysis failed on: %s"_err_en_US, buf);
    }
    return std::nullopt;
  }
}

// This is an optional preliminary pass over parser::Expr subtrees.
// Given an expression tree, iteratively traverse it in a bottom-up order
// to analyze all of its subexpressions.  A later normal top-down analysis
// will then be able to use the results that will have been saved in the
// parse tree without having to recurse deeply.  This technique keeps
// absurdly deep expression parse trees from causing the analyzer to overflow
// its stack.
MaybeExpr ExpressionAnalyzer::IterativelyAnalyzeSubexpressions(
    const parser::Expr &top) {
  std::vector<const parser::Expr *> queue, finish;
  queue.push_back(&top);
  do {
    const parser::Expr &expr{*queue.back()};
    queue.pop_back();
    if (!expr.typedExpr) {
      const parser::Expr::IntrinsicUnary *unary{nullptr};
      const parser::Expr::IntrinsicBinary *binary{nullptr};
      common::visit(
          [&unary, &binary](auto &y) {
            if constexpr (std::is_convertible_v<decltype(&y),
                              decltype(unary)>) {
              // Don't evaluate a constant operand to Negate
              if (!std::holds_alternative<parser::LiteralConstant>(
                      y.v.value().u)) {
                unary = &y;
              }
            } else if constexpr (std::is_convertible_v<decltype(&y),
                                     decltype(binary)>) {
              binary = &y;
            }
          },
          expr.u);
      if (unary) {
        queue.push_back(&unary->v.value());
      } else if (binary) {
        queue.push_back(&std::get<0>(binary->t).value());
        queue.push_back(&std::get<1>(binary->t).value());
      }
      finish.push_back(&expr);
    }
  } while (!queue.empty());
  // Analyze the collected subexpressions in bottom-up order.
  // On an error, bail out and leave partial results in place.
  if (finish.size() == 1) {
    const parser::Expr &expr{DEREF(finish.front())};
    return ExprOrVariable(expr, expr.source);
  } else {
    // NULL() operand catching is deferred to operation analysis so
    // that they can be accepted by defined operators.
    auto restorer{AllowNullPointer()};
    MaybeExpr result;
    for (auto riter{finish.rbegin()}; riter != finish.rend(); ++riter) {
      const parser::Expr &expr{**riter};
      result = ExprOrVariable(expr, expr.source);
      if (!result) {
        return result;
      }
    }
    return result; // last value was from analysis of "top"
  }
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) {
  bool wasIterativelyAnalyzing{iterativelyAnalyzingSubexpressions_};
  MaybeExpr result;
  if (useSavedTypedExprs_) {
    if (expr.typedExpr) {
      // Returning a saved typed expression bypasses Analyze(Name), so walk the
      // original expression to perform its numeric_storage_size checks.
      NumericStorageSizeWarningVisitor visitor{context_};
      parser::Walk(expr, visitor);
      return expr.typedExpr->v;
    }
    if (!wasIterativelyAnalyzing) {
      iterativelyAnalyzingSubexpressions_ = true;
      result = IterativelyAnalyzeSubexpressions(expr);
    }
  }
  if (!result) {
    result = ExprOrVariable(expr, expr.source);
  }
  iterativelyAnalyzingSubexpressions_ = wasIterativelyAnalyzing;
  return result;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Variable &variable) {
  if (useSavedTypedExprs_ && variable.typedExpr) {
    return variable.typedExpr->v;
  }
  return ExprOrVariable(variable, variable.GetSource());
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Selector &selector) {
  if (const auto *var{std::get_if<parser::Variable>(&selector.u)}) {
    if (!useSavedTypedExprs_ || !var->typedExpr) {
      parser::CharBlock source{var->GetSource()};
      auto restorer{GetContextualMessages().SetLocation(source)};
      FixMisparsedFunctionReference(context_, var->u);
      if (const auto *funcRef{
              std::get_if<common::Indirection<parser::FunctionReference>>(
                  &var->u)}) {
        // A Selector that parsed as a Variable might turn out during analysis
        // to actually be a structure constructor.  In that case, repair the
        // Variable parse tree node into an Expr
        std::optional<parser::StructureConstructor> ctor;
        if (MaybeExpr result{Analyze(funcRef->value(), &ctor)}) {
          if (ctor) {
            auto &writable{const_cast<parser::Selector &>(selector)};
            writable.u = parser::Expr{std::move(*ctor)};
            auto &expr{std::get<parser::Expr>(writable.u)};
            expr.source = source;
            SetExpr(expr, Fold(std::move(*result)));
            return expr.typedExpr->v;
          } else {
            SetExpr(*var, Fold(std::move(*result)));
            return var->typedExpr->v;
          }
        } else {
          ResetExpr(*var);
          if (context_.AnyFatalError()) {
            return std::nullopt;
          }
        }
      }
    }
    // Not a Variable -> FunctionReference
    auto restorer{AllowWholeAssumedSizeArray()};
    return Analyze(selector.u);
  } else { // Expr
    return Analyze(selector.u);
  }
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtConstant &x) {
  auto restorer{common::ScopedSet(inDataStmtConstant_, true)};
  return ExprOrVariable(x, x.source);
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::AllocateObject &x) {
  return ExprOrVariable(x, parser::FindSourceLocation(x));
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::PointerObject &x) {
  return ExprOrVariable(x, parser::FindSourceLocation(x));
}

Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(
    TypeCategory category,
    const std::optional<parser::KindSelector> &selector) {
  int defaultKind{GetDefaultKind(category)};
  if (!selector) {
    return Expr<SubscriptInteger>{defaultKind};
  }
  return common::visit(
      common::visitors{
          [&](const parser::ScalarIntConstantExpr &x) {
            if (MaybeExpr kind{Analyze(x)}) {
              if (std::optional<std::int64_t> code{ToInt64(*kind)}) {
                if (CheckIntrinsicKind(category, *code)) {
                  return Expr<SubscriptInteger>{*code};
                }
              } else if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(*kind)}) {
                return ConvertToType<SubscriptInteger>(std::move(*intExpr));
              }
            }
            return Expr<SubscriptInteger>{defaultKind};
          },
          [&](const parser::KindSelector::StarSize &x) {
            std::intmax_t size = x.v;
            if (!CheckIntrinsicSize(category, size)) {
              size = defaultKind;
            } else if (category == TypeCategory::Complex) {
              size /= 2;
            }
            return Expr<SubscriptInteger>{size};
          },
      },
      selector->u);
}

int ExpressionAnalyzer::GetDefaultKind(common::TypeCategory category) {
  return context_.GetDefaultKind(category);
}

DynamicType ExpressionAnalyzer::GetDefaultKindOfType(
    common::TypeCategory category) {
  return {category, GetDefaultKind(category)};
}

bool ExpressionAnalyzer::CheckIntrinsicKind(
    TypeCategory category, std::int64_t kind) {
  if (foldingContext_.targetCharacteristics().IsTypeEnabled(
          category, kind)) { // C712, C714, C715, C727
    return true;
  } else if (foldingContext_.targetCharacteristics().CanSupportType(
                 category, kind)) {
    if (const semantics::Scope *modFileScope{
            semantics::FindModuleFileContaining(
                context_.FindScope(GetContextualMessages().at()))};
        modFileScope && modFileScope->parent().IsIntrinsicModules()) {
      // Ignore usage of unsupported intrinsic type kinds in intrinsic module
      // files.  They might be USE'd into a cross-compilation or into a
      // compilation with a disabled REAL kind.
    } else {
      Say("%s(KIND=%jd) is not an enabled type for this target"_err_en_US,
          ToUpperCase(EnumToString(category)), kind);
    }
    return true;
  } else {
    Say("%s(KIND=%jd) is not a supported type"_err_en_US,
        ToUpperCase(EnumToString(category)), kind);
    return false;
  }
}

bool ExpressionAnalyzer::CheckIntrinsicSize(
    TypeCategory category, std::int64_t size) {
  std::int64_t kind{size};
  if (category == TypeCategory::Complex) {
    // COMPLEX*16 == COMPLEX(KIND=8)
    if (size % 2 == 0) {
      kind = size / 2;
    } else {
      Say("COMPLEX*%jd is not a supported type"_err_en_US, size);
      return false;
    }
  }
  return CheckIntrinsicKind(category, kind);
}

bool ExpressionAnalyzer::AddImpliedDo(parser::CharBlock name, int kind) {
  return impliedDos_.insert(std::make_pair(name, kind)).second;
}

void ExpressionAnalyzer::RemoveImpliedDo(parser::CharBlock name) {
  auto iter{impliedDos_.find(name)};
  if (iter != impliedDos_.end()) {
    impliedDos_.erase(iter);
  }
}

std::optional<int> ExpressionAnalyzer::IsImpliedDo(
    parser::CharBlock name) const {
  auto iter{impliedDos_.find(name)};
  if (iter != impliedDos_.cend()) {
    return {iter->second};
  } else {
    return std::nullopt;
  }
}

bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
    const MaybeExpr &result, TypeCategory category, bool defaultKind) {
  if (result) {
    if (auto type{result->GetType()}) {
      if (type->category() != category) { // C885
        Say(at, "Must have %s type, but is %s"_err_en_US,
            ToUpperCase(EnumToString(category)),
            ToUpperCase(type->AsFortran()));
        return false;
      } else if (defaultKind) {
        int kind{context_.GetDefaultKind(category)};
        if (type->kind() != kind) {
          Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US,
              kind, ToUpperCase(EnumToString(category)),
              ToUpperCase(type->AsFortran()));
          return false;
        }
      }
    } else {
      Say(at, "Must have %s type, but is typeless"_err_en_US,
          ToUpperCase(EnumToString(category)));
      return false;
    }
  }
  return true;
}

MaybeExpr ExpressionAnalyzer::MakeFunctionRef(parser::CharBlock callSite,
    ProcedureDesignator &&proc, ActualArguments &&arguments) {
  if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc.u)}) {
    if (intrinsic->characteristics.value().attrs.test(
            characteristics::Procedure::Attr::NullPointer) &&
        arguments.empty()) {
      return Expr<SomeType>{NullPointer{}};
    }
  }
  if (const Symbol *symbol{proc.GetSymbol()}) {
    if (!ResolveForward(*symbol)) {
      return std::nullopt;
    }
  }
  if (auto chars{CheckCall(callSite, proc, arguments)}) {
    if (chars->functionResult) {
      const auto &result{*chars->functionResult};
      ProcedureRef procRef{std::move(proc), std::move(arguments)};
      if (result.IsProcedurePointer()) {
        return Expr<SomeType>{std::move(procRef)};
      } else {
        // Not a procedure pointer, so type and shape are known.
        return TypedWrapper<FunctionRef, ProcedureRef>(
            DEREF(result.GetTypeAndShape()).type(), std::move(procRef));
      }
    } else {
      Say("Function result characteristics are not known"_err_en_US);
    }
  }
  return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
    parser::CharBlock intrinsic, ActualArguments &&arguments) {
  if (std::optional<SpecificCall> specificCall{
          context_.intrinsics().Probe(CallCharacteristics{intrinsic.ToString()},
              arguments, GetFoldingContext())}) {
    return MakeFunctionRef(intrinsic,
        ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
        std::move(specificCall->arguments));
  } else {
    return std::nullopt;
  }
}

MaybeExpr ExpressionAnalyzer::AnalyzeComplex(
    MaybeExpr &&re, MaybeExpr &&im, const char *what) {
  if (re && re->Rank() > 0) {
    Warn(common::LanguageFeature::ComplexConstructor,
        "Real part of %s is not scalar"_port_en_US, what);
  }
  if (im && im->Rank() > 0) {
    Warn(common::LanguageFeature::ComplexConstructor,
        "Imaginary part of %s is not scalar"_port_en_US, what);
  }
  if (re && im) {
    ConformabilityCheck(GetContextualMessages(), *re, *im);
  }
  return AsMaybeExpr(ConstructComplex(GetContextualMessages(), std::move(re),
      std::move(im), GetDefaultKind(TypeCategory::Real)));
}

std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeVariable(
    const parser::Variable &x) {
  source_.ExtendToCover(x.GetSource());
  if (MaybeExpr expr{context_.Analyze(x)}) {
    if (!IsConstantExpr(*expr)) {
      ActualArgument actual{std::move(*expr)};
      SetArgSourceLocation(actual, x.GetSource());
      return actual;
    }
    const Symbol *symbol{GetLastSymbol(*expr)};
    if (!symbol) {
      context_.SayAt(x, "Assignment to constant '%s' is not allowed"_err_en_US,
          x.GetSource());
    } else if (IsProcedure(*symbol)) {
      if (auto *msg{context_.SayAt(x,
              "Assignment to procedure '%s' is not allowed"_err_en_US,
              symbol->name())}) {
        if (auto *subp{symbol->detailsIf<semantics::SubprogramDetails>()}) {
          if (subp->isFunction()) {
            const auto &result{subp->result().name()};
            msg->Attach(result, "Function result is '%s'"_en_US, result);
          }
        }
      }
    } else {
      context_.SayAt(
          x, "Assignment to '%s' is not allowed"_err_en_US, symbol->name());
    }
  }
  fatalErrors_ = true;
  return std::nullopt;
}

void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
  if (auto actual = AnalyzeVariable(x)) {
    actuals_.emplace_back(std::move(actual));
  }
}

void ArgumentAnalyzer::Analyze(
    const parser::ActualArgSpec &arg, bool isSubroutine) {
  // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
  std::optional<ActualArgument> actual;
  auto restorer{context_.AllowWholeAssumedSizeArray()};
  common::visit(
      common::visitors{
          [&](const common::Indirection<parser::Expr> &x) {
            actual = AnalyzeExpr(x.value());
          },
          [&](const parser::AltReturnSpec &label) {
            if (!isSubroutine) {
              context_.Say(
                  "alternate return specification may not appear on function reference"_err_en_US);
            }
            actual = ActualArgument(label.v);
          },
          [&](const parser::ActualArg::PercentRef &percentRef) {
            actual = AnalyzeExpr(percentRef.v);
            if (actual.has_value()) {
              actual->set_isPercentRef();
            }
          },
          [&](const parser::ActualArg::PercentVal &percentVal) {
            actual = AnalyzeExpr(percentVal.v);
            if (actual.has_value()) {
              actual->set_isPercentVal();
            }
          },
          [&](const parser::ConditionalArg &condArg) {
            // F2023 R1526 conditional-arg analysis (recursive)
            using EvalConsequent = ActualArgument::ConditionalArg::Consequent;
            using EvalConditionalArg = ActualArgument::ConditionalArg;
            using EvalTail =
                ActualArgument::ConditionalArg::ConditionalArgPartOrConsequent;

            // Analyze a single parser::Consequent into an evaluate Consequent
            auto analyzeConsequent{[&](const parser::ConditionalArg::Consequent
                                           &consequent) -> EvalConsequent {
              EvalConsequent result;
              common::visit(
                  common::visitors{
                      [&](const common::Indirection<parser::Expr> &expr) {
                        // F2023 15.5.2.3-2: a consequent-arg is an actual
                        // argument, so a bare TYPE(*) assumed-type dummy is
                        // permitted as the whole consequent (F2018 C710 /
                        // F2023 C715 waived).  The waiver applies only to the
                        // consequent expression itself; an assumed-type entity
                        // nested in a larger expression (e.g. (a) or a + 1)
                        // remains illegal, so the allowance is not extended to
                        // sub-expressions.
                        auto restorer{context_.AllowAssumedTypeDummy(
                            AssumedTypeDummy(expr.value()) != nullptr)};
                        if (MaybeExpr valExpr{context_.Analyze(expr.value())}) {
                          if (!valExpr->GetType()) {
                            context_.Say(
                                "Typeless expression is not allowed as a consequent in a conditional argument"_err_en_US);
                            fatalErrors_ = true;
                          } else {
                            result =
                                common::CopyableIndirection<Expr<SomeType>>{
                                    std::move(*valExpr)};
                          }
                        } else {
                          fatalErrors_ = true;
                        }
                      },
                      [&](const parser::ConditionalArgNil &) {
                        // .NIL. -> std::nullopt (the default)
                      },
                  },
                  consequent.u);
              return result;
            }};

            // Recursively analyze a parser::ConditionalArg into an evaluate
            // ConditionalArg
            auto analyzeCondArg{[&](const parser::ConditionalArg &ca,
                                    auto &self)
                                    -> std::optional<EvalConditionalArg> {
              // Analyze the condition — passing ScalarLogicalExpr directly
              // enforces both scalar (rank-0) and logical type constraints
              // via the Analyze(Scalar<A>) and Analyze(Logical<A>) templates.
              const auto &condition{std::get<parser::ScalarLogicalExpr>(ca.t)};
              MaybeExpr conditionExpr{context_.Analyze(condition)};
              if (!conditionExpr) {
                fatalErrors_ = true;
                return std::nullopt;
              }
              auto &conditionValue{
                  std::get<Expr<SomeLogical>>(conditionExpr->u)};

              // Analyze the consequent
              EvalConsequent consequent{analyzeConsequent(
                  std::get<parser::ConditionalArg::Consequent>(ca.t))};
              if (fatalErrors_) {
                return std::nullopt;
              }

              // Analyze the tail (recursive)
              const auto &tailNode{
                  std::get<common::Indirection<parser::ConditionalArgTail>>(
                      ca.t)
                      .value()};
              EvalTail tail{EvalConsequent{}}; // default: terminal NIL
              common::visit(
                  common::visitors{
                      [&](const parser::ConditionalArg &innerCA) {
                        auto innerResult{self(innerCA, self)};
                        if (innerResult) {
                          tail =
                              common::CopyableIndirection<EvalConditionalArg>{
                                  std::move(*innerResult)};
                        } else {
                          fatalErrors_ = true;
                        }
                      },
                      [&](const parser::ConditionalArg::Consequent &cons) {
                        tail = analyzeConsequent(cons);
                      },
                  },
                  tailNode.u);
              if (fatalErrors_) {
                return std::nullopt;
              }

              return EvalConditionalArg{std::move(conditionValue),
                  std::move(consequent), std::move(tail)};
            }};

            auto result{analyzeCondArg(condArg, analyzeCondArg)};
            if (!result) {
              return;
            }

            // C1540: At least one consequent shall be a consequent-arg
            if (!result->FirstNonNilConsequent()) {
              context_.Say(
                  "At least one consequent in a conditional argument must not be .NIL."_err_en_US);
              fatalErrors_ = true;
              return;
            }

            // C1538: same type and kind; C1539: same rank or assumed-rank
            if (!CheckConsequentTypesAndRanks(*result)) {
              fatalErrors_ = true;
              return;
            }

            actual = ActualArgument{std::move(*result)};
          },
      },
      std::get<parser::ActualArg>(arg.t).u);
  if (actual) {
    if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {
      actual->set_keyword(argKW->v.source);
    }
    actuals_.emplace_back(std::move(*actual));
  } else {
    fatalErrors_ = true;
  }
}

// C1538: Each consequent-arg shall have the same declared type and kind
// C1539: Each consequent-arg shall have the same rank or be assumed-rank
bool ArgumentAnalyzer::CheckConsequentTypesAndRanks(
    const ActualArgument::ConditionalArg &condArg) {
  const Expr<SomeType> *refExpr{condArg.FirstNonNilConsequent()};
  if (!refExpr) {
    return true; // all .NIL.; caller checks separately
  }
  auto refType{refExpr->GetType()};
  // A non-.NIL. consequent always has a type: typeless consequents are
  // rejected during analysis (analyzeConsequent), which aborts before this
  // check runs, so refType is never null here.
  CHECK(refType);
  int refRank{-1};
  bool allSameRank{true};
  bool hasAssumedRank{false};
  bool hasNonAssumedRank{false};

  // Check a single consequent against the reference type and rank
  auto checkOne{[&](const ActualArgument::ConditionalArg::Consequent &cons)
                    -> bool {
    if (!cons) {
      return true; // .NIL. is ok
    }
    auto thisType{cons->value().GetType()};
    // As with refType above, a non-.NIL. consequent always has a type.
    CHECK(thisType);
    if (refType->category() != thisType->category() ||
        (refType->category() != TypeCategory::Derived &&
            refType->kind() != thisType->kind())) {
      context_.Say(
          "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
          refType->AsFortran(), thisType->AsFortran());
      return false;
    }
    if (refType->category() == TypeCategory::Derived) {
      // C1538: same declared type required.  Unlimited polymorphic
      // (CLASS(*)) and assumed type (TYPE(*)) have no declared type,
      // so mixing them with other types is invalid.
      if (refType->IsUnlimitedPolymorphic() !=
          thisType->IsUnlimitedPolymorphic()) {
        context_.Say(
            "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
            refType->AsFortran(), thisType->AsFortran());
        return false;
      }
      if (refType->IsAssumedType() != thisType->IsAssumedType()) {
        context_.Say(
            "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
            refType->AsFortran(), thisType->AsFortran());
        return false;
      }
      // AssumedType (TYPE(*)) implies IsUnlimitedPolymorphic, so checking
      // !IsUnlimitedPolymorphic() alone excludes both CLASS(*) and TYPE(*).
      if (!refType->IsUnlimitedPolymorphic()) {
        const auto &resSpec{refType->GetDerivedTypeSpec()};
        const auto &thisSpec{thisType->GetDerivedTypeSpec()};
        // C1538: same declared type and kind type parameters.  Length type
        // parameters may differ.  AreSameDerivedTypeIgnoringLengthParameters
        // resolves symbol aliases (GetUltimate) and honors the structure
        // equivalence of separately-declared SEQUENCE/BIND(C) types
        // (F2023 7.5.2.4).
        if (!evaluate::AreSameDerivedTypeIgnoringLengthParameters(
                resSpec, thisSpec)) {
          context_.Say(
              "All consequent-args in a conditional argument must be the same derived type; have %s and %s"_err_en_US,
              refType->AsFortran(), thisType->AsFortran());
          return false;
        }
      }
    }
    if (semantics::IsAssumedRank(cons->value())) {
      hasAssumedRank = true;
    } else {
      hasNonAssumedRank = true;
      int thisRank{cons->value().Rank()};
      if (refRank < 0) {
        refRank = thisRank;
      } else if (thisRank != refRank) {
        allSameRank = false;
      }
    }
    return true;
  }};

  // Recursively check all consequents in the tree
  auto checkAll{
      [&](const ActualArgument::ConditionalArg &ca, auto &self) -> bool {
        if (!checkOne(ca.consequent())) {
          return false;
        }
        return ca.VisitTail(
            [&](const ActualArgument::ConditionalArg &inner) {
              return self(inner, self);
            },
            [&](const ActualArgument::ConditionalArg::Consequent &cons) {
              return checkOne(cons);
            });
      }};

  if (!checkAll(condArg, checkAll)) {
    return false;
  }

  // C1539: final rank consistency check
  if (hasAssumedRank && hasNonAssumedRank) {
    context_.Say(
        "All consequent-args in a conditional argument must have the same rank or all must be assumed-rank"_err_en_US);
    return false;
  }
  if (hasNonAssumedRank && !allSameRank) {
    context_.Say(
        "All consequent-args in a conditional argument must have the same rank"_err_en_US);
    return false;
  }
  return true;
}

bool ArgumentAnalyzer::IsIntrinsicRelational(RelationalOperator opr,
    const DynamicType &leftType, const DynamicType &rightType) const {
  CHECK(actuals_.size() == 2);
  return !(context_.context().languageFeatures().IsEnabled(
               common::LanguageFeature::CUDA) &&
             HasDeviceDefinedIntrinsicOpOverride(opr)) &&
      semantics::IsIntrinsicRelational(
          opr, leftType, GetRank(0), rightType, GetRank(1));
}

bool ArgumentAnalyzer::IsIntrinsicNumeric(NumericOperator opr) const {
  std::optional<DynamicType> leftType{GetType(0)};
  if (context_.context().languageFeatures().IsEnabled(
          common::LanguageFeature::CUDA) &&
      HasDeviceDefinedIntrinsicOpOverride(AsFortran(opr))) {
    return false;
  } else if (actuals_.size() == 1) {
    if (IsBOZLiteral(0)) {
      return opr == NumericOperator::Add; // unary '+'
    } else {
      return leftType && semantics::IsIntrinsicNumeric(*leftType);
    }
  } else {
    std::optional<DynamicType> rightType{GetType(1)};
    if (IsBOZLiteral(0) && rightType) { // BOZ opr Integer/Unsigned/Real
      auto cat1{rightType->category()};
      return cat1 == TypeCategory::Integer || cat1 == TypeCategory::Unsigned ||
          cat1 == TypeCategory::Real;
    } else if (IsBOZLiteral(1) && leftType) { // Integer/Unsigned/Real opr BOZ
      auto cat0{leftType->category()};
      return cat0 == TypeCategory::Integer || cat0 == TypeCategory::Unsigned ||
          cat0 == TypeCategory::Real;
    } else {
      return leftType && rightType &&
          semantics::IsIntrinsicNumeric(
              *leftType, GetRank(0), *rightType, GetRank(1));
    }
  }
}

bool ArgumentAnalyzer::IsIntrinsicLogical() const {
  if (std::optional<DynamicType> leftType{GetType(0)}) {
    if (actuals_.size() == 1) {
      return semantics::IsIntrinsicLogical(*leftType);
    } else if (std::optional<DynamicType> rightType{GetType(1)}) {
      return semantics::IsIntrinsicLogical(
          *leftType, GetRank(0), *rightType, GetRank(1));
    }
  }
  return false;
}

bool ArgumentAnalyzer::IsIntrinsicConcat() const {
  if (std::optional<DynamicType> leftType{GetType(0)}) {
    if (std::optional<DynamicType> rightType{GetType(1)}) {
      return semantics::IsIntrinsicConcat(
          *leftType, GetRank(0), *rightType, GetRank(1));
    }
  }
  return false;
}

bool ArgumentAnalyzer::CheckConformance() {
  if (actuals_.size() == 2) {
    const auto *lhs{actuals_.at(0).value().UnwrapExpr()};
    const auto *rhs{actuals_.at(1).value().UnwrapExpr()};
    if (lhs && rhs) {
      auto &foldingContext{context_.GetFoldingContext()};
      auto lhShape{GetShape(foldingContext, *lhs)};
      auto rhShape{GetShape(foldingContext, *rhs)};
      if (lhShape && rhShape) {
        if (!evaluate::CheckConformance(foldingContext.messages(), *lhShape,
                *rhShape, CheckConformanceFlags::EitherScalarExpandable,
                "left operand", "right operand")
                 .value_or(false /*fail when conformance is not known now*/)) {
          fatalErrors_ = true;
          return false;
        }
      }
    }
  }
  return true; // no proven problem
}

bool ArgumentAnalyzer::CheckAssignmentConformance() {
  if (actuals_.size() == 2 && actuals_[0] && actuals_[1]) {
    const auto *lhs{actuals_[0]->UnwrapExpr()};
    const auto *rhs{actuals_[1]->UnwrapExpr()};
    if (lhs && rhs) {
      auto &foldingContext{context_.GetFoldingContext()};
      auto lhShape{GetShape(foldingContext, *lhs)};
      auto rhShape{GetShape(foldingContext, *rhs)};
      if (lhShape && rhShape) {
        if (!evaluate::CheckConformance(foldingContext.messages(), *lhShape,
                *rhShape, CheckConformanceFlags::RightScalarExpandable,
                "left-hand side", "right-hand side")
                 .value_or(true /*ok when conformance is not known now*/)) {
          fatalErrors_ = true;
          return false;
        }
      }
    }
  }
  return true; // no proven problem
}

bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {
  for (const std::optional<ActualArgument> &arg : actuals_) {
    if (arg && IsNullPointerOrAllocatable(arg->UnwrapExpr())) {
      context_.Say(
          source_, "A NULL() pointer is not allowed %s"_err_en_US, where);
      fatalErrors_ = true;
      return false;
    }
  }
  return true;
}

bool ArgumentAnalyzer::CheckForAssumedRank(const char *where) {
  for (const std::optional<ActualArgument> &arg : actuals_) {
    if (arg && semantics::IsAssumedRank(arg->UnwrapExpr())) {
      context_.Say(source_,
          "An assumed-rank dummy argument is not allowed %s"_err_en_US, where);
      fatalErrors_ = true;
      return false;
    }
  }
  return true;
}

bool ArgumentAnalyzer::AnyCUDADeviceData() const {
  for (const std::optional<ActualArgument> &arg : actuals_) {
    if (arg) {
      if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
        if (HasCUDADeviceAttrs(*expr)) {
          return true;
        }
      }
    }
  }
  return false;
}

// Some operations can be defined with explicit non-type-bound interfaces
// that would erroneously conflict with intrinsic operations in their
// types and ranks but have one or more dummy arguments with the DEVICE
// attribute.
bool ArgumentAnalyzer::HasDeviceDefinedIntrinsicOpOverride(
    const char *opr) const {
  if (AnyCUDADeviceData() && !AnyUntypedOperand() && !AnyMissingOperand()) {
    std::string oprNameString{"operator("s + opr + ')'};
    parser::CharBlock oprName{oprNameString};
    parser::Messages buffer;
    auto restorer{context_.GetContextualMessages().SetMessages(buffer)};
    const auto &scope{context_.context().FindScope(source_)};
    if (Symbol * generic{scope.FindSymbol(oprName)}) {
      parser::Name name{generic->name(), generic};
      const Symbol *resultSymbol{nullptr};
      if (context_.AnalyzeDefinedOp(
              name, ActualArguments{actuals_}, resultSymbol)) {
        return true;
      }
    }
  }
  return false;
}

bool ArgumentAnalyzer::HasDeviceDefinedIntrinsicOpOverride(
    const std::vector<const char *> &oprNames) const {
  for (const char *opr : oprNames) {
    if (HasDeviceDefinedIntrinsicOpOverride(opr)) {
      return true;
    }
  }
  return false;
}

MaybeExpr ArgumentAnalyzer::TryDefinedOp(const char *opr,
    parser::MessageFixedText error, bool isUserOp, bool checkForNullPointer) {
  if (AnyMissingOperand()) {
    context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
    return std::nullopt;
  }
  MaybeExpr result;
  bool anyPossibilities{false};
  std::optional<parser::MessageFormattedText> inaccessible;
  std::vector<const Symbol *> hit;
  std::string oprNameString{
      isUserOp ? std::string{opr} : "operator("s + opr + ')'};
  parser::CharBlock oprName{oprNameString};
  parser::Messages hitBuffer;
  {
    parser::Messages buffer;
    auto restorer{context_.GetContextualMessages().SetMessages(buffer)};
    const auto &scope{context_.context().FindScope(source_)};

    auto FoundOne{[&](MaybeExpr &&thisResult, const Symbol &generic,
                      const Symbol *resolution) {
      anyPossibilities = true;
      if (thisResult) {
        if (auto thisInaccessible{CheckAccessibleSymbol(scope, generic)}) {
          inaccessible = thisInaccessible;
        } else {
          bool isElemental{IsElementalProcedure(DEREF(resolution))};
          bool hitsAreNonElemental{
              !hit.empty() && !IsElementalProcedure(DEREF(hit[0]))};
          if (isElemental && hitsAreNonElemental) {
            // ignore elemental resolutions in favor of a non-elemental one
          } else {
            if (!isElemental && !hitsAreNonElemental) {
              hit.clear();
            }
            result = std::move(thisResult);
            hit.push_back(resolution);
            hitBuffer = std::move(buffer);
          }
        }
      }
    }};

    if (Symbol * generic{scope.FindSymbol(oprName)}; generic && !fatalErrors_) {
      parser::Name name{generic->name(), generic};
      const Symbol *resultSymbol{nullptr};
      MaybeExpr possibleResult{context_.AnalyzeDefinedOp(
          name, ActualArguments{actuals_}, resultSymbol)};
      FoundOne(std::move(possibleResult), *generic, resultSymbol);
    }
    for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
      buffer.clear();
      const Symbol *generic{nullptr};
      if (const Symbol *
          binding{FindBoundOp(
              oprName, passIndex, generic, /*isSubroutine=*/false)}) {
        FoundOne(TryBoundOp(*binding, passIndex), DEREF(generic), binding);
      }
    }
  }
  if (result) {
    if (hit.size() > 1) {
      if (auto *msg{context_.Say(
              "%zd matching accessible generic interfaces for %s were found"_err_en_US,
              hit.size(), ToUpperCase(opr))}) {
        for (const Symbol *symbol : hit) {
          AttachDeclaration(*msg, *symbol);
        }
      }
    }
    if (auto *msgs{context_.GetContextualMessages().messages()}) {
      msgs->Annex(std::move(hitBuffer));
    }
  } else if (inaccessible) {
    context_.Say(source_, std::move(*inaccessible));
  } else if (anyPossibilities) {
    SayNoMatch(ToUpperCase(oprNameString), false);
  } else if (actuals_.size() == 2 && !AreConformable()) {
    context_.Say(
        "Operands of %s are not conformable; have rank %d and rank %d"_err_en_US,
        ToUpperCase(opr), actuals_[0]->Rank(), actuals_[1]->Rank());
  } else if (!CheckForAssumedRank()) {
  } else if (checkForNullPointer && !CheckForNullPointer()) {
  } else { // use the supplied error
    context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
  }
  return result;
}

MaybeExpr ArgumentAnalyzer::TryDefinedOp(
    const std::vector<const char *> &oprs, parser::MessageFixedText error) {
  if (oprs.size() == 1) {
    return TryDefinedOp(oprs[0], error);
  }
  MaybeExpr result;
  std::vector<const char *> hit;
  parser::Messages hitBuffer;
  {
    for (std::size_t i{0}; i < oprs.size(); ++i) {
      parser::Messages buffer;
      auto restorer{context_.GetContextualMessages().SetMessages(buffer)};
      if (MaybeExpr thisResult{TryDefinedOp(oprs[i], error, /*isUserOp=*/false,
              /*checkForNullPointer=*/false)}) {
        result = std::move(thisResult);
        hit.push_back(oprs[i]);
        hitBuffer = std::move(buffer);
      }
    }
  }
  if (hit.empty()) { // run TryDefinedOp() again just to emit errors
    CHECK(!TryDefinedOp(oprs[0], error).has_value());
  } else if (hit.size() > 1) {
    context_.Say(
        "Matching accessible definitions were found with %zd variant spellings of the generic operator ('%s', '%s')"_err_en_US,
        hit.size(), ToUpperCase(hit[0]), ToUpperCase(hit[1]));
  } else { // one hit; preserve errors
    context_.context().messages().Annex(std::move(hitBuffer));
  }
  return result;
}

MaybeExpr ArgumentAnalyzer::TryBoundOp(const Symbol &symbol, int passIndex) {
  ActualArguments localActuals{actuals_};
  const Symbol *proc{GetBindingResolution(GetType(passIndex), symbol)};
  if (!proc) {
    proc = &symbol;
    localActuals.at(passIndex).value().set_isPassedObject();
  }
  CheckConformance();
  return context_.MakeFunctionRef(
      source_, ProcedureDesignator{*proc}, std::move(localActuals));
}

std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {
  using semantics::Tristate;
  const Expr<SomeType> &lhs{GetExpr(0)};
  const Expr<SomeType> &rhs{GetExpr(1)};
  std::optional<DynamicType> lhsType{lhs.GetType()};
  std::optional<DynamicType> rhsType{rhs.GetType()};
  int lhsRank{lhs.Rank()};
  int rhsRank{rhs.Rank()};
  Tristate isDefined{
      semantics::IsDefinedAssignment(lhsType, lhsRank, rhsType, rhsRank)};
  if (isDefined == Tristate::No) {
    // Make implicit conversion explicit, unless it is an assignment to a whole
    // allocatable (the explicit conversion would prevent the propagation of the
    // right hand side if it is a variable). Lowering will deal with the
    // conversion in this case.
    if (lhsType) {
      if (rhsType) {
        FoldingContext &foldingContext{context_.GetFoldingContext()};
        auto restorer{foldingContext.messages().SetLocation(
            actuals_.at(1).value().sourceLocation().value_or(
                foldingContext.messages().at()))};
        CheckRealWidening(rhs, lhsType, foldingContext);
        if (!IsAllocatableDesignator(lhs) || context_.inWhereBody()) {
          AddAssignmentConversion(*lhsType, *rhsType);
        }
      } else if (IsBOZLiteral(1)) {
        ConvertBOZAssignmentRHS(*lhsType);
        if (IsBOZLiteral(1)) {
          context_.Say(
              "Right-hand side of this assignment may not be BOZ"_err_en_US);
          fatalErrors_ = true;
        }
      }
    }
    if (!fatalErrors_) {
      CheckAssignmentConformance();
    }
    return std::nullopt; // user-defined assignment not allowed for these args
  }
  auto restorer{context_.GetContextualMessages().SetLocation(source_)};
  bool isAmbiguous{false};
  if (std::optional<ProcedureRef> procRef{
          GetDefinedAssignmentProc(isAmbiguous)}) {
    bool hasCUDADeviceRhs{false};
    for (const semantics::Symbol &symbol : CollectCudaSymbols(rhs)) {
      if (semantics::IsCUDADevice(symbol)) {
        hasCUDADeviceRhs = true;
        break;
      }
    }
    const semantics::Symbol *rhsSymbol{UnwrapWholeSymbolDataRef(rhs)};
    bool hasCUDADeviceAssociateRhs{false};
    if (rhsSymbol) {
      if (const auto *associate{
              rhsSymbol->detailsIf<semantics::AssocEntityDetails>()}) {
        if (const auto &selector{associate->expr()}) {
          for (const semantics::Symbol &symbol :
              CollectCudaSymbols(*selector)) {
            if (semantics::IsCUDADevice(symbol)) {
              hasCUDADeviceAssociateRhs = true;
              break;
            }
          }
        }
      }
    }
    if (hasCUDADeviceRhs && context_.inWhereBody()) {
      context_.Say(
          "Defined assignment in WHERE with a CUDA DEVICE right-hand side is not yet implemented"_todo_en_US);
    } else if (hasCUDADeviceRhs && procRef->proc().IsElemental()) {
      context_.Say(
          "Elemental defined assignment with a CUDA DEVICE right-hand side is not yet implemented"_todo_en_US);
    } else if (hasCUDADeviceAssociateRhs) {
      context_.Say(
          "Defined assignment from an ASSOCIATE name with a CUDA DEVICE target is not yet implemented"_todo_en_US);
    } else if (context_.inWhereBody() &&
        !procRef->proc().IsElemental()) { // C1032
      context_.Say(
          "Defined assignment in WHERE must be elemental, but '%s' is not"_err_en_US,
          DEREF(procRef->proc().GetSymbol()).name());
    }
    context_.CheckCall(source_, procRef->proc(), procRef->arguments());
    return std::move(*procRef);
  }
  if (isDefined == Tristate::Yes) {
    if (isAmbiguous || !lhsType || !rhsType ||
        (lhsRank != rhsRank && rhsRank != 0) ||
        !OkLogicalIntegerAssignment(lhsType->category(), rhsType->category())) {
      SayNoMatch(
          "ASSIGNMENT(=)", /*isAssignment=*/true, /*isAmbiguous=*/isAmbiguous);
    }
  } else if (!fatalErrors_) {
    CheckAssignmentConformance();
  }
  return std::nullopt;
}

bool ArgumentAnalyzer::OkLogicalIntegerAssignment(
    TypeCategory lhs, TypeCategory rhs) {
  if (!context_.context().languageFeatures().IsEnabled(
          common::LanguageFeature::LogicalIntegerAssignment)) {
    return false;
  }
  std::optional<parser::MessageFixedText> msg;
  if (lhs == TypeCategory::Integer && rhs == TypeCategory::Logical) {
    // allow assignment to LOGICAL from INTEGER as a legacy extension
    msg = "assignment of LOGICAL to INTEGER"_port_en_US;
  } else if (lhs == TypeCategory::Logical && rhs == TypeCategory::Integer) {
    // ... and assignment to LOGICAL from INTEGER
    msg = "assignment of INTEGER to LOGICAL"_port_en_US;
  } else {
    return false;
  }
  context_.Warn(
      common::LanguageFeature::LogicalIntegerAssignment, std::move(*msg));
  return true;
}

std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc(
    bool &isAmbiguous) {
  const Symbol *proc{nullptr};
  bool isProcElemental{false};
  std::optional<int> passedObjectIndex;
  std::string oprNameString{"assignment(=)"};
  parser::CharBlock oprName{oprNameString};
  const auto &scope{context_.context().FindScope(source_)};
  isAmbiguous = false;
  {
    auto restorer{context_.GetContextualMessages().DiscardMessages()};
    if (const Symbol *symbol{scope.FindSymbol(oprName)}) {
      ExpressionAnalyzer::AdjustActuals noAdjustment;
      proc = context_
                 .ResolveGeneric(
                     *symbol, actuals_, noAdjustment, true, SymbolVector{})
                 .specific;
      if (proc) {
        isProcElemental = IsElementalProcedure(*proc);
      }
    }
    for (std::size_t i{0}; (!proc || isProcElemental) && i < actuals_.size();
        ++i) {
      const Symbol *generic{nullptr};
      if (const Symbol *binding{FindBoundOp(oprName, i, generic,
              /*isSubroutine=*/true, /*isAmbiguous=*/&isAmbiguous)}) {
        // ignore inaccessible type-bound ASSIGNMENT(=) generic
        if (!CheckAccessibleSymbol(scope, DEREF(generic))) {
          const Symbol *resolution{GetBindingResolution(GetType(i), *binding)};
          const Symbol &newProc{*(resolution ? resolution : binding)};
          bool isElemental{IsElementalProcedure(newProc)};
          if (!proc || !isElemental) {
            // Non-elemental resolution overrides elemental
            proc = &newProc;
            isProcElemental = isElemental;
            if (resolution) {
              passedObjectIndex.reset();
            } else {
              passedObjectIndex = i;
            }
          }
        }
      }
    }
  }
  if (!proc) {
    return std::nullopt;
  }
  ActualArguments actualsCopy{actuals_};
  // Ensure that the RHS argument is not passed as a variable unless
  // the dummy argument has the VALUE attribute, or the actual's own attributes
  // already require reference semantics that must be preserved.
  if (const auto *rhsExpr{actualsCopy.at(1).value().UnwrapExpr()};
      evaluate::IsVariable(rhsExpr)) {
    auto chars{evaluate::characteristics::Procedure::Characterize(
        *proc, context_.GetFoldingContext())};
    const auto *rhsDummy{chars && chars->dummyArguments.size() == 2
            ? std::get_if<evaluate::characteristics::DummyDataObject>(
                  &chars->dummyArguments.at(1).u)
            : nullptr};
    std::optional<common::CUDADataAttr> rhsDataAttr;
    for (const Symbol &symbol : evaluate::GetSymbolVector(*rhsExpr)) {
      if (auto cudaAttr{GetCUDADataAttr(&symbol)}) {
        rhsDataAttr = *cudaAttr;
      }
    }
    const Symbol *rhsFirstSymbol{evaluate::GetFirstSymbol(*rhsExpr)};
    // TODO: This DEVICE exception may need to be limited to device-to-host
    // transfers or to RHS references that appear in unambiguous host code.
    const bool preserveActualReference{
        (rhsDataAttr && *rhsDataAttr == common::CUDADataAttr::Device) ||
        (rhsFirstSymbol && IsValue(*rhsFirstSymbol))};
    if (!preserveActualReference &&
        (!rhsDummy ||
            !rhsDummy->attrs.test(
                evaluate::characteristics::DummyDataObject::Attr::Value))) {
      actualsCopy.at(1).value().Parenthesize();
    }
  }
  if (passedObjectIndex) {
    actualsCopy[*passedObjectIndex]->set_isPassedObject();
  }
  return ProcedureRef{ProcedureDesignator{*proc}, std::move(actualsCopy)};
}

void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {
  os << "source_: " << source_.ToString() << " fatalErrors_ = " << fatalErrors_
     << '\n';
  for (const auto &actual : actuals_) {
    if (!actual.has_value()) {
      os << "- error\n";
    } else if (const Symbol *symbol{actual->GetAssumedTypeDummy()}) {
      os << "- assumed type: " << symbol->name().ToString() << '\n';
    } else if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {
      expr->AsFortran(os << "- expr: ") << '\n';
    } else {
      DIE("bad ActualArgument");
    }
  }
}

std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
    const parser::Expr &expr) {
  source_.ExtendToCover(expr.source);
  if (const Symbol *assumedTypeDummy{AssumedTypeDummy(expr)}) {
    ResetExpr(expr);
    if (isProcedureCall_) {
      ActualArgument arg{ActualArgument::AssumedType{*assumedTypeDummy}};
      SetArgSourceLocation(arg, expr.source);
      return std::move(arg);
    }
    context_.SayAt(expr.source,
        "TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
  } else if (MaybeExpr argExpr{AnalyzeExprOrWholeAssumedSizeArray(expr)}) {
    if (isProcedureCall_ || !IsProcedureDesignator(*argExpr)) {
      // Pad Hollerith actual argument with spaces up to a multiple of 8
      // bytes, in case the data are interpreted as double precision
      // (or a smaller numeric type) by legacy code.
      if (auto hollerith{UnwrapExpr<Constant<Ascii>>(*argExpr)};
          hollerith && hollerith->wasHollerith()) {
        std::string bytes{hollerith->values()};
        while ((bytes.size() % 8) != 0) {
          bytes += ' ';
        }
        Constant<Ascii> c{std::move(bytes)};
        c.set_wasHollerith(true);
        argExpr = AsGenericExpr(std::move(c));
      }
      ActualArgument arg{std::move(*argExpr)};
      SetArgSourceLocation(arg, expr.source);
      return std::move(arg);
    }
    context_.SayAt(expr.source,
        IsFunctionDesignator(*argExpr)
            ? "Function call must have argument list"_err_en_US
            : "Subroutine name is not allowed here"_err_en_US);
  }
  return std::nullopt;
}

MaybeExpr ArgumentAnalyzer::AnalyzeExprOrWholeAssumedSizeArray(
    const parser::Expr &expr) {
  // If an expression's parse tree is a whole assumed-size array:
  //   Expr -> Designator -> DataRef -> Name
  // treat it as a special case for argument passing and bypass
  // the C1002/C1014 constraint checking in expression semantics.
  if (const auto *name{parser::Unwrap<parser::Name>(expr)}) {
    if (name->symbol && semantics::IsAssumedSizeArray(*name->symbol)) {
      auto restorer{context_.AllowWholeAssumedSizeArray()};
      return context_.Analyze(expr);
    }
  }
  auto restorer{context_.AllowNullPointer()};
  MaybeExpr result{context_.Analyze(expr)};
  // For actual arguments of procedure references, retain a designator whose
  // base is a named constant in designator form instead of replacing it by
  // its folded Constant value, so that lowering associates the dummy argument
  // with the named constant's storage.  This matters for sequence association
  // of an array element actual argument (F'2023 15.5.2.12) and whenever the
  // dummy's address is meaningful (e.g. OpenACC/OpenMP present checks).
  // The inner Analyze calls below do not apply the outer folding performed
  // by Analyze(parser::Expr), and folding still sees through the retained
  // designator wherever a constant value is needed later.
  if (isProcedureCall_ && result) {
    // Look only at an expression that is itself a designator: a
    // parenthesized designator is a primary, i.e. an expression
    // (F'2023 R1001), and must keep its folded value.  Substring actual
    // arguments (the F'2023 15.5.2.12 p4 form of character sequence
    // association) are not retained here and keep their folded values.
    if (const auto *designator{
            std::get_if<common::Indirection<parser::Designator>>(&expr.u)}) {
      if (const auto *name{parser::Unwrap<parser::Name>(designator->value())}) {
        // Whole named-constant array.
        if (name->symbol &&
            semantics::IsNamedConstant(name->symbol->GetUltimate()) &&
            name->symbol->Rank() > 0) {
          return context_.Analyze(*name);
        }
      } else {
        // Named-constant array element or section (or array component of a
        // scalar named constant of derived type), e.g. a(1), a(1:3), a(2:*),
        // pt%arr(1).  A section with a vector subscript or a component of a
        // section is retained too; those are not contiguous, and lowering
        // copies them like any other actual argument that needs a copy.
        if (const auto *ae{
                parser::Unwrap<parser::ArrayElement>(designator->value())}) {
          const auto &baseName{parser::GetFirstName(ae->Base())};
          if (baseName.symbol &&
              semantics::IsNamedConstant(baseName.symbol->GetUltimate())) {
            return context_.Analyze(*ae);
          }
        }
      }
    }
  }
  return result;
}

bool ArgumentAnalyzer::AreConformable() const {
  CHECK(actuals_.size() == 2);
  return actuals_[0] && actuals_[1] &&
      evaluate::AreConformable(*actuals_[0], *actuals_[1]);
}

// Look for a type-bound operator in the type of arg number passIndex.
const Symbol *ArgumentAnalyzer::FindBoundOp(parser::CharBlock oprName,
    int passIndex, const Symbol *&generic, bool isSubroutine,
    bool *isAmbiguous) {
  const auto *type{GetDerivedTypeSpec(GetType(passIndex))};
  const semantics::Scope *scope{type ? type->scope() : nullptr};
  if (scope) {
    // Use the original type definition's scope, since PDT
    // instantiations don't have redundant copies of bindings or
    // generics.
    scope = DEREF(scope->derivedTypeSpec()).typeSymbol().scope();
  }
  generic = scope ? scope->FindComponent(oprName) : nullptr;
  if (generic) {
    ExpressionAnalyzer::AdjustActuals adjustment{
        [&](const Symbol &proc, ActualArguments &) {
          return passIndex == GetPassIndex(proc).value_or(-1);
        }};
    auto result{context_.ResolveGeneric(
        *generic, actuals_, adjustment, isSubroutine, SymbolVector{})};
    if (const Symbol *binding{result.specific}) {
      CHECK(binding->has<semantics::ProcBindingDetails>());
      // Use the most recent override of the binding, if any
      return scope->FindComponent(binding->name());
    } else {
      if (isAmbiguous) {
        *isAmbiguous = result.failedDueToAmbiguity;
      }
      context_.EmitGenericResolutionError(*generic, result.failedDueToAmbiguity,
          isSubroutine, actuals_, result.tried, adjustment);
    }
  }
  return nullptr;
}

// If there is an implicit conversion between intrinsic types, make it explicit
void ArgumentAnalyzer::AddAssignmentConversion(
    const DynamicType &lhsType, const DynamicType &rhsType) {
  if (lhsType.category() == rhsType.category() &&
      (lhsType.category() == TypeCategory::Derived ||
          lhsType.kind() == rhsType.kind())) {
    // no conversion necessary
  } else if (auto rhsExpr{evaluate::Fold(context_.GetFoldingContext(),
                 evaluate::ConvertToType(lhsType, MoveExpr(1)))}) {
    std::optional<parser::CharBlock> source;
    if (actuals_[1]) {
      source = actuals_[1]->sourceLocation();
    }
    actuals_[1] = ActualArgument{*rhsExpr};
    SetArgSourceLocation(actuals_[1], source);
  } else {
    actuals_[1] = std::nullopt;
  }
}

std::optional<DynamicType> ArgumentAnalyzer::GetType(std::size_t i) const {
  return i < actuals_.size() ? actuals_[i].value().GetType() : std::nullopt;
}
int ArgumentAnalyzer::GetRank(std::size_t i) const {
  return i < actuals_.size() ? actuals_[i].value().Rank() : 0;
}

// If the argument at index i is a BOZ literal, convert its type to match the
// otherType.  If it's REAL, convert to REAL; if it's UNSIGNED, convert to
// UNSIGNED; otherwise, convert to INTEGER.
// Note that IBM supports comparing BOZ literals to CHARACTER operands.  That
// is not currently supported.
void ArgumentAnalyzer::ConvertBOZOperand(std::optional<DynamicType> *thisType,
    std::size_t i, std::optional<DynamicType> otherType) {
  if (IsBOZLiteral(i)) {
    Expr<SomeType> &&argExpr{MoveExpr(i)};
    auto *boz{std::get_if<BOZLiteralConstant>(&argExpr.u)};
    if (otherType && otherType->category() == TypeCategory::Real) {
      int kind{context_.context().GetDefaultKind(TypeCategory::Real)};
      MaybeExpr realExpr{
          ConvertToKind<TypeCategory::Real>(kind, std::move(*boz))};
      actuals_[i] = std::move(realExpr.value());
      if (thisType) {
        thisType->emplace(TypeCategory::Real, kind);
      }
    } else if (otherType && otherType->category() == TypeCategory::Unsigned) {
      int kind{context_.context().GetDefaultKind(TypeCategory::Unsigned)};
      MaybeExpr unsignedExpr{
          ConvertToKind<TypeCategory::Unsigned>(kind, std::move(*boz))};
      actuals_[i] = std::move(unsignedExpr.value());
      if (thisType) {
        thisType->emplace(TypeCategory::Unsigned, kind);
      }
    } else {
      int kind{context_.context().GetDefaultKind(TypeCategory::Integer)};
      MaybeExpr intExpr{
          ConvertToKind<TypeCategory::Integer>(kind, std::move(*boz))};
      actuals_[i] = std::move(*intExpr);
      if (thisType) {
        thisType->emplace(TypeCategory::Integer, kind);
      }
    }
  }
}

void ArgumentAnalyzer::ConvertBOZAssignmentRHS(const DynamicType &lhsType) {
  if (lhsType.category() == TypeCategory::Integer ||
      lhsType.category() == TypeCategory::Unsigned ||
      lhsType.category() == TypeCategory::Real) {
    Expr<SomeType> rhs{MoveExpr(1)};
    if (lhsType.category() == TypeCategory::Integer ||
        lhsType.category() == TypeCategory::Unsigned) {
      if (const auto *boz{std::get_if<BOZLiteralConstant>(&rhs.u)};
          boz && boz->bits - boz->LEADZ() > lhsType.kind() * 8) {
        context_.Warn(common::UsageWarning::BOZLiteralTruncation,
            "BOZ literal constant is too large for %s(KIND=%d) assignment target; truncated"_warn_en_US,
            lhsType.category() == TypeCategory::Unsigned ? "UNSIGNED"
                                                         : "INTEGER",
            lhsType.kind());
      }
    }
    if (MaybeExpr converted{ConvertToType(lhsType, std::move(rhs))}) {
      actuals_[1] = std::move(*converted);
    }
  }
}

// Report error resolving opr when there is a user-defined one available
void ArgumentAnalyzer::SayNoMatch(
    const std::string &opr, bool isAssignment, bool isAmbiguous) {
  std::string type0{TypeAsFortran(0)};
  auto rank0{actuals_[0]->Rank()};
  std::string prefix{"No intrinsic or user-defined "s + opr + " matches"};
  if (isAmbiguous) {
    prefix = "Multiple specific procedures for the generic "s + opr + " match";
  }
  if (actuals_.size() == 1) {
    if (rank0 > 0) {
      context_.Say("%s rank %d array of %s"_err_en_US, prefix, rank0, type0);
    } else {
      context_.Say("%s operand type %s"_err_en_US, prefix, type0);
    }
  } else {
    std::string type1{TypeAsFortran(1)};
    auto rank1{actuals_[1]->Rank()};
    if (rank0 > 0 && rank1 > 0 && rank0 != rank1) {
      context_.Say("%s rank %d array of %s and rank %d array of %s"_err_en_US,
          prefix, rank0, type0, rank1, type1);
    } else if (isAssignment && rank0 != rank1) {
      if (rank0 == 0) {
        context_.Say("%s scalar %s and rank %d array of %s"_err_en_US, prefix,
            type0, rank1, type1);
      } else {
        context_.Say("%s rank %d array of %s and scalar %s"_err_en_US, prefix,
            rank0, type0, type1);
      }
    } else {
      context_.Say(
          "%s operand types %s and %s"_err_en_US, prefix, type0, type1);
    }
  }
}

std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
  if (i >= actuals_.size() || !actuals_[i]) {
    return "missing argument";
  } else if (std::optional<DynamicType> type{GetType(i)}) {
    return type->IsAssumedType()         ? "TYPE(*)"s
        : type->IsUnlimitedPolymorphic() ? "CLASS(*)"s
        : type->IsPolymorphic()          ? type->AsFortran()
        : type->category() == TypeCategory::Derived
        ? (type->GetDerivedTypeSpec().IsVectorType()
                  ? type->AsFortran()
                  : "TYPE("s + type->AsFortran() + ')')
        : type->category() == TypeCategory::Character
        ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
        : ToUpperCase(type->AsFortran());
  } else {
    return "untyped";
  }
}

bool ArgumentAnalyzer::AnyUntypedOperand() const {
  for (const auto &actual : actuals_) {
    if (actual && !actual->GetType() &&
        !IsBareNullPointer(actual->UnwrapExpr())) {
      return true;
    }
  }
  return false;
}

bool ArgumentAnalyzer::AnyMissingOperand() const {
  for (const auto &actual : actuals_) {
    if (!actual) {
      return true;
    }
  }
  return false;
}
} // namespace Fortran::evaluate

namespace Fortran::semantics {
evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
    SemanticsContext &context, common::TypeCategory category,
    const std::optional<parser::KindSelector> &selector) {
  evaluate::ExpressionAnalyzer analyzer{context};
  CHECK(context.location().has_value());
  auto restorer{
      analyzer.GetContextualMessages().SetLocation(*context.location())};
  return analyzer.AnalyzeKindSelector(category, selector);
}

void NoteUsedSymbols(
    SemanticsContext &context, const SomeExpr &expr, bool isDefinition) {
  context.NoteUsedSymbols(
      evaluate::CollectUsedSymbolValues(context, expr, isDefinition));
}

bool CheckMisparsedArrayElement(
    SemanticsContext &context, const parser::FunctionReference &funcRef) {
  // Ensure that there are no argument keywords
  for (const auto &arg :
      std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t)) {
    if (std::get<std::optional<parser::Keyword>>(arg.t)) {
      return false;
    }
  }
  auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
  if (const Symbol *origSymbol{common::visit(
          common::visitors{
              [&](const parser::Name &name) { return name.symbol; },
              [&](const parser::ProcComponentRef &pcr) {
                return parser::UnwrapRef<parser::StructureComponent>(pcr)
                    .Component()
                    .symbol;
              },
          },
          proc.u)}) {
    const Symbol &symbol{origSymbol->GetUltimate()};
    if (symbol.has<semantics::ObjectEntityDetails>() ||
        symbol.has<semantics::AssocEntityDetails>()) {
      // Note that expression in AssocEntityDetails cannot be a procedure
      // pointer as per C1105 so this cannot be a function reference.
      return evaluate::CheckFuncRefToArrayElement(context, funcRef);
    }
  }
  return false;
}

ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}

bool ExprChecker::Pre(const parser::DataStmtObject &obj) {
  exprAnalyzer_.set_inDataStmtObject(true);
  return true;
}

void ExprChecker::Post(const parser::DataStmtObject &obj) {
  exprAnalyzer_.set_inDataStmtObject(false);
}

bool ExprChecker::Pre(const parser::DataImpliedDo &ido) {
  parser::Walk(std::get<parser::DataImpliedDo::Bounds>(ido.t), *this);
  const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(ido.t)};
  const auto &name{parser::UnwrapRef<parser::Name>(bounds.Name())};
  int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
  if (const auto dynamicType{evaluate::DynamicType::From(DEREF(name.symbol))}) {
    if (dynamicType->category() == TypeCategory::Integer) {
      kind = dynamicType->kind();
    }
  }
  exprAnalyzer_.AddImpliedDo(name.source, kind);
  parser::Walk(std::get<std::list<parser::DataIDoObject>>(ido.t), *this);
  exprAnalyzer_.RemoveImpliedDo(name.source);
  return false;
}

// Handle messages from dead code in block IF constructs
bool ExprChecker::Pre(const parser::IfConstruct &construct) {
  enum State {
    NotYetKnownTrue,
    WasKnownTrue,
    TrueNow,
    FalseNow
  } state{NotYetKnownTrue};
  auto &messages{exprAnalyzer_.GetContextualMessages()};
  parser::CharBlock determiner; // source of relevant IF statement

  auto consider{[&](const SomeExpr *expr, parser::CharBlock here) {
    if (state == TrueNow) {
      state = WasKnownTrue;
    } else if (state != WasKnownTrue) {
      state = NotYetKnownTrue;
      if (expr) {
        if (auto known{
                evaluate::GetScalarConstantValue<evaluate::LogicalResult>(
                    *expr)}) {
          state = known->IsTrue() ? TrueNow : FalseNow;
          determiner = here;
        }
      }
    }
  }};
  auto doBlock{[&, this](const parser::Block &block) {
    if ((state == FalseNow || state == WasKnownTrue) && messages.messages()) {
      parser::Messages inDeadCode;
      {
        auto restorer{messages.SetMessages(inDeadCode)};
        parser::Walk(block, *this);
      }
      for (auto &msg : inDeadCode.messages()) {
        if (msg.severity() == parser::Severity::ErrorUnlessDeadCode) {
          msg.set_severity(parser::Severity::Warning);
          msg.set_usageWarning(common::UsageWarning::BadValueInDeadCode);
          msg.Attach(determiner,
              "in code known to be dead due to this compile-time IF expression value"_en_US);
        }
      }
      if (context_.ShouldWarn(common::UsageWarning::BadValueInDeadCode) ||
          inDeadCode.AnyFatalError()) {
        messages.messages()->Annex(std::move(inDeadCode));
      }
    } else {
      parser::Walk(block, *this);
    }
  }};

  const auto &[ifThen, block, elseIfs, maybeElse, endIf]{construct.t};
  // IF (...) THEN block
  parser::Walk(ifThen, *this);
  consider(GetExpr(&context_,
               std::get<parser::ScalarLogicalExpr>(ifThen.statement.t)),
      ifThen.source);
  doBlock(block);
  // ELSE IF (...) THEN block ...
  for (const auto &elseIf : elseIfs) {
    const auto &[stmt, block]{elseIf.t};
    parser::Walk(stmt, *this);
    consider(GetExpr(&context_,
                 std::get<parser::ScalarLogicalExpr>(stmt.statement.t)),
        stmt.source);
    doBlock(block);
  }
  // ELSE block
  if (maybeElse) {
    const auto &[stmt, block]{maybeElse->t};
    parser::Walk(stmt, *this);
    if (state == TrueNow || state == WasKnownTrue) {
      state = FalseNow;
    } else {
      state = TrueNow;
    }
    doBlock(block);
  }
  // END IF
  parser::Walk(endIf, *this);
  return false;
}

bool ExprChecker::Walk(const parser::Program &program) {
  parser::Walk(program, *this);
  return !context_.AnyFatalError();
}
} // namespace Fortran::semantics