brintos / llvm-project-archived public Read only

1//===-- lib/Semantics/expression.cpp --------------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Semantics/expression.h"10#include "check-call.h"11#include "pointer-assignment.h"12#include "resolve-names-utils.h"13#include "resolve-names.h"14#include "flang/Common/idioms.h"15#include "flang/Common/type-kinds.h"16#include "flang/Evaluate/common.h"17#include "flang/Evaluate/fold.h"18#include "flang/Evaluate/tools.h"19#include "flang/Parser/characters.h"20#include "flang/Parser/dump-parse-tree.h"21#include "flang/Parser/parse-tree-visitor.h"22#include "flang/Parser/parse-tree.h"23#include "flang/Semantics/scope.h"24#include "flang/Semantics/semantics.h"25#include "flang/Semantics/symbol.h"26#include "flang/Semantics/tools.h"27#include "flang/Support/Fortran.h"28#include "llvm/Support/raw_ostream.h"29#include <algorithm>30#include <functional>31#include <optional>32#include <set>33#include <vector>34 35// Typedef for optional generic expressions (ubiquitous in this file)36using MaybeExpr =37    std::optional<Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>;38 39// Much of the code that implements semantic analysis of expressions is40// tightly coupled with their typed representations in lib/Evaluate,41// and appears here in namespace Fortran::evaluate for convenience.42namespace Fortran::evaluate {43 44using common::LanguageFeature;45using common::NumericOperator;46using common::TypeCategory;47 48static inline std::string ToUpperCase(std::string_view str) {49  return parser::ToUpperCaseLetters(str);50}51 52struct DynamicTypeWithLength : public DynamicType {53  explicit DynamicTypeWithLength(const DynamicType &t) : DynamicType{t} {}54  std::optional<Expr<SubscriptInteger>> LEN() const;55  std::optional<Expr<SubscriptInteger>> length;56};57 58std::optional<Expr<SubscriptInteger>> DynamicTypeWithLength::LEN() const {59  if (length) {60    return length;61  } else {62    return GetCharLength();63  }64}65 66static std::optional<DynamicTypeWithLength> AnalyzeTypeSpec(67    const std::optional<parser::TypeSpec> &spec, FoldingContext &context) {68  if (spec) {69    if (const semantics::DeclTypeSpec *typeSpec{spec->declTypeSpec}) {70      // Name resolution sets TypeSpec::declTypeSpec only when it's valid71      // (viz., an intrinsic type with valid known kind or a non-polymorphic72      // & non-ABSTRACT derived type).73      if (const semantics::IntrinsicTypeSpec *intrinsic{74              typeSpec->AsIntrinsic()}) {75        TypeCategory category{intrinsic->category()};76        if (auto optKind{ToInt64(intrinsic->kind())}) {77          int kind{static_cast<int>(*optKind)};78          if (category == TypeCategory::Character) {79            const semantics::CharacterTypeSpec &cts{80                typeSpec->characterTypeSpec()};81            const semantics::ParamValue &len{cts.length()};82            if (len.isAssumed() || len.isDeferred()) {83              context.messages().Say(84                  "A length specifier of '*' or ':' may not appear in the type of an array constructor"_err_en_US);85            }86            DynamicTypeWithLength type{DynamicType{kind, len}};87            if (auto lenExpr{type.LEN()}) {88              type.length = Fold(context,89                  AsExpr(Extremum<SubscriptInteger>{Ordering::Greater,90                      Expr<SubscriptInteger>{0}, std::move(*lenExpr)}));91            }92            return type;93          } else {94            return DynamicTypeWithLength{DynamicType{category, kind}};95          }96        }97      } else if (const semantics::DerivedTypeSpec *derived{98                     typeSpec->AsDerived()}) {99        return DynamicTypeWithLength{DynamicType{*derived}};100      }101    }102  }103  return std::nullopt;104}105 106// Utilities to set a source location, if we have one, on an actual argument,107// when it is statically present.108static void SetArgSourceLocation(ActualArgument &x, parser::CharBlock at) {109  x.set_sourceLocation(at);110}111static void SetArgSourceLocation(112    std::optional<ActualArgument> &x, parser::CharBlock at) {113  if (x) {114    x->set_sourceLocation(at);115  }116}117static void SetArgSourceLocation(118    std::optional<ActualArgument> &x, std::optional<parser::CharBlock> at) {119  if (x && at) {120    x->set_sourceLocation(*at);121  }122}123 124class ArgumentAnalyzer {125public:126  explicit ArgumentAnalyzer(ExpressionAnalyzer &context)127      : context_{context}, source_{context.GetContextualMessages().at()},128        isProcedureCall_{false} {}129  ArgumentAnalyzer(ExpressionAnalyzer &context, parser::CharBlock source,130      bool isProcedureCall = false)131      : context_{context}, source_{source}, isProcedureCall_{isProcedureCall} {}132  bool fatalErrors() const { return fatalErrors_; }133  ActualArguments &&GetActuals() {134    CHECK(!fatalErrors_);135    return std::move(actuals_);136  }137  const Expr<SomeType> &GetExpr(std::size_t i) const {138    return DEREF(actuals_.at(i).value().UnwrapExpr());139  }140  Expr<SomeType> &&MoveExpr(std::size_t i) {141    return std::move(DEREF(actuals_.at(i).value().UnwrapExpr()));142  }143  void Analyze(const common::Indirection<parser::Expr> &x) {144    Analyze(x.value());145  }146  void Analyze(const parser::Expr &x) {147    actuals_.emplace_back(AnalyzeExpr(x));148    SetArgSourceLocation(actuals_.back(), x.source);149    fatalErrors_ |= !actuals_.back();150  }151  void Analyze(const parser::Variable &);152  void Analyze(const parser::ActualArgSpec &, bool isSubroutine);153  void ConvertBOZOperand(std::optional<DynamicType> *thisType, std::size_t,154      std::optional<DynamicType> otherType);155  void ConvertBOZAssignmentRHS(const DynamicType &lhsType);156 157  bool IsIntrinsicRelational(158      RelationalOperator, const DynamicType &, const DynamicType &) const;159  bool IsIntrinsicLogical() const;160  bool IsIntrinsicNumeric(NumericOperator) const;161  bool IsIntrinsicConcat() const;162 163  bool CheckConformance();164  bool CheckAssignmentConformance();165  bool CheckForNullPointer(const char *where = "as an operand here");166  bool CheckForAssumedRank(const char *where = "as an operand here");167 168  bool AnyCUDADeviceData() const;169  // Returns true if an interface has been defined for an intrinsic operator170  // with one or more device operands.171  bool HasDeviceDefinedIntrinsicOpOverride(const char *) const;172  template <typename E> bool HasDeviceDefinedIntrinsicOpOverride(E opr) const {173    return HasDeviceDefinedIntrinsicOpOverride(174        context_.context().languageFeatures().GetNames(opr));175  }176 177  // Find and return a user-defined operator or report an error.178  // The provided message is used if there is no such operator.179  MaybeExpr TryDefinedOp(const char *, parser::MessageFixedText,180      bool isUserOp = false, bool checkForNullPointer = true);181  template <typename E>182  MaybeExpr TryDefinedOp(E opr, parser::MessageFixedText msg) {183    return TryDefinedOp(184        context_.context().languageFeatures().GetNames(opr), msg);185  }186  // Find and return a user-defined assignment187  std::optional<ProcedureRef> TryDefinedAssignment();188  std::optional<ProcedureRef> GetDefinedAssignmentProc(bool &isAmbiguous);189  std::optional<DynamicType> GetType(std::size_t) const;190  void Dump(llvm::raw_ostream &);191 192private:193  bool HasDeviceDefinedIntrinsicOpOverride(194      const std::vector<const char *> &) const;195  MaybeExpr TryDefinedOp(196      const std::vector<const char *> &, parser::MessageFixedText);197  MaybeExpr TryBoundOp(const Symbol &, int passIndex);198  std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);199  std::optional<ActualArgument> AnalyzeVariable(const parser::Variable &);200  MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &);201  bool AreConformable() const;202  const Symbol *FindBoundOp(parser::CharBlock, int passIndex,203      const Symbol *&generic, bool isSubroutine, bool *isAmbiguous = nullptr);204  void AddAssignmentConversion(205      const DynamicType &lhsType, const DynamicType &rhsType);206  bool OkLogicalIntegerAssignment(TypeCategory lhs, TypeCategory rhs);207  int GetRank(std::size_t) const;208  bool IsBOZLiteral(std::size_t i) const {209    return evaluate::IsBOZLiteral(GetExpr(i));210  }211  void SayNoMatch(212      const std::string &, bool isAssignment = false, bool isAmbiguous = false);213  std::string TypeAsFortran(std::size_t);214  bool AnyUntypedOperand() const;215  bool AnyMissingOperand() const;216 217  ExpressionAnalyzer &context_;218  ActualArguments actuals_;219  parser::CharBlock source_;220  bool fatalErrors_{false};221  const bool isProcedureCall_; // false for user-defined op or assignment222};223 224// Wraps a data reference in a typed Designator<>, and a procedure225// or procedure pointer reference in a ProcedureDesignator.226MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {227  const Symbol &last{ref.GetLastSymbol()};228  const Symbol &specific{BypassGeneric(last)};229  const Symbol &symbol{specific.GetUltimate()};230  if (semantics::IsProcedure(symbol)) {231    if (symbol.attrs().test(semantics::Attr::ABSTRACT)) {232      Say("Abstract procedure interface '%s' may not be used as a designator"_err_en_US,233          last.name());234    }235    if (auto *component{std::get_if<Component>(&ref.u)}) {236      if (!CheckDataRef(ref)) {237        return std::nullopt;238      }239      return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};240    } else if (!std::holds_alternative<SymbolRef>(ref.u)) {241      DIE("unexpected alternative in DataRef");242    } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {243      if (symbol.has<semantics::GenericDetails>()) {244        Say("'%s' is not a specific procedure"_err_en_US, last.name());245      } else if (IsProcedurePointer(specific)) {246        // For procedure pointers, retain associations so that data accesses247        // from client modules will work.248        return Expr<SomeType>{ProcedureDesignator{specific}};249      } else {250        return Expr<SomeType>{ProcedureDesignator{symbol}};251      }252    } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(253                   symbol.name().ToString())};254               interface && !interface->isRestrictedSpecific) {255      SpecificIntrinsic intrinsic{256          symbol.name().ToString(), std::move(*interface)};257      intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;258      return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};259    } else {260      Say("'%s' is not an unrestricted specific intrinsic procedure"_err_en_US,261          last.name());262    }263    return std::nullopt;264  } else if (MaybeExpr result{AsGenericExpr(std::move(ref))}) {265    return result;266  } else if (semantics::HadUseError(267                 context_, GetContextualMessages().at(), &symbol)) {268    return std::nullopt;269  } else {270    if (!context_.HasError(last) && !context_.HasError(symbol)) {271      AttachDeclaration(272          Say("'%s' is not an object that can appear in an expression"_err_en_US,273              last.name()),274          symbol);275      context_.SetError(last);276    }277    return std::nullopt;278  }279}280 281// Returns false if any dimension could be empty (e.g. A(1:0)) or has an error282static bool FoldSubscripts(semantics::SemanticsContext &context,283    const Symbol &arraySymbol, std::vector<Subscript> &subscripts, Shape &lb,284    Shape &ub) {285  FoldingContext &foldingContext{context.foldingContext()};286  lb = GetLBOUNDs(foldingContext, NamedEntity{arraySymbol});287  CHECK(lb.size() >= subscripts.size());288  ub = GetUBOUNDs(foldingContext, NamedEntity{arraySymbol});289  CHECK(ub.size() >= subscripts.size());290  bool anyPossiblyEmptyDim{false};291  int dim{0};292  for (Subscript &ss : subscripts) {293    if (Triplet * triplet{std::get_if<Triplet>(&ss.u)}) {294      auto expr{Fold(foldingContext, triplet->stride())};295      auto stride{ToInt64(expr)};296      triplet->set_stride(std::move(expr));297      std::optional<ConstantSubscript> lower, upper;298      if (auto expr{triplet->lower()}) {299        *expr = Fold(foldingContext, std::move(*expr));300        lower = ToInt64(*expr);301        triplet->set_lower(std::move(*expr));302      } else {303        lower = ToInt64(lb[dim]);304      }305      if (auto expr{triplet->upper()}) {306        *expr = Fold(foldingContext, std::move(*expr));307        upper = ToInt64(*expr);308        triplet->set_upper(std::move(*expr));309      } else {310        upper = ToInt64(ub[dim]);311      }312      if (stride) {313        if (*stride == 0) {314          foldingContext.messages().Say(315              "Stride of triplet must not be zero"_err_en_US);316          return false; // error317        }318        if (lower && upper) {319          if (*stride > 0) {320            anyPossiblyEmptyDim |= *lower > *upper;321          } else {322            anyPossiblyEmptyDim |= *lower < *upper;323          }324        } else {325          anyPossiblyEmptyDim = true;326        }327      } else { // non-constant stride328        if (lower && upper && *lower == *upper) {329          // stride is not relevant330        } else {331          anyPossiblyEmptyDim = true;332        }333      }334    } else { // not triplet335      auto &expr{std::get<IndirectSubscriptIntegerExpr>(ss.u).value()};336      expr = Fold(foldingContext, std::move(expr));337      anyPossiblyEmptyDim |= expr.Rank() > 0; // vector subscript338    }339    ++dim;340  }341  return !anyPossiblyEmptyDim;342}343 344static void ValidateSubscriptValue(parser::ContextualMessages &messages,345    const Symbol &symbol, ConstantSubscript val,346    std::optional<ConstantSubscript> lb, std::optional<ConstantSubscript> ub,347    int dim, const char *co = "") {348  std::optional<parser::MessageFixedText> msg;349  std::optional<ConstantSubscript> bound;350  if (lb && val < *lb) {351    msg =352        "%ssubscript %jd is less than lower %sbound %jd for %sdimension %d of array"_err_en_US;353    bound = *lb;354  } else if (ub && val > *ub) {355    msg =356        "%ssubscript %jd is greater than upper %sbound %jd for %sdimension %d of array"_err_en_US;357    bound = *ub;358    if (dim + 1 == symbol.Rank() && IsDummy(symbol) && *bound == 1) {359      // Old-school overindexing of a dummy array isn't fatal when360      // it's on the last dimension and the extent is 1.361      msg->set_severity(parser::Severity::Warning);362    }363  }364  if (msg) {365    AttachDeclaration(366        messages.Say(std::move(*msg), co, static_cast<std::intmax_t>(val), co,367            static_cast<std::intmax_t>(bound.value()), co, dim + 1),368        symbol);369  }370}371 372static void ValidateSubscripts(semantics::SemanticsContext &context,373    const Symbol &arraySymbol, const std::vector<Subscript> &subscripts,374    const Shape &lb, const Shape &ub) {375  int dim{0};376  for (const Subscript &ss : subscripts) {377    auto dimLB{ToInt64(lb[dim])};378    auto dimUB{ToInt64(ub[dim])};379    if (dimUB && dimLB && *dimUB < *dimLB) {380      AttachDeclaration(381          context.Warn(common::UsageWarning::SubscriptedEmptyArray,382              context.foldingContext().messages().at(),383              "Empty array dimension %d should not be subscripted as an element or non-empty array section"_err_en_US,384              dim + 1),385          arraySymbol);386      break;387    }388    std::optional<ConstantSubscript> val[2];389    int vals{0};390    if (auto *triplet{std::get_if<Triplet>(&ss.u)}) {391      auto stride{ToInt64(triplet->stride())};392      std::optional<ConstantSubscript> lower, upper;393      if (const auto *lowerExpr{triplet->GetLower()}) {394        lower = ToInt64(*lowerExpr);395      } else if (lb[dim]) {396        lower = ToInt64(*lb[dim]);397      }398      if (const auto *upperExpr{triplet->GetUpper()}) {399        upper = ToInt64(*upperExpr);400      } else if (ub[dim]) {401        upper = ToInt64(*ub[dim]);402      }403      if (lower) {404        val[vals++] = *lower;405        if (upper && *upper != lower && (stride && *stride != 0)) {406          // Normalize upper bound for non-unit stride407          // 1:10:2 -> 1:9:2, 10:1:-2 -> 10:2:-2408          val[vals++] = *lower + *stride * ((*upper - *lower) / *stride);409        }410      }411    } else {412      val[vals++] =413          ToInt64(std::get<IndirectSubscriptIntegerExpr>(ss.u).value());414    }415    for (int j{0}; j < vals; ++j) {416      if (val[j]) {417        ValidateSubscriptValue(context.foldingContext().messages(), arraySymbol,418            *val[j], dimLB, dimUB, dim);419      }420    }421    ++dim;422  }423}424 425static void CheckSubscripts(426    semantics::SemanticsContext &context, ArrayRef &ref) {427  const Symbol &arraySymbol{ref.base().GetLastSymbol()};428  Shape lb, ub;429  if (FoldSubscripts(context, arraySymbol, ref.subscript(), lb, ub)) {430    ValidateSubscripts(context, arraySymbol, ref.subscript(), lb, ub);431  }432}433 434static void CheckCosubscripts(435    semantics::SemanticsContext &context, CoarrayRef &ref) {436  const Symbol &coarraySymbol{ref.GetLastSymbol()};437  FoldingContext &foldingContext{context.foldingContext()};438  int dim{0};439  for (auto &expr : ref.cosubscript()) {440    expr = Fold(foldingContext, std::move(expr));441    if (auto val{ToInt64(expr)}) {442      ValidateSubscriptValue(foldingContext.messages(), coarraySymbol, *val,443          ToInt64(GetLCOBOUND(coarraySymbol, dim)),444          ToInt64(GetUCOBOUND(coarraySymbol, dim)), dim, "co");445    }446    ++dim;447  }448}449 450// Some subscript semantic checks must be deferred until all of the451// subscripts are in hand.452MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) {453  const Symbol &symbol{ref.GetLastSymbol().GetUltimate()};454  int symbolRank{symbol.Rank()};455  int subscripts{static_cast<int>(ref.size())};456  if (subscripts == 0) {457    return std::nullopt; // error recovery458  } else if (subscripts != symbolRank) {459    if (symbolRank != 0) {460      Say("Reference to rank-%d object '%s' has %d subscripts"_err_en_US,461          symbolRank, symbol.name(), subscripts);462    }463    return std::nullopt;464  } else if (symbol.has<semantics::ObjectEntityDetails>() ||465      symbol.has<semantics::AssocEntityDetails>()) {466    // C928 & C1002467    if (Triplet * last{std::get_if<Triplet>(&ref.subscript().back().u)}) {468      if (!last->upper() && IsAssumedSizeArray(symbol)) {469        Say("Assumed-size array '%s' must have explicit final subscript upper bound value"_err_en_US,470            symbol.name());471        return std::nullopt;472      }473    }474  } else {475    // Shouldn't get here from Analyze(ArrayElement) without a valid base,476    // which, if not an object, must be a construct entity from477    // SELECT TYPE/RANK or ASSOCIATE.478    CHECK(symbol.has<semantics::AssocEntityDetails>());479  }480  if (!semantics::IsNamedConstant(symbol) && !inDataStmtObject_) {481    // Subscripts of named constants are checked in folding.482    // Subscripts of DATA statement objects are checked in data statement483    // conversion to initializers.484    CheckSubscripts(context_, ref);485  }486  return Designate(DataRef{std::move(ref)});487}488 489// Applies subscripts to a data reference.490MaybeExpr ExpressionAnalyzer::ApplySubscripts(491    DataRef &&dataRef, std::vector<Subscript> &&subscripts) {492  if (subscripts.empty()) {493    return std::nullopt; // error recovery494  }495  return common::visit(common::visitors{496                           [&](SymbolRef &&symbol) {497                             return CompleteSubscripts(498                                 ArrayRef{symbol, std::move(subscripts)});499                           },500                           [&](Component &&c) {501                             return CompleteSubscripts(502                                 ArrayRef{std::move(c), std::move(subscripts)});503                           },504                           [&](auto &&) -> MaybeExpr {505                             DIE("bad base for ArrayRef");506                             return std::nullopt;507                           },508                       },509      std::move(dataRef.u));510}511 512// C919a - only one part-ref of a data-ref may have rank > 0513bool ExpressionAnalyzer::CheckRanks(const DataRef &dataRef) {514  return common::visit(515      common::visitors{516          [this](const Component &component) {517            const Symbol &symbol{component.GetLastSymbol()};518            if (int componentRank{symbol.Rank()}; componentRank > 0) {519              if (int baseRank{component.base().Rank()}; baseRank > 0) {520                Say("Reference to whole rank-%d component '%s' of rank-%d array of derived type is not allowed"_err_en_US,521                    componentRank, symbol.name(), baseRank);522                return false;523              }524            } else {525              return CheckRanks(component.base());526            }527            return true;528          },529          [this](const ArrayRef &arrayRef) {530            if (const auto *component{arrayRef.base().UnwrapComponent()}) {531              int subscriptRank{0};532              for (const Subscript &subscript : arrayRef.subscript()) {533                subscriptRank += subscript.Rank();534              }535              if (subscriptRank > 0) {536                if (int componentBaseRank{component->base().Rank()};537                    componentBaseRank > 0) {538                  Say("Subscripts of component '%s' of rank-%d derived type array have rank %d but must all be scalar"_err_en_US,539                      component->GetLastSymbol().name(), componentBaseRank,540                      subscriptRank);541                  return false;542                }543              } else {544                return CheckRanks(component->base());545              }546            }547            return true;548          },549          [](const SymbolRef &) { return true; },550          [](const CoarrayRef &) { return true; },551      },552      dataRef.u);553}554 555// C911 - if the last name in a data-ref has an abstract derived type,556// it must also be polymorphic.557bool ExpressionAnalyzer::CheckPolymorphic(const DataRef &dataRef) {558  if (auto type{DynamicType::From(dataRef.GetLastSymbol())}) {559    if (type->category() == TypeCategory::Derived && !type->IsPolymorphic()) {560      const Symbol &typeSymbol{561          type->GetDerivedTypeSpec().typeSymbol().GetUltimate()};562      if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) {563        AttachDeclaration(564            Say("Reference to object with abstract derived type '%s' must be polymorphic"_err_en_US,565                typeSymbol.name()),566            typeSymbol);567        return false;568      }569    }570  }571  return true;572}573 574bool ExpressionAnalyzer::CheckDataRef(const DataRef &dataRef) {575  // Always check both, don't short-circuit576  bool ranksOk{CheckRanks(dataRef)};577  bool polyOk{CheckPolymorphic(dataRef)};578  return ranksOk && polyOk;579}580 581// Parse tree correction after a substring S(j:k) was misparsed as an582// array section.  Fortran substrings must have a range, not a583// single index.584static std::optional<parser::Substring> FixMisparsedSubstringDataRef(585    parser::DataRef &dataRef) {586  if (auto *ae{587          std::get_if<common::Indirection<parser::ArrayElement>>(&dataRef.u)}) {588    // ...%a(j:k) and "a" is a character scalar589    parser::ArrayElement &arrElement{ae->value()};590    if (arrElement.subscripts.size() == 1) {591      if (auto *triplet{std::get_if<parser::SubscriptTriplet>(592              &arrElement.subscripts.front().u)}) {593        if (!std::get<2 /*stride*/>(triplet->t).has_value()) {594          if (const Symbol *symbol{595                  parser::GetLastName(arrElement.base).symbol}) {596            const Symbol &ultimate{symbol->GetUltimate()};597            if (const semantics::DeclTypeSpec *type{ultimate.GetType()}) {598              if (ultimate.Rank() == 0 &&599                  type->category() == semantics::DeclTypeSpec::Character) {600                // The ambiguous S(j:k) was parsed as an array section601                // reference, but it's now clear that it's a substring.602                // Fix the parse tree in situ.603                return arrElement.ConvertToSubstring();604              }605            }606          }607        }608      }609    }610  }611  return std::nullopt;612}613 614// When a designator is a misparsed type-param-inquiry of a misparsed615// substring -- it looks like a structure component reference of an array616// slice -- fix the substring and then convert to an intrinsic function617// call to KIND() or LEN().  And when the designator is a misparsed618// substring, convert it into a substring reference in place.619MaybeExpr ExpressionAnalyzer::FixMisparsedSubstring(620    const parser::Designator &d) {621  auto &mutate{const_cast<parser::Designator &>(d)};622  if (auto *dataRef{std::get_if<parser::DataRef>(&mutate.u)}) {623    if (auto *sc{std::get_if<common::Indirection<parser::StructureComponent>>(624            &dataRef->u)}) {625      parser::StructureComponent &structComponent{sc->value()};626      parser::CharBlock which{structComponent.component.source};627      if (which == "kind" || which == "len") {628        if (auto substring{629                FixMisparsedSubstringDataRef(structComponent.base)}) {630          // ...%a(j:k)%kind or %len and "a" is a character scalar631          mutate.u = std::move(*substring);632          if (MaybeExpr substringExpr{Analyze(d)}) {633            return MakeFunctionRef(which,634                ActualArguments{ActualArgument{std::move(*substringExpr)}});635          }636        }637      }638    } else if (auto substring{FixMisparsedSubstringDataRef(*dataRef)}) {639      mutate.u = std::move(*substring);640    }641  }642  return std::nullopt;643}644 645MaybeExpr ExpressionAnalyzer::Analyze(const parser::Designator &d) {646  auto restorer{GetContextualMessages().SetLocation(d.source)};647  if (auto substringInquiry{FixMisparsedSubstring(d)}) {648    return substringInquiry;649  }650  // These checks have to be deferred to these "top level" data-refs where651  // we can be sure that there are no following subscripts (yet).652  MaybeExpr result{Analyze(d.u)};653  if (result) {654    std::optional<DataRef> dataRef{ExtractDataRef(std::move(result))};655    if (!dataRef) {656      dataRef = ExtractDataRef(std::move(result), /*intoSubstring=*/true);657    }658    if (!dataRef) {659      dataRef = ExtractDataRef(std::move(result),660          /*intoSubstring=*/false, /*intoComplexPart=*/true);661    }662    if (dataRef) {663      if (!CheckDataRef(*dataRef)) {664        result.reset();665      } else if (ExtractCoarrayRef(*dataRef).has_value()) {666        if (auto dyType{result->GetType()};667            dyType && dyType->category() == TypeCategory::Derived) {668          if (!std::holds_alternative<CoarrayRef>(dataRef->u) &&669              dyType->IsPolymorphic()) { // F'2023 C918670            Say("The base of a polymorphic object may not be coindexed"_err_en_US);671          }672          if (const auto *derived{GetDerivedTypeSpec(*dyType)}) {673            if (auto bad{FindPolymorphicAllocatablePotentialComponent(674                    *derived)}) { // F'2023 C917675              Say("A coindexed designator may not have a type with the polymorphic potential subobject component '%s'"_err_en_US,676                  bad.BuildResultDesignatorName());677            }678          }679        }680      }681    }682  }683  return result;684}685 686// A utility subroutine to repackage optional expressions of various levels687// of type specificity as fully general MaybeExpr values.688template <typename A> common::IfNoLvalue<MaybeExpr, A> AsMaybeExpr(A &&x) {689  return AsGenericExpr(std::move(x));690}691template <typename A> MaybeExpr AsMaybeExpr(std::optional<A> &&x) {692  if (x) {693    return AsMaybeExpr(std::move(*x));694  }695  return std::nullopt;696}697 698// Type kind parameter values for literal constants.699int ExpressionAnalyzer::AnalyzeKindParam(700    const std::optional<parser::KindParam> &kindParam, int defaultKind) {701  if (!kindParam) {702    return defaultKind;703  }704  std::int64_t kind{common::visit(705      common::visitors{706          [](std::uint64_t k) { return static_cast<std::int64_t>(k); },707          [&](const parser::Scalar<708              parser::Integer<parser::Constant<parser::Name>>> &n) {709            if (MaybeExpr ie{Analyze(n)}) {710              return ToInt64(*ie).value_or(defaultKind);711            }712            return static_cast<std::int64_t>(defaultKind);713          },714      },715      kindParam->u)};716  if (kind != static_cast<int>(kind)) {717    Say("Unsupported type kind value (%jd)"_err_en_US,718        static_cast<std::intmax_t>(kind));719    kind = defaultKind;720  }721  return static_cast<int>(kind);722}723 724// Common handling of parser::IntLiteralConstant, SignedIntLiteralConstant,725// and UnsignedLiteralConstant726template <typename TYPES, TypeCategory CAT> struct IntTypeVisitor {727  using Result = MaybeExpr;728  using Types = TYPES;729  template <typename T> Result Test() {730    if (T::kind >= kind) {731      const char *p{digits.begin()};732      using Int = typename T::Scalar;733      typename Int::ValueWithOverflow num{0, false};734      const char *typeName{735          CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};736      if (isNegated) {737        auto unsignedNum{Int::Read(p, 10, false /*unsigned*/)};738        num.value = unsignedNum.value.Negate().value;739        num.overflow = unsignedNum.overflow ||740            (CAT == TypeCategory::Integer && num.value > Int{0});741        if (!num.overflow && num.value.Negate().overflow) {742          analyzer.Warn(LanguageFeature::BigIntLiterals, digits,743              "negated maximum INTEGER(KIND=%d) literal"_port_en_US, T::kind);744        }745      } else {746        num = Int::Read(p, 10, /*isSigned=*/CAT == TypeCategory::Integer);747      }748      if (num.overflow) {749        if constexpr (CAT == TypeCategory::Unsigned) {750          analyzer.Warn(common::UsageWarning::UnsignedLiteralTruncation,751              "Unsigned literal too large for UNSIGNED(KIND=%d); truncated"_warn_en_US,752              kind);753          return Expr<SomeType>{754              Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};755        }756      } else {757        if (T::kind > kind) {758          if (!isDefaultKind ||759              !analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {760            return std::nullopt;761          } else {762            analyzer.Warn(LanguageFeature::BigIntLiterals, digits,763                "Integer literal is too large for default %s(KIND=%d); "764                "assuming %s(KIND=%d)"_port_en_US,765                typeName, kind, typeName, T::kind);766          }767        }768        return Expr<SomeType>{769            Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};770      }771    }772    return std::nullopt;773  }774  ExpressionAnalyzer &analyzer;775  parser::CharBlock digits;776  std::int64_t kind;777  bool isDefaultKind;778  bool isNegated;779};780 781template <typename TYPES, TypeCategory CAT, typename PARSED>782MaybeExpr ExpressionAnalyzer::IntLiteralConstant(783    const PARSED &x, bool isNegated) {784  const auto &kindParam{std::get<std::optional<parser::KindParam>>(x.t)};785  bool isDefaultKind{!kindParam};786  int kind{AnalyzeKindParam(kindParam, GetDefaultKind(CAT))};787  const char *typeName{CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};788  if (CheckIntrinsicKind(CAT, kind)) {789    auto digits{std::get<parser::CharBlock>(x.t)};790    if (MaybeExpr result{common::SearchTypes(IntTypeVisitor<TYPES, CAT>{791            *this, digits, kind, isDefaultKind, isNegated})}) {792      return result;793    } else if (isDefaultKind) {794      Say(digits,795          "Integer literal is too large for any allowable kind of %s"_err_en_US,796          typeName);797    } else {798      Say(digits, "Integer literal is too large for %s(KIND=%d)"_err_en_US,799          typeName, kind);800    }801  }802  return std::nullopt;803}804 805MaybeExpr ExpressionAnalyzer::Analyze(806    const parser::IntLiteralConstant &x, bool isNegated) {807  auto restorer{808      GetContextualMessages().SetLocation(std::get<parser::CharBlock>(x.t))};809  return IntLiteralConstant<IntegerTypes, TypeCategory::Integer>(x, isNegated);810}811 812MaybeExpr ExpressionAnalyzer::Analyze(813    const parser::SignedIntLiteralConstant &x) {814  auto restorer{GetContextualMessages().SetLocation(x.source)};815  return IntLiteralConstant<IntegerTypes, TypeCategory::Integer>(x);816}817 818MaybeExpr ExpressionAnalyzer::Analyze(819    const parser::UnsignedLiteralConstant &x) {820  parser::CharBlock at{std::get<parser::CharBlock>(x.t)};821  auto restorer{GetContextualMessages().SetLocation(at)};822  if (!context().IsEnabled(common::LanguageFeature::Unsigned) &&823      !context().AnyFatalError()) {824    context().Say(825        at, "-funsigned is required to enable UNSIGNED constants"_err_en_US);826  }827  return IntLiteralConstant<UnsignedTypes, TypeCategory::Unsigned>(x);828}829 830template <typename TYPE>831Constant<TYPE> ReadRealLiteral(832    parser::CharBlock source, FoldingContext &context, bool isDefaultKind) {833  const char *p{source.begin()};834  auto valWithFlags{835      Scalar<TYPE>::Read(p, context.targetCharacteristics().roundingMode())};836  CHECK(p == source.end());837  context.RealFlagWarnings(valWithFlags.flags, "conversion of REAL literal");838  auto value{valWithFlags.value};839  if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {840    value = value.FlushSubnormalToZero();841  }842  typename Constant<TYPE>::Result resultInfo;843  resultInfo.set_isFromInexactLiteralConversion(844      isDefaultKind && valWithFlags.flags.test(RealFlag::Inexact));845  return {value, resultInfo};846}847 848struct RealTypeVisitor {849  using Result = std::optional<Expr<SomeReal>>;850  using Types = RealTypes;851 852  RealTypeVisitor(853      int k, parser::CharBlock lit, FoldingContext &ctx, bool isDeftKind)854      : kind{k}, literal{lit}, context{ctx}, isDefaultKind{isDeftKind} {}855 856  template <typename T> Result Test() {857    if (kind == T::kind) {858      return {859          AsCategoryExpr(ReadRealLiteral<T>(literal, context, isDefaultKind))};860    }861    return std::nullopt;862  }863 864  int kind;865  parser::CharBlock literal;866  FoldingContext &context;867  bool isDefaultKind;868};869 870// Reads a real literal constant and encodes it with the right kind.871MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {872  // Use a local message context around the real literal for better873  // provenance on any messages.874  auto restorer{GetContextualMessages().SetLocation(x.real.source)};875  // If a kind parameter appears, it defines the kind of the literal and the876  // letter used in an exponent part must be 'E' (e.g., the 'E' in877  // "6.02214E+23").  In the absence of an explicit kind parameter, any878  // exponent letter determines the kind.  Otherwise, defaults apply.879  auto &defaults{context_.defaultKinds()};880  int defaultKind{defaults.GetDefaultKind(TypeCategory::Real)};881  const char *end{x.real.source.end()};882  char expoLetter{' '};883  std::optional<int> letterKind;884  for (const char *p{x.real.source.begin()}; p < end; ++p) {885    if (parser::IsLetter(*p)) {886      expoLetter = *p;887      switch (expoLetter) {888      case 'e':889        letterKind = defaults.GetDefaultKind(TypeCategory::Real);890        break;891      case 'd':892        letterKind = defaults.doublePrecisionKind();893        break;894      case 'q':895        letterKind = defaults.quadPrecisionKind();896        break;897      default:898        Say("Unknown exponent letter '%c'"_err_en_US, expoLetter);899      }900      break;901    }902  }903  if (letterKind) {904    defaultKind = *letterKind;905  }906  // C716 requires 'E' as an exponent.907  // Extension: allow exponent-letter matching the kind-param.908  auto kind{AnalyzeKindParam(x.kind, defaultKind)};909  if (letterKind && expoLetter != 'e') {910    if (kind != *letterKind) {911      Warn(common::LanguageFeature::ExponentMatchingKindParam,912          "Explicit kind parameter on real constant disagrees with exponent letter '%c'"_warn_en_US,913          expoLetter);914    } else if (x.kind) {915      Warn(common::LanguageFeature::ExponentMatchingKindParam,916          "Explicit kind parameter together with non-'E' exponent letter is not standard"_port_en_US);917    }918  }919  bool isDefaultKind{!x.kind && letterKind.value_or('e') == 'e'};920  auto result{common::SearchTypes(RealTypeVisitor{921      kind, x.real.source, GetFoldingContext(), isDefaultKind})};922  if (!result) { // C717923    Say("Unsupported REAL(KIND=%d)"_err_en_US, kind);924  }925  return AsMaybeExpr(std::move(result));926}927 928MaybeExpr ExpressionAnalyzer::Analyze(929    const parser::SignedRealLiteralConstant &x) {930  if (auto result{Analyze(std::get<parser::RealLiteralConstant>(x.t))}) {931    auto &realExpr{std::get<Expr<SomeReal>>(result->u)};932    if (auto sign{std::get<std::optional<parser::Sign>>(x.t)}) {933      if (sign == parser::Sign::Negative) {934        return AsGenericExpr(-std::move(realExpr));935      }936    }937    return result;938  }939  return std::nullopt;940}941 942MaybeExpr ExpressionAnalyzer::Analyze(943    const parser::SignedComplexLiteralConstant &x) {944  auto result{Analyze(std::get<parser::ComplexLiteralConstant>(x.t))};945  if (!result) {946    return std::nullopt;947  } else if (std::get<parser::Sign>(x.t) == parser::Sign::Negative) {948    return AsGenericExpr(-std::move(std::get<Expr<SomeComplex>>(result->u)));949  } else {950    return result;951  }952}953 954MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexPart &x) {955  return Analyze(x.u);956}957 958MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexLiteralConstant &z) {959  return AnalyzeComplex(Analyze(std::get<0>(z.t)), Analyze(std::get<1>(z.t)),960      "complex literal constant");961}962 963// CHARACTER literal processing.964MaybeExpr ExpressionAnalyzer::AnalyzeString(std::string &&string, int kind) {965  if (!CheckIntrinsicKind(TypeCategory::Character, kind)) {966    return std::nullopt;967  }968  switch (kind) {969  case 1:970    return AsGenericExpr(Constant<Type<TypeCategory::Character, 1>>{971        parser::DecodeString<std::string, parser::Encoding::LATIN_1>(972            string, true)});973  case 2:974    return AsGenericExpr(Constant<Type<TypeCategory::Character, 2>>{975        parser::DecodeString<std::u16string, parser::Encoding::UTF_8>(976            string, true)});977  case 4:978    return AsGenericExpr(Constant<Type<TypeCategory::Character, 4>>{979        parser::DecodeString<std::u32string, parser::Encoding::UTF_8>(980            string, true)});981  default:982    CRASH_NO_CASE;983  }984}985 986MaybeExpr ExpressionAnalyzer::Analyze(const parser::CharLiteralConstant &x) {987  int kind{988      AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t), 1)};989  auto value{std::get<std::string>(x.t)};990  return AnalyzeString(std::move(value), kind);991}992 993MaybeExpr ExpressionAnalyzer::Analyze(994    const parser::HollerithLiteralConstant &x) {995  int kind{GetDefaultKind(TypeCategory::Character)};996  auto result{AnalyzeString(std::string{x.v}, kind)};997  if (auto *constant{UnwrapConstantValue<Ascii>(result)}) {998    constant->set_wasHollerith(true);999  }1000  return result;1001}1002 1003// .TRUE. and .FALSE. of various kinds1004MaybeExpr ExpressionAnalyzer::Analyze(const parser::LogicalLiteralConstant &x) {1005  auto kind{AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t),1006      GetDefaultKind(TypeCategory::Logical))};1007  bool value{std::get<bool>(x.t)};1008  auto result{common::SearchTypes(1009      TypeKindVisitor<TypeCategory::Logical, Constant, bool>{1010          kind, std::move(value)})};1011  if (!result) {1012    Say("unsupported LOGICAL(KIND=%d)"_err_en_US, kind); // C7281013  }1014  return result;1015}1016 1017// BOZ typeless literals1018MaybeExpr ExpressionAnalyzer::Analyze(const parser::BOZLiteralConstant &x) {1019  const char *p{x.v.c_str()};1020  std::uint64_t base{16};1021  switch (*p++) {1022  case 'b':1023    base = 2;1024    break;1025  case 'o':1026    base = 8;1027    break;1028  case 'z':1029    break;1030  case 'x':1031    break;1032  default:1033    CRASH_NO_CASE;1034  }1035  CHECK(*p == '"');1036  ++p;1037  auto value{BOZLiteralConstant::Read(p, base, false /*unsigned*/)};1038  if (*p != '"') {1039    Say("Invalid digit ('%c') in BOZ literal '%s'"_err_en_US, *p,1040        x.v); // C7107, C71081041    return std::nullopt;1042  }1043  if (value.overflow) {1044    Say("BOZ literal '%s' too large"_err_en_US, x.v);1045    return std::nullopt;1046  }1047  return AsGenericExpr(std::move(value.value));1048}1049 1050// Names and named constants1051MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {1052  auto restorer{GetContextualMessages().SetLocation(n.source)};1053  if (std::optional<int> kind{IsImpliedDo(n.source)}) {1054    return AsMaybeExpr(ConvertToKind<TypeCategory::Integer>(1055        *kind, AsExpr(ImpliedDoIndex{n.source})));1056  }1057  if (context_.HasError(n.symbol)) { // includes case of no symbol1058    return std::nullopt;1059  } else {1060    const Symbol &ultimate{n.symbol->GetUltimate()};1061    if (ultimate.has<semantics::TypeParamDetails>()) {1062      // A bare reference to a derived type parameter within a parameterized1063      // derived type definition.1064      auto dyType{DynamicType::From(ultimate)};1065      if (!dyType) {1066        // When the integer kind of this type parameter is not known now,1067        // it's either an error or because it depends on earlier-declared kind1068        // type parameters.  So assume that it's a subscript integer for now1069        // while processing other specification expressions in the PDT1070        // definition; the right kind value will be used later in each of its1071        // instantiations.1072        int kind{SubscriptInteger::kind};1073        if (const auto *typeSpec{ultimate.GetType()}) {1074          if (const semantics::IntrinsicTypeSpec *1075              intrinType{typeSpec->AsIntrinsic()}) {1076            if (auto k{ToInt64(Fold(semantics::KindExpr{intrinType->kind()}))};1077                k &&1078                common::IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {1079              kind = *k;1080            }1081          }1082        }1083        dyType = DynamicType{TypeCategory::Integer, kind};1084      }1085      return Fold(ConvertToType(1086          *dyType, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));1087    } else {1088      if (n.symbol->attrs().test(semantics::Attr::VOLATILE)) {1089        if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(1090                context_.FindScope(n.source))}) {1091          SayAt(n,1092              "VOLATILE variable '%s' may not be referenced in pure subprogram '%s'"_err_en_US,1093              n.source, DEREF(pure->symbol()).name());1094          n.symbol->attrs().reset(semantics::Attr::VOLATILE);1095        }1096      }1097      CheckForWholeAssumedSizeArray(n.source, n.symbol);1098      return Designate(DataRef{*n.symbol});1099    }1100  }1101}1102 1103void ExpressionAnalyzer::CheckForWholeAssumedSizeArray(1104    parser::CharBlock at, const Symbol *symbol) {1105  if (!isWholeAssumedSizeArrayOk_ && symbol &&1106      semantics::IsAssumedSizeArray(ResolveAssociations(*symbol))) {1107    AttachDeclaration(1108        SayAt(at,1109            "Whole assumed-size array '%s' may not appear here without subscripts"_err_en_US,1110            symbol->name()),1111        *symbol);1112  }1113}1114 1115MaybeExpr ExpressionAnalyzer::Analyze(const parser::NamedConstant &n) {1116  auto restorer{GetContextualMessages().SetLocation(n.v.source)};1117  if (MaybeExpr value{Analyze(n.v)}) {1118    Expr<SomeType> folded{Fold(std::move(*value))};1119    if (IsConstantExpr(folded)) {1120      return folded;1121    }1122    Say(n.v.source, "must be a constant"_err_en_US); // C7181123  }1124  return std::nullopt;1125}1126 1127MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &n) {1128  auto restorer{AllowNullPointer()};1129  if (MaybeExpr value{Analyze(n.v.value())}) {1130    // Subtle: when the NullInit is a DataStmtConstant, it might1131    // be a misparse of a structure constructor without parameters1132    // or components (e.g., T()).  Checking the result to ensure1133    // that a "=>" data entity initializer actually resolved to1134    // a null pointer has to be done by the caller.1135    return Fold(std::move(*value));1136  }1137  return std::nullopt;1138}1139 1140MaybeExpr ExpressionAnalyzer::Analyze(1141    const parser::StmtFunctionStmt &stmtFunc) {1142  inStmtFunctionDefinition_ = true;1143  return Analyze(std::get<parser::Scalar<parser::Expr>>(stmtFunc.t));1144}1145 1146MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) {1147  return Analyze(x.value());1148}1149 1150MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) {1151  if (const auto &repeat{1152          std::get<std::optional<parser::DataStmtRepeat>>(x.t)}) {1153    x.repetitions = -1;1154    if (MaybeExpr expr{Analyze(repeat->u)}) {1155      Expr<SomeType> folded{Fold(std::move(*expr))};1156      if (auto value{ToInt64(folded)}) {1157        if (*value >= 0) { // C8821158          x.repetitions = *value;1159        } else {1160          Say(FindSourceLocation(repeat),1161              "Repeat count (%jd) for data value must not be negative"_err_en_US,1162              *value);1163        }1164      }1165    }1166  }1167  return Analyze(std::get<parser::DataStmtConstant>(x.t));1168}1169 1170// Substring references1171std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::GetSubstringBound(1172    const std::optional<parser::ScalarIntExpr> &bound) {1173  if (bound) {1174    if (MaybeExpr expr{Analyze(*bound)}) {1175      if (expr->Rank() > 1) {1176        Say("substring bound expression has rank %d"_err_en_US, expr->Rank());1177      }1178      if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {1179        if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {1180          return {std::move(*ssIntExpr)};1181        }1182        return {Expr<SubscriptInteger>{1183            Convert<SubscriptInteger, TypeCategory::Integer>{1184                std::move(*intExpr)}}};1185      } else {1186        Say("substring bound expression is not INTEGER"_err_en_US);1187      }1188    }1189  }1190  return std::nullopt;1191}1192 1193MaybeExpr ExpressionAnalyzer::Analyze(const parser::Substring &ss) {1194  if (MaybeExpr baseExpr{Analyze(std::get<parser::DataRef>(ss.t))}) {1195    if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(*baseExpr))}) {1196      if (MaybeExpr newBaseExpr{Designate(std::move(*dataRef))}) {1197        if (std::optional<DataRef> checked{1198                ExtractDataRef(std::move(*newBaseExpr))}) {1199          const parser::SubstringRange &range{1200              std::get<parser::SubstringRange>(ss.t)};1201          std::optional<Expr<SubscriptInteger>> first{1202              Fold(GetSubstringBound(std::get<0>(range.t)))};1203          std::optional<Expr<SubscriptInteger>> last{1204              Fold(GetSubstringBound(std::get<1>(range.t)))};1205          const Symbol &symbol{checked->GetLastSymbol()};1206          if (std::optional<DynamicType> dynamicType{1207                  DynamicType::From(symbol)}) {1208            if (dynamicType->category() == TypeCategory::Character) {1209              auto lbValue{ToInt64(first)};1210              if (!lbValue) {1211                lbValue = 1;1212              }1213              auto ubValue{ToInt64(last)};1214              auto len{dynamicType->knownLength()};1215              if (!ubValue) {1216                ubValue = len;1217              }1218              if (lbValue && ubValue && *lbValue > *ubValue) {1219                // valid, substring is empty1220              } else if (lbValue && *lbValue < 1 && (ubValue || !last)) {1221                Say("Substring must begin at 1 or later, not %jd"_err_en_US,1222                    static_cast<std::intmax_t>(*lbValue));1223                return std::nullopt;1224              } else if (ubValue && len && *ubValue > *len &&1225                  (lbValue || !first)) {1226                Say("Substring must end at %zd or earlier, not %jd"_err_en_US,1227                    static_cast<std::intmax_t>(*len),1228                    static_cast<std::intmax_t>(*ubValue));1229                return std::nullopt;1230              }1231              return WrapperHelper<TypeCategory::Character, Designator,1232                  Substring>(dynamicType->kind(),1233                  Substring{std::move(checked.value()), std::move(first),1234                      std::move(last)});1235            }1236          }1237          Say("substring may apply only to CHARACTER"_err_en_US);1238        }1239      }1240    }1241  }1242  return std::nullopt;1243}1244 1245// CHARACTER literal substrings1246MaybeExpr ExpressionAnalyzer::Analyze(1247    const parser::CharLiteralConstantSubstring &x) {1248  const parser::SubstringRange &range{std::get<parser::SubstringRange>(x.t)};1249  std::optional<Expr<SubscriptInteger>> lower{1250      GetSubstringBound(std::get<0>(range.t))};1251  std::optional<Expr<SubscriptInteger>> upper{1252      GetSubstringBound(std::get<1>(range.t))};1253  if (MaybeExpr string{Analyze(std::get<parser::CharLiteralConstant>(x.t))}) {1254    if (auto *charExpr{std::get_if<Expr<SomeCharacter>>(&string->u)}) {1255      Expr<SubscriptInteger> length{1256          common::visit([](const auto &ckExpr) { return ckExpr.LEN().value(); },1257              charExpr->u)};1258      if (!lower) {1259        lower = Expr<SubscriptInteger>{1};1260      }1261      if (!upper) {1262        upper = Expr<SubscriptInteger>{1263            static_cast<std::int64_t>(ToInt64(length).value())};1264      }1265      return common::visit(1266          [&](auto &&ckExpr) -> MaybeExpr {1267            using Result = ResultType<decltype(ckExpr)>;1268            auto *cp{std::get_if<Constant<Result>>(&ckExpr.u)};1269            CHECK(DEREF(cp).size() == 1);1270            StaticDataObject::Pointer staticData{StaticDataObject::Create()};1271            staticData->set_alignment(Result::kind)1272                .set_itemBytes(Result::kind)1273                .Push(cp->GetScalarValue().value(),1274                    foldingContext_.targetCharacteristics().isBigEndian());1275            Substring substring{std::move(staticData), std::move(lower.value()),1276                std::move(upper.value())};1277            return AsGenericExpr(1278                Expr<Result>{Designator<Result>{std::move(substring)}});1279          },1280          std::move(charExpr->u));1281    }1282  }1283  return std::nullopt;1284}1285 1286// substring%KIND/LEN1287MaybeExpr ExpressionAnalyzer::Analyze(const parser::SubstringInquiry &x) {1288  if (MaybeExpr substring{Analyze(x.v)}) {1289    CHECK(x.source.size() >= 8);1290    int nameLen{x.source.back() == 'n' ? 3 /*LEN*/ : 4 /*KIND*/};1291    parser::CharBlock name{1292        x.source.end() - nameLen, static_cast<std::size_t>(nameLen)};1293    CHECK(name == "len" || name == "kind");1294    return MakeFunctionRef(1295        name, ActualArguments{ActualArgument{std::move(*substring)}});1296  } else {1297    return std::nullopt;1298  }1299}1300 1301// Subscripted array references1302std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::AsSubscript(1303    MaybeExpr &&expr) {1304  if (expr) {1305    if (expr->Rank() > 1) {1306      Say("Subscript expression has rank %d greater than 1"_err_en_US,1307          expr->Rank());1308    }1309    if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {1310      if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {1311        return std::move(*ssIntExpr);1312      } else {1313        return Expr<SubscriptInteger>{1314            Convert<SubscriptInteger, TypeCategory::Integer>{1315                std::move(*intExpr)}};1316      }1317    } else {1318      Say("Subscript expression is not INTEGER"_err_en_US);1319    }1320  }1321  return std::nullopt;1322}1323 1324std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::TripletPart(1325    const std::optional<parser::Subscript> &s) {1326  if (s) {1327    return AsSubscript(Analyze(*s));1328  } else {1329    return std::nullopt;1330  }1331}1332 1333std::optional<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscript(1334    const parser::SectionSubscript &ss) {1335  return common::visit(1336      common::visitors{1337          [&](const parser::SubscriptTriplet &t) -> std::optional<Subscript> {1338            const auto &lower{std::get<0>(t.t)};1339            const auto &upper{std::get<1>(t.t)};1340            const auto &stride{std::get<2>(t.t)};1341            auto result{Triplet{1342                TripletPart(lower), TripletPart(upper), TripletPart(stride)}};1343            if ((lower && !result.lower()) || (upper && !result.upper())) {1344              return std::nullopt;1345            } else {1346              return std::make_optional<Subscript>(result);1347            }1348          },1349          [&](const auto &s) -> std::optional<Subscript> {1350            if (auto subscriptExpr{AsSubscript(Analyze(s))}) {1351              return Subscript{std::move(*subscriptExpr)};1352            } else {1353              return std::nullopt;1354            }1355          },1356      },1357      ss.u);1358}1359 1360// Empty result means an error occurred1361std::vector<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscripts(1362    const std::list<parser::SectionSubscript> &sss) {1363  bool error{false};1364  std::vector<Subscript> subscripts;1365  for (const auto &s : sss) {1366    if (auto subscript{AnalyzeSectionSubscript(s)}) {1367      subscripts.emplace_back(std::move(*subscript));1368    } else {1369      error = true;1370    }1371  }1372  return !error ? subscripts : std::vector<Subscript>{};1373}1374 1375MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayElement &ae) {1376  MaybeExpr baseExpr;1377  {1378    auto restorer{AllowWholeAssumedSizeArray()};1379    baseExpr = Analyze(ae.base);1380  }1381  if (baseExpr) {1382    if (ae.subscripts.empty()) {1383      // will be converted to function call later or error reported1384    } else if (baseExpr->Rank() == 0) {1385      if (const Symbol *symbol{GetLastSymbol(*baseExpr)}) {1386        if (!context_.HasError(symbol)) {1387          if (inDataStmtConstant_) {1388            // Better error for NULL(X) with a MOLD= argument1389            Say("'%s' must be an array or structure constructor if used with non-empty parentheses as a DATA statement constant"_err_en_US,1390                symbol->name());1391          } else {1392            Say("'%s' is not an array"_err_en_US, symbol->name());1393          }1394          context_.SetError(*symbol);1395        }1396      }1397    } else if (std::optional<DataRef> dataRef{1398                   ExtractDataRef(std::move(*baseExpr))}) {1399      return ApplySubscripts(1400          std::move(*dataRef), AnalyzeSectionSubscripts(ae.subscripts));1401    } else {1402      Say("Subscripts may be applied only to an object, component, or array constant"_err_en_US);1403    }1404  }1405  // error was reported: analyze subscripts without reporting more errors1406  auto restorer{GetContextualMessages().DiscardMessages()};1407  AnalyzeSectionSubscripts(ae.subscripts);1408  return std::nullopt;1409}1410 1411// Type parameter inquiries apply to data references, but don't depend1412// on any trailing (co)subscripts.1413static NamedEntity IgnoreAnySubscripts(Designator<SomeDerived> &&designator) {1414  return common::visit(1415      common::visitors{1416          [](SymbolRef &&symbol) { return NamedEntity{symbol}; },1417          [](Component &&component) {1418            return NamedEntity{std::move(component)};1419          },1420          [](ArrayRef &&arrayRef) { return std::move(arrayRef.base()); },1421          [](CoarrayRef &&coarrayRef) {1422            return NamedEntity{coarrayRef.GetLastSymbol()};1423          },1424      },1425      std::move(designator.u));1426}1427 1428// Components, but not bindings, of parent derived types are explicitly1429// represented as such.1430std::optional<Component> ExpressionAnalyzer::CreateComponent(DataRef &&base,1431    const Symbol &component, const semantics::Scope &scope,1432    bool C919bAlreadyEnforced) {1433  if (!C919bAlreadyEnforced && IsAllocatableOrPointer(component) &&1434      base.Rank() > 0) { // C919b1435    Say("An allocatable or pointer component reference must be applied to a scalar base"_err_en_US);1436  }1437  if (&component.owner() == &scope ||1438      component.has<semantics::ProcBindingDetails>()) {1439    return Component{std::move(base), component};1440  }1441  if (const Symbol *typeSymbol{scope.GetSymbol()}) {1442    if (const Symbol *parentComponent{typeSymbol->GetParentComponent(&scope)}) {1443      if (const auto *object{1444              parentComponent->detailsIf<semantics::ObjectEntityDetails>()}) {1445        if (const auto *parentType{object->type()}) {1446          if (const semantics::Scope *parentScope{1447                  parentType->derivedTypeSpec().scope()}) {1448            return CreateComponent(1449                DataRef{Component{std::move(base), *parentComponent}},1450                component, *parentScope, C919bAlreadyEnforced);1451          }1452        }1453      }1454    }1455  }1456  return std::nullopt;1457}1458 1459// Derived type component references and type parameter inquiries1460MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {1461  Symbol *sym{sc.component.symbol};1462  if (context_.HasError(sym)) {1463    return std::nullopt;1464  }1465  const auto *misc{sym->detailsIf<semantics::MiscDetails>()};1466  bool isTypeParamInquiry{sym->has<semantics::TypeParamDetails>() ||1467      (misc &&1468          (misc->kind() == semantics::MiscDetails::Kind::KindParamInquiry ||1469              misc->kind() == semantics::MiscDetails::Kind::LenParamInquiry))};1470  MaybeExpr base;1471  if (isTypeParamInquiry) {1472    auto restorer{AllowWholeAssumedSizeArray()};1473    base = Analyze(sc.base);1474  } else {1475    base = Analyze(sc.base);1476  }1477  if (!base) {1478    return std::nullopt;1479  }1480  const auto &name{sc.component.source};1481  if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {1482    const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};1483    if (isTypeParamInquiry) {1484      if (auto *designator{UnwrapExpr<Designator<SomeDerived>>(*dtExpr)}) {1485        if (std::optional<DynamicType> dyType{DynamicType::From(*sym)}) {1486          if (dyType->category() == TypeCategory::Integer) {1487            auto restorer{GetContextualMessages().SetLocation(name)};1488            return Fold(ConvertToType(*dyType,1489                AsGenericExpr(TypeParamInquiry{1490                    IgnoreAnySubscripts(std::move(*designator)), *sym})));1491          }1492        }1493        Say(name, "Type parameter is not INTEGER"_err_en_US);1494      } else {1495        Say(name,1496            "A type parameter inquiry must be applied to a designator"_err_en_US);1497      }1498    } else if (!dtSpec || !dtSpec->scope()) {1499      CHECK(context_.AnyFatalError() || !foldingContext_.messages().empty());1500      return std::nullopt;1501    } else if (std::optional<DataRef> dataRef{1502                   ExtractDataRef(std::move(*dtExpr))}) {1503      auto restorer{GetContextualMessages().SetLocation(name)};1504      if (auto component{1505              CreateComponent(std::move(*dataRef), *sym, *dtSpec->scope())}) {1506        return Designate(DataRef{std::move(*component)});1507      } else {1508        Say(name, "Component is not in scope of derived TYPE(%s)"_err_en_US,1509            dtSpec->typeSymbol().name());1510      }1511    } else {1512      Say(name,1513          "Base of component reference must be a data reference"_err_en_US);1514    }1515  } else if (auto *details{sym->detailsIf<semantics::MiscDetails>()}) {1516    // special part-ref: %re, %im, %kind, %len1517    // Type errors on the base of %re/%im/%len are detected and1518    // reported in name resolution.1519    using MiscKind = semantics::MiscDetails::Kind;1520    MiscKind kind{details->kind()};1521    if (kind == MiscKind::ComplexPartRe || kind == MiscKind::ComplexPartIm) {1522      if (auto *zExpr{std::get_if<Expr<SomeComplex>>(&base->u)}) {1523        if (std::optional<DataRef> dataRef{ExtractDataRef(*zExpr)}) {1524          // Represent %RE/%IM as a designator1525          Expr<SomeReal> realExpr{common::visit(1526              [&](const auto &z) {1527                using PartType = typename ResultType<decltype(z)>::Part;1528                auto part{kind == MiscKind::ComplexPartRe1529                        ? ComplexPart::Part::RE1530                        : ComplexPart::Part::IM};1531                return AsCategoryExpr(Designator<PartType>{1532                    ComplexPart{std::move(*dataRef), part}});1533              },1534              zExpr->u)};1535          return AsGenericExpr(std::move(realExpr));1536        }1537      }1538    } else if (isTypeParamInquiry) { // %kind or %len1539      ActualArgument arg{std::move(*base)};1540      SetArgSourceLocation(arg, name);1541      return MakeFunctionRef(name, ActualArguments{std::move(arg)});1542    } else {1543      DIE("unexpected MiscDetails::Kind");1544    }1545  } else {1546    Say(name, "derived type required before component reference"_err_en_US);1547  }1548  return std::nullopt;1549}1550 1551MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {1552  if (auto dataRef{ExtractDataRef(Analyze(x.base))}) {1553    if (!std::holds_alternative<ArrayRef>(dataRef->u) &&1554        dataRef->GetLastSymbol().Rank() > 0) { // F'2023 C9161555      Say("Subscripts must appear in a coindexed reference when its base is an array"_err_en_US);1556    }1557    std::vector<Expr<SubscriptInteger>> cosubscripts;1558    bool cosubsOk{true};1559    for (const auto &cosub :1560        std::get<std::list<parser::Cosubscript>>(x.imageSelector.t)) {1561      MaybeExpr coex{Analyze(cosub)};1562      if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(coex)}) {1563        cosubscripts.push_back(1564            ConvertToType<SubscriptInteger>(std::move(*intExpr)));1565      } else {1566        cosubsOk = false;1567      }1568    }1569    if (cosubsOk) {1570      int numCosubscripts{static_cast<int>(cosubscripts.size())};1571      const Symbol &symbol{dataRef->GetLastSymbol()};1572      if (numCosubscripts != GetCorank(symbol)) {1573        Say("'%s' has corank %d, but coindexed reference has %d cosubscripts"_err_en_US,1574            symbol.name(), GetCorank(symbol), numCosubscripts);1575      }1576    }1577    CoarrayRef coarrayRef{std::move(*dataRef), std::move(cosubscripts)};1578    for (const auto &imageSelSpec :1579        std::get<std::list<parser::ImageSelectorSpec>>(x.imageSelector.t)) {1580      common::visit(1581          common::visitors{1582              [&](const parser::ImageSelectorSpec::Notify &x) {1583                Analyze(x.v);1584                if (const auto *expr{GetExpr(context_, x.v)}) {1585                  if (coarrayRef.notify()) {1586                    Say("coindexed reference has multiple NOTIFY= specifiers"_err_en_US);1587                  } else if (auto dyType{expr->GetType()};1588                      dyType && IsNotifyType(GetDerivedTypeSpec(*dyType))) {1589                    coarrayRef.set_notify(Expr<SomeType>{*expr});1590                  } else {1591                    Say("NOTIFY= specifier must have type NOTIFY_TYPE from ISO_FORTRAN_ENV"_err_en_US);1592                  }1593                }1594              },1595              [&](const parser::ImageSelectorSpec::Stat &x) {1596                Analyze(x.v);1597                if (const auto *expr{GetExpr(context_, x.v)}) {1598                  if (const auto *intExpr{1599                          std::get_if<Expr<SomeInteger>>(&expr->u)}) {1600                    if (coarrayRef.stat()) {1601                      Say("coindexed reference has multiple STAT= specifiers"_err_en_US);1602                    } else {1603                      coarrayRef.set_stat(Expr<SomeInteger>{*intExpr});1604                    }1605                  }1606                }1607              },1608              [&](const parser::TeamValue &x) {1609                Analyze(x.v);1610                if (const auto *expr{GetExpr(context_, x.v)}) {1611                  if (coarrayRef.team()) {1612                    Say("coindexed reference has multiple TEAM= or TEAM_NUMBER= specifiers"_err_en_US);1613                  } else if (auto dyType{expr->GetType()};1614                      dyType && IsTeamType(GetDerivedTypeSpec(*dyType))) {1615                    coarrayRef.set_team(Expr<SomeType>{*expr});1616                  } else {1617                    Say("TEAM= specifier must have type TEAM_TYPE from ISO_FORTRAN_ENV"_err_en_US);1618                  }1619                }1620              },1621              [&](const parser::ImageSelectorSpec::Team_Number &x) {1622                Analyze(x.v);1623                if (const auto *expr{GetExpr(context_, x.v)}) {1624                  if (coarrayRef.team()) {1625                    Say("coindexed reference has multiple TEAM= or TEAM_NUMBER= specifiers"_err_en_US);1626                  } else {1627                    coarrayRef.set_team(Expr<SomeType>{*expr});1628                  }1629                }1630              }},1631          imageSelSpec.u);1632    }1633    CheckCosubscripts(context_, coarrayRef);1634    return Designate(DataRef{std::move(coarrayRef)});1635  }1636  return std::nullopt;1637}1638 1639int ExpressionAnalyzer::IntegerTypeSpecKind(1640    const parser::IntegerTypeSpec &spec) {1641  Expr<SubscriptInteger> value{1642      AnalyzeKindSelector(TypeCategory::Integer, spec.v)};1643  if (auto kind{ToInt64(value)}) {1644    return static_cast<int>(*kind);1645  }1646  SayAt(spec, "Constant INTEGER kind value required here"_err_en_US);1647  return GetDefaultKind(TypeCategory::Integer);1648}1649 1650// Array constructors1651 1652// Inverts a collection of generic ArrayConstructorValues<SomeType> that1653// all happen to have the same actual type T into one ArrayConstructor<T>.1654template <typename T>1655ArrayConstructorValues<T> MakeSpecific(1656    ArrayConstructorValues<SomeType> &&from) {1657  ArrayConstructorValues<T> to;1658  for (ArrayConstructorValue<SomeType> &x : from) {1659    common::visit(1660        common::visitors{1661            [&](common::CopyableIndirection<Expr<SomeType>> &&expr) {1662              auto *typed{UnwrapExpr<Expr<T>>(expr.value())};1663              to.Push(std::move(DEREF(typed)));1664            },1665            [&](ImpliedDo<SomeType> &&impliedDo) {1666              to.Push(ImpliedDo<T>{impliedDo.name(),1667                  std::move(impliedDo.lower()), std::move(impliedDo.upper()),1668                  std::move(impliedDo.stride()),1669                  MakeSpecific<T>(std::move(impliedDo.values()))});1670            },1671        },1672        std::move(x.u));1673  }1674  return to;1675}1676 1677class ArrayConstructorContext {1678public:1679  ArrayConstructorContext(1680      ExpressionAnalyzer &c, std::optional<DynamicTypeWithLength> &&t)1681      : exprAnalyzer_{c}, type_{std::move(t)} {}1682 1683  void Add(const parser::AcValue &);1684  MaybeExpr ToExpr();1685 1686  // These interfaces allow *this to be used as a type visitor argument to1687  // common::SearchTypes() to convert the array constructor to a typed1688  // expression in ToExpr().1689  using Result = MaybeExpr;1690  using Types = AllTypes;1691  template <typename T> Result Test() {1692    if (type_ && type_->category() == T::category) {1693      if constexpr (T::category == TypeCategory::Derived) {1694        if (!type_->IsUnlimitedPolymorphic()) {1695          return AsMaybeExpr(ArrayConstructor<T>{type_->GetDerivedTypeSpec(),1696              MakeSpecific<T>(std::move(values_))});1697        }1698      } else if (type_->kind() == T::kind) {1699        ArrayConstructor<T> result{MakeSpecific<T>(std::move(values_))};1700        if constexpr (T::category == TypeCategory::Character) {1701          if (auto len{LengthIfGood()}) {1702            // The ac-do-variables may be treated as constant expressions,1703            // if some conditions on ac-implied-do-control hold (10.1.12 (12)).1704            // At the same time, they may be treated as constant expressions1705            // only in the context of the ac-implied-do, but setting1706            // the character length here may result in complete elimination1707            // of the ac-implied-do. For example:1708            //   character(10) :: c1709            //   ... len([(c(i:i), integer(8)::i = 1,4)])1710            // would be evaulated into:1711            //   ... int(max(0_8,i-i+1_8),kind=4)1712            // with a dangling reference to the ac-do-variable.1713            // Prevent this by checking for the ac-do-variable references1714            // in the 'len' expression.1715            result.set_LEN(std::move(*len));1716          }1717        }1718        return AsMaybeExpr(std::move(result));1719      }1720    }1721    return std::nullopt;1722  }1723 1724private:1725  using ImpliedDoIntType = ResultType<ImpliedDoIndex>;1726 1727  std::optional<Expr<SubscriptInteger>> LengthIfGood() const {1728    if (type_) {1729      auto len{type_->LEN()};1730      if (explicitType_ ||1731          (len && IsConstantExpr(*len) && !ContainsAnyImpliedDoIndex(*len))) {1732        return len;1733      }1734    }1735    return std::nullopt;1736  }1737  bool NeedLength() const {1738    return type_ && type_->category() == TypeCategory::Character &&1739        !LengthIfGood();1740  }1741  void Push(MaybeExpr &&);1742  void Add(const parser::AcValue::Triplet &);1743  void Add(const parser::Expr &);1744  void Add(const parser::AcImpliedDo &);1745  void UnrollConstantImpliedDo(const parser::AcImpliedDo &,1746      parser::CharBlock name, std::int64_t lower, std::int64_t upper,1747      std::int64_t stride);1748 1749  template <int KIND>1750  std::optional<Expr<Type<TypeCategory::Integer, KIND>>> ToSpecificInt(1751      MaybeExpr &&y) {1752    if (y) {1753      Expr<SomeInteger> *intExpr{UnwrapExpr<Expr<SomeInteger>>(*y)};1754      return Fold(exprAnalyzer_.GetFoldingContext(),1755          ConvertToType<Type<TypeCategory::Integer, KIND>>(1756              std::move(DEREF(intExpr))));1757    } else {1758      return std::nullopt;1759    }1760  }1761 1762  template <int KIND, typename A>1763  std::optional<Expr<Type<TypeCategory::Integer, KIND>>> GetSpecificIntExpr(1764      const A &x) {1765    return ToSpecificInt<KIND>(exprAnalyzer_.Analyze(x));1766  }1767 1768  // Nested array constructors all reference the same ExpressionAnalyzer,1769  // which represents the nest of active implied DO loop indices.1770  ExpressionAnalyzer &exprAnalyzer_;1771  std::optional<DynamicTypeWithLength> type_;1772  bool explicitType_{type_.has_value()};1773  std::optional<std::int64_t> constantLength_;1774  ArrayConstructorValues<SomeType> values_;1775  std::uint64_t messageDisplayedSet_{0};1776};1777 1778void ArrayConstructorContext::Push(MaybeExpr &&x) {1779  if (!x) {1780    return;1781  }1782  if (!type_) {1783    if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {1784      // Treat an array constructor of BOZ as if default integer.1785      exprAnalyzer_.Warn(common::LanguageFeature::BOZAsDefaultInteger,1786          "BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);1787      x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(1788          exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),1789          std::move(*boz)));1790    }1791  }1792  std::optional<DynamicType> dyType{x->GetType()};1793  if (!dyType) {1794    if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {1795      if (!type_) {1796        // Treat an array constructor of BOZ as if default integer.1797        exprAnalyzer_.Warn(common::LanguageFeature::BOZAsDefaultInteger,1798            "BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);1799        x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(1800            exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),1801            std::move(*boz)));1802        dyType = x.value().GetType();1803      } else if (auto cast{ConvertToType(*type_, std::move(*x))}) {1804        x = std::move(cast);1805        dyType = *type_;1806      } else {1807        if (!(messageDisplayedSet_ & 0x80)) {1808          exprAnalyzer_.Say(1809              "BOZ literal is not suitable for use in this array constructor"_err_en_US);1810          messageDisplayedSet_ |= 0x80;1811        }1812        return;1813      }1814    } else { // procedure name, &c.1815      if (!(messageDisplayedSet_ & 0x40)) {1816        exprAnalyzer_.Say(1817            "Item is not suitable for use in an array constructor"_err_en_US);1818        messageDisplayedSet_ |= 0x40;1819      }1820      return;1821    }1822  } else if (dyType->IsUnlimitedPolymorphic()) {1823    if (!(messageDisplayedSet_ & 8)) {1824      exprAnalyzer_.Say("Cannot have an unlimited polymorphic value in an "1825                        "array constructor"_err_en_US); // C71131826      messageDisplayedSet_ |= 8;1827    }1828    return;1829  } else if (dyType->category() == TypeCategory::Derived &&1830      dyType->GetDerivedTypeSpec().typeSymbol().attrs().test(1831          semantics::Attr::ABSTRACT)) { // F'2023 C71251832    if (!(messageDisplayedSet_ & 0x200)) {1833      exprAnalyzer_.Say(1834          "An item whose declared type is ABSTRACT may not appear in an array constructor"_err_en_US);1835      messageDisplayedSet_ |= 0x200;1836    }1837  }1838  DynamicTypeWithLength xType{dyType.value()};1839  if (Expr<SomeCharacter> * charExpr{UnwrapExpr<Expr<SomeCharacter>>(*x)}) {1840    CHECK(xType.category() == TypeCategory::Character);1841    xType.length =1842        common::visit([](const auto &kc) { return kc.LEN(); }, charExpr->u);1843  }1844  if (!type_) {1845    // If there is no explicit type-spec in an array constructor, the type1846    // of the array is the declared type of all of the elements, which must1847    // be well-defined and all match.1848    // TODO: Possible language extension: use the most general type of1849    // the values as the type of a numeric constructed array, convert all1850    // of the other values to that type.  Alternative: let the first value1851    // determine the type, and convert the others to that type.1852    CHECK(!explicitType_);1853    type_ = std::move(xType);1854    constantLength_ = ToInt64(type_->length);1855    values_.Push(std::move(*x));1856  } else if (!explicitType_) {1857    if (type_->IsTkCompatibleWith(xType) && xType.IsTkCompatibleWith(*type_)) {1858      values_.Push(std::move(*x));1859      auto xLen{xType.LEN()};1860      if (auto thisLen{ToInt64(xLen)}) {1861        if (constantLength_) {1862          if (*thisLen != *constantLength_ && !(messageDisplayedSet_ & 1)) {1863            exprAnalyzer_.Warn(1864                common::LanguageFeature::DistinctArrayConstructorLengths,1865                "Character literal in array constructor without explicit type has different length than earlier elements"_port_en_US);1866            messageDisplayedSet_ |= 1;1867          }1868          if (*thisLen > *constantLength_) {1869            // Language extension: use the longest literal to determine the1870            // length of the array constructor's character elements, not the1871            // first, when there is no explicit type.1872            *constantLength_ = *thisLen;1873            type_->length = std::move(xLen);1874          }1875        } else {1876          constantLength_ = *thisLen;1877          type_->length = std::move(xLen);1878        }1879      } else if (xLen && NeedLength()) {1880        type_->length = std::move(xLen);1881      }1882    } else {1883      if (!(messageDisplayedSet_ & 2)) {1884        exprAnalyzer_.Say(1885            "Values in array constructor must have the same declared type when no explicit type appears"_err_en_US); // C71101886        messageDisplayedSet_ |= 2;1887      }1888    }1889  } else {1890    CheckRealWidening(*x, *type_, exprAnalyzer_.GetFoldingContext());1891    if (auto cast{ConvertToType(*type_, std::move(*x))}) {1892      values_.Push(std::move(*cast));1893    } else if (!(messageDisplayedSet_ & 4)) {1894      exprAnalyzer_.Say(1895          "Value in array constructor of type '%s' could not be converted to the type of the array '%s'"_err_en_US,1896          x->GetType()->AsFortran(), type_->AsFortran()); // C7111, C71121897      messageDisplayedSet_ |= 4;1898    }1899  }1900}1901 1902void ArrayConstructorContext::Add(const parser::AcValue &x) {1903  common::visit(1904      common::visitors{1905          [&](const parser::AcValue::Triplet &triplet) { Add(triplet); },1906          [&](const common::Indirection<parser::Expr> &expr) {1907            Add(expr.value());1908          },1909          [&](const common::Indirection<parser::AcImpliedDo> &impliedDo) {1910            Add(impliedDo.value());1911          },1912      },1913      x.u);1914}1915 1916// Transforms l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_'1917void ArrayConstructorContext::Add(const parser::AcValue::Triplet &triplet) {1918  MaybeExpr lowerExpr{exprAnalyzer_.Analyze(std::get<0>(triplet.t))};1919  MaybeExpr upperExpr{exprAnalyzer_.Analyze(std::get<1>(triplet.t))};1920  MaybeExpr strideExpr{exprAnalyzer_.Analyze(std::get<2>(triplet.t))};1921  if (lowerExpr && upperExpr) {1922    auto lowerType{lowerExpr->GetType()};1923    auto upperType{upperExpr->GetType()};1924    auto strideType{strideExpr ? strideExpr->GetType() : lowerType};1925    if (lowerType && upperType && strideType) {1926      int kind{lowerType->kind()};1927      if (upperType->kind() > kind) {1928        kind = upperType->kind();1929      }1930      if (strideType->kind() > kind) {1931        kind = strideType->kind();1932      }1933      auto lower{ToSpecificInt<ImpliedDoIntType::kind>(std::move(lowerExpr))};1934      auto upper{ToSpecificInt<ImpliedDoIntType::kind>(std::move(upperExpr))};1935      if (lower && upper) {1936        auto stride{1937            ToSpecificInt<ImpliedDoIntType::kind>(std::move(strideExpr))};1938        if (!stride) {1939          stride = Expr<ImpliedDoIntType>{1};1940        }1941        DynamicType type{TypeCategory::Integer, kind};1942        if (!type_) {1943          type_ = DynamicTypeWithLength{type};1944        }1945        parser::CharBlock anonymous;1946        if (auto converted{ConvertToType(type,1947                AsGenericExpr(1948                    Expr<ImpliedDoIntType>{ImpliedDoIndex{anonymous}}))}) {1949          auto v{std::move(values_)};1950          Push(std::move(converted));1951          std::swap(v, values_);1952          values_.Push(ImpliedDo<SomeType>{anonymous, std::move(*lower),1953              std::move(*upper), std::move(*stride), std::move(v)});1954        }1955      }1956    }1957  }1958}1959 1960void ArrayConstructorContext::Add(const parser::Expr &expr) {1961  auto restorer1{1962      exprAnalyzer_.GetContextualMessages().SetLocation(expr.source)};1963  auto restorer2{exprAnalyzer_.AllowWholeAssumedSizeArray(false)};1964  Push(exprAnalyzer_.Analyze(expr));1965}1966 1967void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {1968  const auto &control{std::get<parser::AcImpliedDoControl>(impliedDo.t)};1969  const auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)};1970  exprAnalyzer_.Analyze(bounds.name);1971  const auto &parsedName{parser::UnwrapRef<parser::Name>(bounds.name)};1972  parser::CharBlock name{parsedName.source};1973  int kind{ImpliedDoIntType::kind};1974  if (const Symbol *symbol{parsedName.symbol}) {1975    if (auto dynamicType{DynamicType::From(symbol)}) {1976      if (dynamicType->category() == TypeCategory::Integer) {1977        kind = dynamicType->kind();1978      }1979    }1980  }1981  std::optional<Expr<ImpliedDoIntType>> lower{1982      GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.lower)};1983  std::optional<Expr<ImpliedDoIntType>> upper{1984      GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.upper)};1985  if (lower && upper) {1986    std::optional<Expr<ImpliedDoIntType>> stride{1987        GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.step)};1988    if (!stride) {1989      stride = Expr<ImpliedDoIntType>{1};1990    }1991    if (exprAnalyzer_.AddImpliedDo(name, kind)) {1992      // Check for constant bounds; the loop may require complete unrolling1993      // of the parse tree if all bounds are constant in order to allow the1994      // implied DO loop index to qualify as a constant expression.1995      auto cLower{ToInt64(lower)};1996      auto cUpper{ToInt64(upper)};1997      auto cStride{ToInt64(stride)};1998      if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) {1999        exprAnalyzer_.SayAt(parser::UnwrapRef<parser::Expr>(bounds.step).source,2000            "The stride of an implied DO loop must not be zero"_err_en_US);2001        messageDisplayedSet_ |= 0x10;2002      }2003      bool isConstant{cLower && cUpper && cStride && *cStride != 0};2004      bool isNonemptyConstant{isConstant &&2005          ((*cStride > 0 && *cLower <= *cUpper) ||2006              (*cStride < 0 && *cLower >= *cUpper))};2007      bool isEmpty{isConstant && !isNonemptyConstant};2008      bool unrollConstantLoop{false};2009      parser::Messages buffer;2010      auto saveMessagesDisplayed{messageDisplayedSet_};2011      {2012        auto messageRestorer{2013            exprAnalyzer_.GetContextualMessages().SetMessages(buffer)};2014        auto v{std::move(values_)};2015        for (const auto &value :2016            std::get<std::list<parser::AcValue>>(impliedDo.t)) {2017          Add(value);2018        }2019        std::swap(v, values_);2020        if (isNonemptyConstant && buffer.AnyFatalError()) {2021          unrollConstantLoop = true;2022        } else {2023          values_.Push(ImpliedDo<SomeType>{name, std::move(*lower),2024              std::move(*upper), std::move(*stride), std::move(v)});2025        }2026      }2027      // F'2023 7.8 p52028      if (!(messageDisplayedSet_ & 0x100) && isEmpty && NeedLength()) {2029        exprAnalyzer_.SayAt(name,2030            "Array constructor implied DO loop has no iterations and indeterminate character length"_err_en_US);2031        messageDisplayedSet_ |= 0x100;2032      }2033      if (unrollConstantLoop) {2034        messageDisplayedSet_ = saveMessagesDisplayed;2035        UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride);2036      } else if (auto *messages{2037                     exprAnalyzer_.GetContextualMessages().messages()}) {2038        messages->Annex(std::move(buffer));2039      }2040      exprAnalyzer_.RemoveImpliedDo(name);2041    } else if (!(messageDisplayedSet_ & 0x20)) {2042      exprAnalyzer_.SayAt(name,2043          "Implied DO index '%s' is active in a surrounding implied DO loop "2044          "and may not have the same name"_err_en_US,2045          name); // C71152046      messageDisplayedSet_ |= 0x20;2047    }2048  }2049}2050 2051// Fortran considers an implied DO index of an array constructor to be2052// a constant expression if the bounds of the implied DO loop are constant.2053// Usually this doesn't matter, but if we emitted spurious messages as a2054// result of not using constant values for the index while analyzing the2055// items, we need to do it again the "hard" way with multiple iterations over2056// the parse tree.2057void ArrayConstructorContext::UnrollConstantImpliedDo(2058    const parser::AcImpliedDo &impliedDo, parser::CharBlock name,2059    std::int64_t lower, std::int64_t upper, std::int64_t stride) {2060  auto &foldingContext{exprAnalyzer_.GetFoldingContext()};2061  auto restorer{exprAnalyzer_.DoNotUseSavedTypedExprs()};2062  for (auto &at{foldingContext.StartImpliedDo(name, lower)};2063       (stride > 0 && at <= upper) || (stride < 0 && at >= upper);2064       at += stride) {2065    for (const auto &value :2066        std::get<std::list<parser::AcValue>>(impliedDo.t)) {2067      Add(value);2068    }2069  }2070  foldingContext.EndImpliedDo(name);2071}2072 2073MaybeExpr ArrayConstructorContext::ToExpr() {2074  return common::SearchTypes(std::move(*this));2075}2076 2077MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayConstructor &array) {2078  const parser::AcSpec &acSpec{array.v};2079  ArrayConstructorContext acContext{2080      *this, AnalyzeTypeSpec(acSpec.type, GetFoldingContext())};2081  for (const parser::AcValue &value : acSpec.values) {2082    acContext.Add(value);2083  }2084  return acContext.ToExpr();2085}2086 2087// Check if implicit conversion of expr to the symbol type is legal (if needed),2088// and make it explicit if requested.2089static MaybeExpr ImplicitConvertTo(const Symbol &sym, Expr<SomeType> &&expr,2090    bool keepConvertImplicit, FoldingContext &foldingContext) {2091  CheckRealWidening(expr, DynamicType::From(sym), foldingContext);2092  if (!keepConvertImplicit) {2093    return ConvertToType(sym, std::move(expr));2094  } else {2095    // Test if a convert could be inserted, but do not make it explicit to2096    // preserve the information that expr is a variable.2097    if (ConvertToType(sym, common::Clone(expr))) {2098      return MaybeExpr{std::move(expr)};2099    }2100  }2101  // Illegal implicit convert.2102  return std::nullopt;2103}2104 2105MaybeExpr ExpressionAnalyzer::CheckStructureConstructor(2106    parser::CharBlock typeName, const semantics::DerivedTypeSpec &spec0,2107    std::list<ComponentSpec> &&componentSpecs) {2108  semantics::Scope &scope{context_.FindScope(typeName)};2109  FoldingContext &foldingContext{GetFoldingContext()};2110  const semantics::DerivedTypeSpec *effectiveSpec{&spec0};2111  if (foldingContext.pdtInstance() && spec0.MightBeParameterized()) {2112    // We're processing a structure constructor in the context of a derived2113    // type instantiation, and the derived type of the structure constructor2114    // is parameterized.  Evaluate its parameters in the context of the2115    // instantiation in progress so that the components in constructor's scope2116    // have the correct types.2117    semantics::DerivedTypeSpec newSpec{spec0};2118    newSpec.ReevaluateParameters(context());2119    const semantics::DeclTypeSpec &instantiatedType{2120        semantics::FindOrInstantiateDerivedType(2121            scope, std::move(newSpec), semantics::DeclTypeSpec::TypeDerived)};2122    effectiveSpec = &instantiatedType.derivedTypeSpec();2123  }2124  const semantics::DerivedTypeSpec &spec{*effectiveSpec};2125  const Symbol &typeSymbol{spec.typeSymbol()};2126  if (!spec.scope() || !typeSymbol.has<semantics::DerivedTypeDetails>()) {2127    return std::nullopt; // error recovery2128  }2129  const semantics::Scope *pureContext{FindPureProcedureContaining(scope)};2130  const auto &typeDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};2131  const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};2132  if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C7962133    AttachDeclaration(2134        Say(typeName,2135            "ABSTRACT derived type '%s' may not be used in a structure constructor"_err_en_US,2136            typeName),2137        typeSymbol); // C71142138  }2139 2140  // This iterator traverses all of the components in the derived type and its2141  // parents.  The symbols for whole parent components appear after their2142  // own components and before the components of the types that extend them.2143  // E.g., TYPE :: A; REAL X; END TYPE2144  //       TYPE, EXTENDS(A) :: B; REAL Y; END TYPE2145  // produces the component list X, A, Y.2146  // The order is important below because a structure constructor can2147  // initialize X or A by name, but not both.2148  auto components{semantics::OrderedComponentIterator{spec}};2149  auto nextAnonymous{components.begin()};2150  auto afterLastParentComponentIter{components.end()};2151  if (parentComponent) {2152    for (auto iter{components.begin()}; iter != components.end(); ++iter) {2153      if (iter->test(Symbol::Flag::ParentComp)) {2154        afterLastParentComponentIter = iter;2155        ++afterLastParentComponentIter;2156      }2157    }2158  }2159 2160  std::set<parser::CharBlock> unavailable;2161  bool anyKeyword{false};2162  StructureConstructor result{spec};2163  bool checkConflicts{true}; // until we hit one2164  auto &messages{GetContextualMessages()};2165 2166  for (ComponentSpec &componentSpec : componentSpecs) {2167    parser::CharBlock source{componentSpec.source};2168    parser::CharBlock exprSource{componentSpec.exprSource};2169    auto restorer{messages.SetLocation(source)};2170    const Symbol *symbol{componentSpec.keywordSymbol};2171    if (symbol) {2172      symbol = spec.scope()->FindComponent(symbol->name());2173    }2174    MaybeExpr &maybeValue{componentSpec.expr};2175    if (!maybeValue.has_value()) {2176      return std::nullopt;2177    }2178    Expr<SomeType> &value{*maybeValue};2179    std::optional<DynamicType> valueType{DynamicType::From(value)};2180    if (componentSpec.hasKeyword) {2181      anyKeyword = true;2182      if (!symbol) {2183        // Skip overridden inaccessible parent components in favor of2184        // their later overrides.2185        for (const Symbol &sym : components) {2186          if (sym.name() == source) {2187            symbol = &sym;2188          }2189        }2190      }2191      if (!symbol) { // C71012192        Say(source,2193            "Keyword '%s=' does not name a component of derived type '%s'"_err_en_US,2194            source, typeName);2195      }2196    } else {2197      if (anyKeyword) { // C71002198        Say(source,2199            "Value in structure constructor lacks a component name"_err_en_US);2200        checkConflicts = false; // stem cascade2201      }2202      // Here's a regrettably common extension of the standard: anonymous2203      // initialization of parent components, e.g., T(PT(1)) rather than2204      // T(1) or T(PT=PT(1)).  There may be multiple parent components.2205      if (nextAnonymous == components.begin() && parentComponent && valueType &&2206          context().IsEnabled(LanguageFeature::AnonymousParents)) {2207        auto parent{components.begin()};2208        if (!parent->test(Symbol::Flag::ParentComp)) {2209          // Ensure that the first value can't initialize the first actual2210          // component.2211          if (auto firstComponentType{DynamicType::From(*parent)}) {2212            if (firstComponentType->IsTkCompatibleWith(*valueType) &&2213                value.Rank() == parent->Rank()) {2214              parent = afterLastParentComponentIter; // skip next loop2215            }2216          }2217        }2218        for (; parent != afterLastParentComponentIter; ++parent) {2219          if (auto parentType{DynamicType::From(*parent)}) {2220            if (parent->test(Symbol::Flag::ParentComp) &&2221                valueType->IsEquivalentTo(*parentType) &&2222                value.Rank() == 0 /* scalar only */) {2223              symbol = &*parent;2224              nextAnonymous = ++parent;2225              Warn(LanguageFeature::AnonymousParents, source,2226                  "Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,2227                  symbol->name());2228              break;2229            }2230          }2231        }2232      }2233      while (!symbol && nextAnonymous != components.end()) {2234        const Symbol &next{*nextAnonymous};2235        ++nextAnonymous;2236        if (!next.test(Symbol::Flag::ParentComp)) {2237          symbol = &next;2238        }2239      }2240      if (!symbol) {2241        Say(source, "Unexpected value in structure constructor"_err_en_US);2242      }2243    }2244    if (symbol) {2245      const semantics::Scope &innermost{context_.FindScope(exprSource)};2246      if (auto msg{CheckAccessibleSymbol(2247              innermost, *symbol, /*inStructureConstructor=*/true)}) {2248        Say(exprSource, std::move(*msg));2249      }2250      if (checkConflicts) {2251        auto componentIter{2252            std::find(components.begin(), components.end(), *symbol)};2253        if (unavailable.find(symbol->name()) != unavailable.cend()) {2254          // C797, C7982255          Say(source,2256              "Component '%s' conflicts with another component earlier in this structure constructor"_err_en_US,2257              symbol->name());2258        } else if (symbol->test(Symbol::Flag::ParentComp)) {2259          // Make earlier components unavailable once a whole parent appears.2260          for (auto it{components.begin()}; it != componentIter; ++it) {2261            unavailable.insert(it->name());2262          }2263        } else {2264          // Make whole parent components unavailable after any of their2265          // constituents appear.2266          for (auto it{componentIter}; it != components.end(); ++it) {2267            if (it->test(Symbol::Flag::ParentComp)) {2268              unavailable.insert(it->name());2269            }2270          }2271        }2272      }2273      unavailable.insert(symbol->name());2274      if (symbol->has<semantics::TypeParamDetails>()) {2275        Say(exprSource,2276            "Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US,2277            symbol->name());2278      }2279      if (!(symbol->has<semantics::ProcEntityDetails>() ||2280              symbol->has<semantics::ObjectEntityDetails>())) {2281        continue; // recovery2282      }2283      if (IsPointer(*symbol)) { // C7104, C7105, C1594(4)2284        semantics::CheckStructConstructorPointerComponent(2285            context_, *symbol, value, innermost);2286        result.Add(*symbol, Fold(std::move(value)));2287        continue;2288      }2289      if (IsNullPointer(&value)) {2290        if (IsAllocatable(*symbol)) {2291          if (IsBareNullPointer(&value)) {2292            // NULL() with no arguments allowed by 7.5.10 para 6 for2293            // ALLOCATABLE.2294            result.Add(*symbol, Expr<SomeType>{NullPointer{}});2295            continue;2296          }2297          if (IsNullObjectPointer(&value)) {2298            AttachDeclaration(2299                Warn(common::LanguageFeature::NullMoldAllocatableComponentValue,2300                    exprSource,2301                    "NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,2302                    symbol->name()),2303                *symbol);2304            // proceed to check type & shape2305          } else {2306            AttachDeclaration(2307                Say(exprSource,2308                    "A NULL procedure pointer may not be used as the value for component '%s'"_err_en_US,2309                    symbol->name()),2310                *symbol);2311            continue;2312          }2313        } else {2314          AttachDeclaration(2315              Say(exprSource,2316                  "A NULL pointer may not be used as the value for component '%s'"_err_en_US,2317                  symbol->name()),2318              *symbol);2319          continue;2320        }2321      } else if (IsNullAllocatable(&value) && IsAllocatable(*symbol)) {2322        result.Add(*symbol, Expr<SomeType>{NullPointer{}});2323        continue;2324      } else if (auto *derived{evaluate::GetDerivedTypeSpec(2325                     evaluate::DynamicType::From(*symbol))}) {2326        if (auto iter{FindPointerPotentialComponent(*derived)};2327            iter && pureContext) { // F'2023 C15104(4)2328          if (const Symbol *2329              visible{semantics::FindExternallyVisibleObject(2330                  value, *pureContext)}) {2331            Say(exprSource,2332                "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,2333                visible->name(), symbol->name(),2334                iter.BuildResultDesignatorName());2335          } else if (ExtractCoarrayRef(value)) {2336            Say(exprSource,2337                "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,2338                symbol->name(), iter.BuildResultDesignatorName());2339          }2340        }2341      }2342      // Make implicit conversion explicit to allow folding of the structure2343      // constructors and help semantic checking, unless the component is2344      // allocatable, in which case the value could be an unallocated2345      // allocatable (see Fortran 2018 7.5.10 point 7). The explicit2346      // convert would cause a segfault. Lowering will deal with2347      // conditionally converting and preserving the lower bounds in this2348      // case.2349      if (MaybeExpr converted{ImplicitConvertTo(*symbol, std::move(value),2350              /*keepConvertImplicit=*/IsAllocatable(*symbol),2351              foldingContext)}) {2352        if (auto componentShape{GetShape(foldingContext, *symbol)}) {2353          if (auto valueShape{GetShape(foldingContext, *converted)}) {2354            if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {2355              AttachDeclaration(2356                  Say(exprSource,2357                      "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,2358                      GetRank(*valueShape), symbol->name()),2359                  *symbol);2360            } else {2361              auto checked{CheckConformance(messages, *componentShape,2362                  *valueShape, CheckConformanceFlags::RightIsExpandableDeferred,2363                  "component", "value")};2364              if (checked.value_or(false) && GetRank(*componentShape) > 0 &&2365                  GetRank(*valueShape) == 0 &&2366                  (IsDeferredShape(*symbol) ||2367                      !IsExpandableScalar(*converted, foldingContext,2368                          *componentShape, true /*admit PURE call*/))) {2369                AttachDeclaration(2370                    Say(exprSource,2371                        "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,2372                        symbol->name()),2373                    *symbol);2374              }2375              if (checked.value_or(true)) {2376                result.Add(*symbol, std::move(*converted));2377              }2378            }2379          } else {2380            Say(exprSource, "Shape of value cannot be determined"_err_en_US);2381          }2382        } else {2383          AttachDeclaration(2384              Say(exprSource,2385                  "Shape of component '%s' cannot be determined"_err_en_US,2386                  symbol->name()),2387              *symbol);2388        }2389      } else if (auto symType{DynamicType::From(symbol)}) {2390        if (IsAllocatable(*symbol) && symType->IsUnlimitedPolymorphic() &&2391            valueType) {2392          // ok2393        } else if (valueType) {2394          AttachDeclaration(2395              Say(exprSource,2396                  "Value in structure constructor of type '%s' is incompatible with component '%s' of type '%s'"_err_en_US,2397                  valueType->AsFortran(), symbol->name(), symType->AsFortran()),2398              *symbol);2399        } else {2400          AttachDeclaration(2401              Say(exprSource,2402                  "Value in structure constructor is incompatible with component '%s' of type %s"_err_en_US,2403                  symbol->name(), symType->AsFortran()),2404              *symbol);2405        }2406      }2407    }2408  }2409 2410  // Ensure that unmentioned component objects have default initializers.2411  for (const Symbol &symbol : components) {2412    if (!symbol.test(Symbol::Flag::ParentComp) &&2413        unavailable.find(symbol.name()) == unavailable.cend()) {2414      if (IsAllocatable(symbol)) {2415        // Set all remaining allocatables to explicit NULL().2416        result.Add(symbol, Expr<SomeType>{NullPointer{}});2417      } else {2418        const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};2419        if (object && object->init()) {2420          result.Add(symbol, common::Clone(*object->init()));2421        } else if (IsPointer(symbol)) {2422          result.Add(symbol, Expr<SomeType>{NullPointer{}});2423        } else if (object) { // C7992424          AttachDeclaration(2425              Say(typeName,2426                  "Structure constructor lacks a value for component '%s'"_err_en_US,2427                  symbol.name()),2428              symbol);2429        }2430      }2431    }2432  }2433 2434  return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});2435}2436 2437MaybeExpr ExpressionAnalyzer::Analyze(2438    const parser::StructureConstructor &structure) {2439  const auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};2440  parser::Name structureType{std::get<parser::Name>(parsedType.t)};2441  parser::CharBlock &typeName{structureType.source};2442  if (semantics::Symbol * typeSymbol{structureType.symbol}) {2443    if (typeSymbol->has<semantics::DerivedTypeDetails>()) {2444      semantics::DerivedTypeSpec dtSpec{typeName, typeSymbol->GetUltimate()};2445      if (!CheckIsValidForwardReference(dtSpec)) {2446        return std::nullopt;2447      }2448    }2449  }2450  if (!parsedType.derivedTypeSpec) {2451    return std::nullopt;2452  }2453  auto restorer{AllowNullPointer()}; // NULL() can be a valid component2454  std::list<ComponentSpec> componentSpecs;2455  for (const auto &component :2456      std::get<std::list<parser::ComponentSpec>>(structure.t)) {2457    const parser::Expr &expr{2458        std::get<parser::ComponentDataSource>(component.t).v.value()};2459    auto restorer{GetContextualMessages().SetLocation(expr.source)};2460    ComponentSpec compSpec;2461    compSpec.exprSource = expr.source;2462    compSpec.expr = Analyze(expr);2463    if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {2464      compSpec.source = kw->v.source;2465      compSpec.hasKeyword = true;2466      compSpec.keywordSymbol = kw->v.symbol;2467    } else {2468      compSpec.source = expr.source;2469    }2470    componentSpecs.emplace_back(std::move(compSpec));2471  }2472  return CheckStructureConstructor(2473      typeName, DEREF(parsedType.derivedTypeSpec), std::move(componentSpecs));2474}2475 2476static std::optional<parser::CharBlock> GetPassName(2477    const semantics::Symbol &proc) {2478  return common::visit(2479      [](const auto &details) {2480        if constexpr (std::is_base_of_v<semantics::WithPassArg,2481                          std::decay_t<decltype(details)>>) {2482          return details.passName();2483        } else {2484          return std::optional<parser::CharBlock>{};2485        }2486      },2487      proc.details());2488}2489 2490static std::optional<int> GetPassIndex(const Symbol &proc) {2491  CHECK(!proc.attrs().test(semantics::Attr::NOPASS));2492  std::optional<parser::CharBlock> passName{GetPassName(proc)};2493  const auto *interface {2494    semantics::FindInterface(proc)2495  };2496  if (!passName || !interface) {2497    return 0; // first argument is passed-object2498  }2499  const auto &subp{interface->get<semantics::SubprogramDetails>()};2500  int index{0};2501  for (const auto *arg : subp.dummyArgs()) {2502    if (arg && arg->name() == passName) {2503      return index;2504    }2505    ++index;2506  }2507  return std::nullopt;2508}2509 2510// Injects an expression into an actual argument list as the "passed object"2511// for a type-bound procedure reference that is not NOPASS.  Adds an2512// argument keyword if possible, but not when the passed object goes2513// before a positional argument.2514// e.g., obj%tbp(x) -> tbp(obj,x).2515static void AddPassArg(ActualArguments &actuals, const Expr<SomeDerived> &expr,2516    const Symbol &component, bool isPassedObject = true) {2517  if (component.attrs().test(semantics::Attr::NOPASS)) {2518    return;2519  }2520  std::optional<int> passIndex{GetPassIndex(component)};2521  if (!passIndex) {2522    return; // error recovery2523  }2524  auto iter{actuals.begin()};2525  int at{0};2526  while (iter < actuals.end() && at < *passIndex) {2527    if (*iter && (*iter)->keyword()) {2528      iter = actuals.end();2529      break;2530    }2531    ++iter;2532    ++at;2533  }2534  ActualArgument passed{AsGenericExpr(common::Clone(expr))};2535  passed.set_isPassedObject(isPassedObject);2536  if (iter == actuals.end()) {2537    if (auto passName{GetPassName(component)}) {2538      passed.set_keyword(*passName);2539    }2540  }2541  actuals.emplace(iter, std::move(passed));2542}2543 2544// Return the compile-time resolution of a procedure binding, if possible.2545static const Symbol *GetBindingResolution(2546    const std::optional<DynamicType> &baseType, const Symbol &component) {2547  const auto *binding{component.detailsIf<semantics::ProcBindingDetails>()};2548  if (!binding) {2549    return nullptr;2550  }2551  if (!component.attrs().test(semantics::Attr::NON_OVERRIDABLE) &&2552      (!baseType || baseType->IsPolymorphic())) {2553    return nullptr;2554  }2555  return &binding->symbol();2556}2557 2558auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(2559    const parser::ProcComponentRef &pcr, ActualArguments &&arguments,2560    bool isSubroutine) -> std::optional<CalleeAndArguments> {2561  const auto &sc{parser::UnwrapRef<parser::StructureComponent>(pcr)};2562  if (MaybeExpr base{Analyze(sc.base)}) {2563    if (const Symbol *sym{sc.component.symbol}) {2564      if (context_.HasError(sym)) {2565        return std::nullopt;2566      }2567      if (!IsProcedure(*sym)) {2568        AttachDeclaration(2569            Say(sc.component.source, "'%s' is not a procedure"_err_en_US,2570                sc.component.source),2571            *sym);2572        return std::nullopt;2573      }2574      if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {2575        if (sym->has<semantics::GenericDetails>()) {2576          const Symbol &generic{*sym};2577          auto dyType{dtExpr->GetType()};2578          AdjustActuals adjustment{2579              [&](const Symbol &proc, ActualArguments &actuals) {2580                if (!proc.attrs().test(semantics::Attr::NOPASS)) {2581                  AddPassArg(actuals, std::move(*dtExpr), proc);2582                }2583                return true;2584              }};2585          auto result{ResolveGeneric(2586              generic, arguments, adjustment, isSubroutine, SymbolVector{})};2587          sym = result.specific;2588          if (!sym) {2589            EmitGenericResolutionError(generic, result.failedDueToAmbiguity,2590                isSubroutine, arguments, result.tried);2591            return std::nullopt;2592          }2593          // re-resolve the name to the specific binding2594          CHECK(sym->has<semantics::ProcBindingDetails>());2595          // Use the most recent override of a binding, respecting2596          // the rule that inaccessible bindings may not be overridden2597          // outside their module.  Fortran doesn't allow a PUBLIC2598          // binding to be overridden by a PRIVATE one.2599          CHECK(dyType && dyType->category() == TypeCategory::Derived &&2600              !dyType->IsUnlimitedPolymorphic());2601          if (const Symbol *2602              latest{DEREF(dyType->GetDerivedTypeSpec().typeSymbol().scope())2603                         .FindComponent(sym->name())}) {2604            if (sym->attrs().test(semantics::Attr::PRIVATE)) {2605              const auto *bindingModule{FindModuleContaining(generic.owner())};2606              const Symbol *s{latest};2607              while (s && FindModuleContaining(s->owner()) != bindingModule) {2608                if (const auto *parent{s->owner().GetDerivedTypeParent()}) {2609                  s = parent->FindComponent(sym->name());2610                } else {2611                  s = nullptr;2612                }2613              }2614              if (s && !s->attrs().test(semantics::Attr::PRIVATE)) {2615                // The latest override in the same module as the binding2616                // is public, so it can be overridden.2617              } else {2618                latest = s;2619              }2620            }2621            if (latest) {2622              sym = latest;2623            }2624          }2625          sc.component.symbol = const_cast<Symbol *>(sym);2626        }2627        std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};2628        if (dataRef && !CheckDataRef(*dataRef)) {2629          return std::nullopt;2630        }2631        if (dataRef && dataRef->Rank() > 0) {2632          if (sym->has<semantics::ProcBindingDetails>() &&2633              sym->attrs().test(semantics::Attr::NOPASS)) {2634            // F'2023 C1529 seems unnecessary and most compilers don't2635            // enforce it.2636            AttachDeclaration(2637                Warn(common::LanguageFeature::NopassScalarBase,2638                    sc.component.source,2639                    "Base of NOPASS type-bound procedure reference should be scalar"_port_en_US),2640                *sym);2641          } else if (IsProcedurePointer(*sym)) { // C9192642            Say(sc.component.source,2643                "Base of procedure component reference must be scalar"_err_en_US);2644          }2645        }2646        if (const Symbol *resolution{2647                GetBindingResolution(dtExpr->GetType(), *sym)}) {2648          AddPassArg(arguments, std::move(*dtExpr), *sym, false);2649          return CalleeAndArguments{2650              ProcedureDesignator{*resolution}, std::move(arguments)};2651        } else if (dataRef.has_value()) {2652          if (ExtractCoarrayRef(*dataRef)) {2653            if (IsProcedurePointer(*sym)) {2654              Say(sc.component.source,2655                  "Base of procedure component reference may not be coindexed"_err_en_US);2656            } else {2657              Say(sc.component.source,2658                  "A procedure binding may not be coindexed unless it can be resolved at compilation time"_err_en_US);2659            }2660          }2661          if (sym->attrs().test(semantics::Attr::NOPASS)) {2662            const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};2663            if (dtSpec && dtSpec->scope()) {2664              if (auto component{CreateComponent(std::move(*dataRef), *sym,2665                      *dtSpec->scope(), /*C919bAlreadyEnforced=*/true)}) {2666                return CalleeAndArguments{2667                    ProcedureDesignator{std::move(*component)},2668                    std::move(arguments)};2669              }2670            }2671            Say(sc.component.source,2672                "Component is not in scope of base derived type"_err_en_US);2673            return std::nullopt;2674          } else {2675            AddPassArg(arguments,2676                Expr<SomeDerived>{Designator<SomeDerived>{std::move(*dataRef)}},2677                *sym);2678            return CalleeAndArguments{2679                ProcedureDesignator{*sym}, std::move(arguments)};2680          }2681        }2682      }2683      Say(sc.component.source,2684          "Base of procedure component reference is not a derived-type object"_err_en_US);2685    }2686  }2687  CHECK(context_.AnyFatalError());2688  return std::nullopt;2689}2690 2691// Can actual be argument associated with dummy?2692static bool CheckCompatibleArgument(bool isElemental,2693    const ActualArgument &actual, const characteristics::DummyArgument &dummy,2694    FoldingContext &foldingContext) {2695  const auto *expr{actual.UnwrapExpr()};2696  return common::visit(2697      common::visitors{2698          [&](const characteristics::DummyDataObject &x) {2699            if ((x.attrs.test(2700                     characteristics::DummyDataObject::Attr::Pointer) ||2701                    x.attrs.test(2702                        characteristics::DummyDataObject::Attr::Allocatable)) &&2703                IsBareNullPointer(expr)) {2704              // NULL() without MOLD= is compatible with any dummy data pointer2705              // or allocatable, but cannot be allowed to lead to ambiguity.2706              return true;2707            } else if (!isElemental && actual.Rank() != x.type.Rank() &&2708                !x.type.attrs().test(2709                    characteristics::TypeAndShape::Attr::AssumedRank) &&2710                !x.ignoreTKR.test(common::IgnoreTKR::Rank)) {2711              return false;2712            } else if (auto actualType{actual.GetType()}) {2713              return x.type.type().IsTkCompatibleWith(*actualType, x.ignoreTKR);2714            }2715            return false;2716          },2717          [&](const characteristics::DummyProcedure &dummy) {2718            if ((dummy.attrs.test(2719                     characteristics::DummyProcedure::Attr::Optional) ||2720                    dummy.attrs.test(2721                        characteristics::DummyProcedure::Attr::Pointer)) &&2722                IsBareNullPointer(expr)) {2723              // NULL() is compatible with any dummy pointer2724              // or optional dummy procedure.2725              return true;2726            }2727            if (!expr || !IsProcedurePointerTarget(*expr)) {2728              return false;2729            }2730            if (auto actualProc{characteristics::Procedure::Characterize(2731                    *expr, foldingContext)}) {2732              const auto &dummyResult{dummy.procedure.value().functionResult};2733              const auto *dummyTypeAndShape{2734                  dummyResult ? dummyResult->GetTypeAndShape() : nullptr};2735              const auto &actualResult{actualProc->functionResult};2736              const auto *actualTypeAndShape{2737                  actualResult ? actualResult->GetTypeAndShape() : nullptr};2738              if (dummyTypeAndShape && actualTypeAndShape) {2739                // Return false when the function results' types are both2740                // known and not compatible.2741                return actualTypeAndShape->type().IsTkCompatibleWith(2742                    dummyTypeAndShape->type());2743              }2744            }2745            return true;2746          },2747          [&](const characteristics::AlternateReturn &) {2748            return actual.isAlternateReturn();2749          },2750      },2751      dummy.u);2752}2753 2754// Are the actual arguments compatible with the dummy arguments of procedure?2755static bool CheckCompatibleArguments(2756    const characteristics::Procedure &procedure, const ActualArguments &actuals,2757    FoldingContext &foldingContext) {2758  bool isElemental{procedure.IsElemental()};2759  const auto &dummies{procedure.dummyArguments};2760  CHECK(dummies.size() == actuals.size());2761  for (std::size_t i{0}; i < dummies.size(); ++i) {2762    const characteristics::DummyArgument &dummy{dummies[i]};2763    const std::optional<ActualArgument> &actual{actuals[i]};2764    if (actual &&2765        !CheckCompatibleArgument(isElemental, *actual, dummy, foldingContext)) {2766      return false;2767    }2768  }2769  return true;2770}2771 2772static constexpr int cudaInfMatchingValue{std::numeric_limits<int>::max()};2773 2774// Compute the matching distance as described in section 3.2.3 of the CUDA2775// Fortran references.2776static int GetMatchingDistance(const common::LanguageFeatureControl &features,2777    const characteristics::DummyArgument &dummy,2778    const std::optional<ActualArgument> &actual) {2779  bool isCudaManaged{features.IsEnabled(common::LanguageFeature::CudaManaged)};2780  bool isCudaUnified{features.IsEnabled(common::LanguageFeature::CudaUnified)};2781  CHECK(!(isCudaUnified && isCudaManaged) && "expect only one enabled.");2782 2783  std::optional<common::CUDADataAttr> actualDataAttr, dummyDataAttr;2784  if (actual) {2785    if (auto *expr{actual->UnwrapExpr()}) {2786      const auto *actualLastSymbol{evaluate::GetLastSymbol(*expr)};2787      if (actualLastSymbol) {2788        actualLastSymbol = &semantics::ResolveAssociations(*actualLastSymbol);2789        if (const auto *actualObject{actualLastSymbol2790                    ? actualLastSymbol2791                          ->detailsIf<semantics::ObjectEntityDetails>()2792                    : nullptr}) {2793          actualDataAttr = actualObject->cudaDataAttr();2794        }2795      }2796    }2797  }2798 2799  common::visit(common::visitors{2800                    [&](const characteristics::DummyDataObject &object) {2801                      dummyDataAttr = object.cudaDataAttr;2802                    },2803                    [&](const auto &) {},2804                },2805      dummy.u);2806 2807  if (!dummyDataAttr) {2808    if (!actualDataAttr) {2809      if (isCudaUnified || isCudaManaged) {2810        return 3;2811      }2812      return 0;2813    } else if (*actualDataAttr == common::CUDADataAttr::Device) {2814      return cudaInfMatchingValue;2815    } else if (*actualDataAttr == common::CUDADataAttr::Managed ||2816        *actualDataAttr == common::CUDADataAttr::Unified) {2817      return 3;2818    }2819  } else if (*dummyDataAttr == common::CUDADataAttr::Device) {2820    if (!actualDataAttr) {2821      if (isCudaUnified || isCudaManaged) {2822        return 2;2823      }2824      return cudaInfMatchingValue;2825    } else if (*actualDataAttr == common::CUDADataAttr::Device) {2826      return 0;2827    } else if (*actualDataAttr == common::CUDADataAttr::Managed ||2828        *actualDataAttr == common::CUDADataAttr::Unified) {2829      return 2;2830    }2831  } else if (*dummyDataAttr == common::CUDADataAttr::Managed) {2832    if (!actualDataAttr) {2833      return isCudaUnified ? 1 : isCudaManaged ? 0 : cudaInfMatchingValue;2834    }2835    if (*actualDataAttr == common::CUDADataAttr::Device) {2836      return cudaInfMatchingValue;2837    } else if (*actualDataAttr == common::CUDADataAttr::Managed) {2838      return 0;2839    } else if (*actualDataAttr == common::CUDADataAttr::Unified) {2840      return 1;2841    }2842  } else if (*dummyDataAttr == common::CUDADataAttr::Unified) {2843    if (!actualDataAttr) {2844      return isCudaUnified ? 0 : isCudaManaged ? 1 : cudaInfMatchingValue;2845    }2846    if (*actualDataAttr == common::CUDADataAttr::Device) {2847      return cudaInfMatchingValue;2848    } else if (*actualDataAttr == common::CUDADataAttr::Managed) {2849      return 1;2850    } else if (*actualDataAttr == common::CUDADataAttr::Unified) {2851      return 0;2852    }2853  }2854  return cudaInfMatchingValue;2855}2856 2857static int ComputeCudaMatchingDistance(2858    const common::LanguageFeatureControl &features,2859    const characteristics::Procedure &procedure,2860    const ActualArguments &actuals) {2861  const auto &dummies{procedure.dummyArguments};2862  CHECK(dummies.size() == actuals.size());2863  int distance{0};2864  for (std::size_t i{0}; i < dummies.size(); ++i) {2865    const characteristics::DummyArgument &dummy{dummies[i]};2866    const std::optional<ActualArgument> &actual{actuals[i]};2867    int d{GetMatchingDistance(features, dummy, actual)};2868    if (d == cudaInfMatchingValue)2869      return d;2870    distance += d;2871  }2872  return distance;2873}2874 2875// Handles a forward reference to a module function from what must2876// be a specification expression.  Return false if the symbol is2877// an invalid forward reference.2878const Symbol *ExpressionAnalyzer::ResolveForward(const Symbol &symbol) {2879  if (context_.HasError(symbol)) {2880    return nullptr;2881  }2882  if (const auto *details{2883          symbol.detailsIf<semantics::SubprogramNameDetails>()}) {2884    if (details->kind() == semantics::SubprogramKind::Module) {2885      // If this symbol is still a SubprogramNameDetails, we must be2886      // checking a specification expression in a sibling module2887      // procedure.  Resolve its names now so that its interface2888      // is known.2889      const semantics::Scope &scope{symbol.owner()};2890      semantics::ResolveSpecificationParts(context_, symbol);2891      const Symbol *resolved{nullptr};2892      if (auto iter{scope.find(symbol.name())}; iter != scope.cend()) {2893        resolved = &*iter->second;2894      }2895      if (!resolved || resolved->has<semantics::SubprogramNameDetails>()) {2896        // When the symbol hasn't had its details updated, we must have2897        // already been in the process of resolving the function's2898        // specification part; but recursive function calls are not2899        // allowed in specification parts (10.1.11 para 5).2900        Say("The module function '%s' may not be referenced recursively in a specification expression"_err_en_US,2901            symbol.name());2902        context_.SetError(symbol);2903      }2904      return resolved;2905    } else if (inStmtFunctionDefinition_) {2906      semantics::ResolveSpecificationParts(context_, symbol);2907      CHECK(symbol.has<semantics::SubprogramDetails>());2908    } else { // 10.1.11 para 42909      Say("The internal function '%s' may not be referenced in a specification expression"_err_en_US,2910          symbol.name());2911      context_.SetError(symbol);2912      return nullptr;2913    }2914  }2915  return &symbol;2916}2917 2918// Resolve a call to a generic procedure with given actual arguments.2919// adjustActuals is called on procedure bindings to handle pass arg.2920auto ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,2921    const ActualArguments &actuals, const AdjustActuals &adjustActuals,2922    bool isSubroutine, SymbolVector &&tried, bool mightBeStructureConstructor)2923    -> GenericResolution {2924  const Symbol &ultimate{symbol.GetUltimate()};2925  // Check for a match with an explicit INTRINSIC2926  const Symbol *explicitIntrinsic{nullptr};2927  if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {2928    parser::Messages buffer;2929    auto restorer{GetContextualMessages().SetMessages(buffer)};2930    ActualArguments localActuals{actuals};2931    if (context_.intrinsics().Probe(2932            CallCharacteristics{ultimate.name().ToString(), isSubroutine},2933            localActuals, foldingContext_) &&2934        !buffer.AnyFatalError()) {2935      explicitIntrinsic = &ultimate;2936    }2937  }2938  const Symbol *elemental{nullptr}; // matching elemental specific proc2939  const Symbol *nonElemental{nullptr}; // matching non-elemental specific2940  const auto *genericDetails{ultimate.detailsIf<semantics::GenericDetails>()};2941  if (genericDetails && !explicitIntrinsic) {2942    int crtMatchingDistance{cudaInfMatchingValue};2943    for (const Symbol &specific0 : genericDetails->specificProcs()) {2944      const Symbol &specific1{BypassGeneric(specific0)};2945      if (isSubroutine != !IsFunction(specific1)) {2946        continue;2947      }2948      const Symbol *specific{ResolveForward(specific1)};2949      if (!specific) {2950        continue;2951      }2952      if (std::optional<characteristics::Procedure> procedure{2953              characteristics::Procedure::Characterize(2954                  ProcedureDesignator{*specific}, context_.foldingContext(),2955                  /*emitError=*/false)}) {2956        ActualArguments localActuals{actuals};2957        if (specific->has<semantics::ProcBindingDetails>()) {2958          if (!adjustActuals.value()(*specific, localActuals)) {2959            continue;2960          }2961        }2962        if (semantics::CheckInterfaceForGeneric(*procedure, localActuals,2963                context_, false /* no integer conversions */) &&2964            CheckCompatibleArguments(2965                *procedure, localActuals, foldingContext_)) {2966          if ((procedure->IsElemental() && elemental) ||2967              (!procedure->IsElemental() && nonElemental)) {2968            int d{ComputeCudaMatchingDistance(2969                context_.languageFeatures(), *procedure, localActuals)};2970            if (d != crtMatchingDistance) {2971              if (d > crtMatchingDistance) {2972                continue;2973              }2974              // Matching distance is smaller than the previously matched2975              // specific. Let it go through so the current procedure is picked.2976            } else {2977              // 16.9.144(6): a bare NULL() is not allowed as an actual2978              // argument to a generic procedure if the specific procedure2979              // cannot be unambiguously distinguished2980              // Underspecified external procedure actual arguments can2981              // also lead to ambiguity.2982              return {nullptr, true /* due to ambiguity */, std::move(tried)};2983            }2984          }2985          if (!procedure->IsElemental()) {2986            // takes priority over elemental match2987            nonElemental = specific;2988          } else {2989            elemental = specific;2990          }2991          crtMatchingDistance = ComputeCudaMatchingDistance(2992              context_.languageFeatures(), *procedure, localActuals);2993        } else {2994          tried.push_back(*specific);2995        }2996      }2997    }2998  }2999  // Is there a derived type of the same name?3000  const Symbol *derivedType{nullptr};3001  if (mightBeStructureConstructor && !isSubroutine && genericDetails) {3002    if (const Symbol * dt{genericDetails->derivedType()}) {3003      const Symbol &ultimate{dt->GetUltimate()};3004      if (ultimate.has<semantics::DerivedTypeDetails>()) {3005        derivedType = &ultimate;3006      }3007    }3008  }3009  // F'2023 C7108 checking.  No Fortran compiler actually enforces this3010  // constraint, so it's just a portability warning here.3011  if (derivedType && (explicitIntrinsic || nonElemental || elemental) &&3012      context_.ShouldWarn(3013          common::LanguageFeature::AmbiguousStructureConstructor)) {3014    // See whethr there's ambiguity with a structure constructor.3015    bool possiblyAmbiguous{true};3016    if (const semantics::Scope * dtScope{derivedType->scope()}) {3017      parser::Messages buffer;3018      auto restorer{GetContextualMessages().SetMessages(buffer)};3019      std::list<ComponentSpec> componentSpecs;3020      for (const auto &actual : actuals) {3021        if (actual) {3022          ComponentSpec compSpec;3023          if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {3024            compSpec.expr = *expr;3025          } else {3026            possiblyAmbiguous = false;3027          }3028          if (auto loc{actual->sourceLocation()}) {3029            compSpec.source = compSpec.exprSource = *loc;3030          }3031          if (auto kw{actual->keyword()}) {3032            compSpec.hasKeyword = true;3033            compSpec.keywordSymbol = dtScope->FindComponent(*kw);3034          }3035          componentSpecs.emplace_back(std::move(compSpec));3036        } else {3037          possiblyAmbiguous = false;3038        }3039      }3040      semantics::DerivedTypeSpec dtSpec{derivedType->name(), *derivedType};3041      dtSpec.set_scope(*dtScope);3042      possiblyAmbiguous = possiblyAmbiguous &&3043          CheckStructureConstructor(3044              derivedType->name(), dtSpec, std::move(componentSpecs))3045              .has_value() &&3046          !buffer.AnyFatalError();3047    }3048    if (possiblyAmbiguous) {3049      if (explicitIntrinsic) {3050        Warn(common::LanguageFeature::AmbiguousStructureConstructor,3051            "Reference to the intrinsic function '%s' is ambiguous with a structure constructor of the same name"_port_en_US,3052            symbol.name());3053      } else {3054        Warn(common::LanguageFeature::AmbiguousStructureConstructor,3055            "Reference to generic function '%s' (resolving to specific '%s') is ambiguous with a structure constructor of the same name"_port_en_US,3056            symbol.name(),3057            nonElemental ? nonElemental->name() : elemental->name());3058      }3059    }3060  }3061  // Return the right resolution, if there is one.  Explicit intrinsics3062  // are preferred, then non-elements specifics, then elementals, and3063  // lastly structure constructors.3064  if (explicitIntrinsic) {3065    return {explicitIntrinsic, false};3066  } else if (nonElemental) {3067    return {&AccessSpecific(symbol, *nonElemental), false};3068  } else if (elemental) {3069    return {&AccessSpecific(symbol, *elemental), false};3070  }3071  // Check parent derived type3072  if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {3073    if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {3074      auto result{ResolveGeneric(*extended, actuals, adjustActuals,3075          isSubroutine, std::move(tried), false)};3076      if (result.specific != nullptr) {3077        return result;3078      }3079      tried = std::move(result.tried);3080    }3081  }3082  // Structure constructor?3083  if (derivedType) {3084    return {derivedType, false};3085  }3086  // Check for generic or explicit INTRINSIC of the same name in outer scopes.3087  // See 15.5.5.2 for details.3088  if (!symbol.owner().IsGlobal() && !symbol.owner().IsDerivedType()) {3089    if (const Symbol *3090        outer{symbol.owner().parent().FindSymbol(symbol.name())}) {3091      auto result{ResolveGeneric(*outer, actuals, adjustActuals, isSubroutine,3092          std::move(tried), mightBeStructureConstructor)};3093      if (result.specific) {3094        return result;3095      }3096      tried = std::move(result.tried);3097    }3098  }3099  return {nullptr, false, std::move(tried)};3100}3101 3102const Symbol &ExpressionAnalyzer::AccessSpecific(3103    const Symbol &originalGeneric, const Symbol &specific) {3104  if (const auto *hosted{3105          originalGeneric.detailsIf<semantics::HostAssocDetails>()}) {3106    return AccessSpecific(hosted->symbol(), specific);3107  } else if (const auto *used{3108                 originalGeneric.detailsIf<semantics::UseDetails>()}) {3109    const auto &scope{originalGeneric.owner()};3110    if (auto iter{scope.find(specific.name())}; iter != scope.end()) {3111      if (const auto *useDetails{3112              iter->second->detailsIf<semantics::UseDetails>()}) {3113        const Symbol &usedSymbol{useDetails->symbol()};3114        const auto *usedGeneric{3115            usedSymbol.detailsIf<semantics::GenericDetails>()};3116        if (&usedSymbol == &specific ||3117            (usedGeneric && usedGeneric->specific() == &specific)) {3118          return specific;3119        }3120      }3121    }3122    // Create a renaming USE of the specific procedure.3123    auto rename{context_.SaveTempName(3124        used->symbol().owner().GetName().value().ToString() + "$" +3125        specific.owner().GetName().value().ToString() + "$" +3126        specific.name().ToString())};3127    return *const_cast<semantics::Scope &>(scope)3128                .try_emplace(rename, specific.attrs(),3129                    semantics::UseDetails{rename, specific})3130                .first->second;3131  } else {3132    return specific;3133  }3134}3135 3136void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol,3137    bool dueToAmbiguity, bool isSubroutine, ActualArguments &arguments,3138    const SymbolVector &tried) {3139  if (auto *msg{Say(dueToAmbiguity3140              ? "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_US3141              : semantics::IsGenericDefinedOp(symbol)3142              ? "No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US3143              : isSubroutine3144              ? "No specific subroutine of generic '%s' matches the actual arguments"_err_en_US3145              : "No specific function of generic '%s' matches the actual arguments"_err_en_US,3146          symbol.name())}) {3147    parser::ContextualMessages &messages{GetContextualMessages()};3148    semantics::Scope &scope{context_.FindScope(messages.at())};3149    for (const Symbol &specific : tried) {3150      if (auto procChars{characteristics::Procedure::Characterize(3151              specific, GetFoldingContext())}) {3152        if (procChars->HasExplicitInterface()) {3153          if (auto reasons{semantics::CheckExplicitInterface(*procChars,3154                  arguments, context_, &scope, /*intrinsic=*/nullptr,3155                  /*allocActualArgumentConversions=*/false,3156                  /*extentErrors=*/false,3157                  /*ignoreImplicitVsExplicit=*/false)};3158              !reasons.empty()) {3159            reasons.AttachTo(3160                msg->Attach(specific.name(),3161                    "Specific procedure '%s' does not match the actual arguments because"_en_US,3162                    specific.name()),3163                parser::Severity::None);3164          }3165        }3166      }3167    }3168  }3169}3170 3171auto ExpressionAnalyzer::GetCalleeAndArguments(3172    const parser::ProcedureDesignator &pd, ActualArguments &&arguments,3173    bool isSubroutine, bool mightBeStructureConstructor)3174    -> std::optional<CalleeAndArguments> {3175  return common::visit(common::visitors{3176                           [&](const parser::Name &name) {3177                             return GetCalleeAndArguments(name,3178                                 std::move(arguments), isSubroutine,3179                                 mightBeStructureConstructor);3180                           },3181                           [&](const parser::ProcComponentRef &pcr) {3182                             return AnalyzeProcedureComponentRef(3183                                 pcr, std::move(arguments), isSubroutine);3184                           },3185                       },3186      pd.u);3187}3188 3189auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,3190    ActualArguments &&arguments, bool isSubroutine,3191    bool mightBeStructureConstructor) -> std::optional<CalleeAndArguments> {3192  const Symbol *symbol{name.symbol};3193  if (context_.HasError(symbol)) {3194    return std::nullopt; // also handles null symbol3195  }3196  symbol = ResolveForward(*symbol);3197  if (!symbol) {3198    return std::nullopt;3199  }3200  name.symbol = const_cast<Symbol *>(symbol);3201  const Symbol &ultimate{symbol->GetUltimate()};3202  CheckForBadRecursion(name.source, ultimate);3203  bool dueToAmbiguity{false};3204  bool isGenericInterface{ultimate.has<semantics::GenericDetails>()};3205  bool isExplicitIntrinsic{ultimate.attrs().test(semantics::Attr::INTRINSIC)};3206  const Symbol *resolution{nullptr};3207  SymbolVector tried;3208  if (isGenericInterface || isExplicitIntrinsic) {3209    ExpressionAnalyzer::AdjustActuals noAdjustment;3210    auto result{ResolveGeneric(*symbol, arguments, noAdjustment, isSubroutine,3211        SymbolVector{}, mightBeStructureConstructor)};3212    resolution = result.specific;3213    dueToAmbiguity = result.failedDueToAmbiguity;3214    tried = std::move(result.tried);3215    if (resolution) {3216      if (context_.GetPPCBuiltinsScope() &&3217          resolution->name().ToString().rfind("__ppc_", 0) == 0) {3218        semantics::CheckPPCIntrinsic(3219            *symbol, *resolution, arguments, GetFoldingContext());3220      }3221      // re-resolve name to the specific procedure3222      name.symbol = const_cast<Symbol *>(resolution);3223    }3224  } else if (IsProcedure(ultimate) &&3225      ultimate.attrs().test(semantics::Attr::ABSTRACT)) {3226    Say("Abstract procedure interface '%s' may not be referenced"_err_en_US,3227        name.source);3228  } else {3229    resolution = symbol;3230  }3231  if (resolution && context_.targetCharacteristics().isOSWindows()) {3232    semantics::CheckWindowsIntrinsic(*resolution, GetFoldingContext());3233  }3234  if (!resolution || resolution->attrs().test(semantics::Attr::INTRINSIC)) {3235    auto name{resolution ? resolution->name() : ultimate.name()};3236    if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(3237            CallCharacteristics{name.ToString(), isSubroutine}, arguments,3238            GetFoldingContext())}) {3239      CheckBadExplicitType(*specificCall, *symbol);3240      return CalleeAndArguments{3241          ProcedureDesignator{std::move(specificCall->specificIntrinsic)},3242          std::move(specificCall->arguments)};3243    } else {3244      if (isGenericInterface) {3245        EmitGenericResolutionError(3246            *symbol, dueToAmbiguity, isSubroutine, arguments, tried);3247      }3248      return std::nullopt;3249    }3250  }3251  if (resolution->GetUltimate().has<semantics::DerivedTypeDetails>()) {3252    if (mightBeStructureConstructor) {3253      return CalleeAndArguments{3254          semantics::SymbolRef{*resolution}, std::move(arguments)};3255    }3256  } else if (IsProcedure(*resolution)) {3257    return CalleeAndArguments{3258        ProcedureDesignator{*resolution}, std::move(arguments)};3259  }3260  if (!context_.HasError(*resolution)) {3261    AttachDeclaration(3262        Say(name.source, "'%s' is not a callable procedure"_err_en_US,3263            name.source),3264        *resolution);3265  }3266  return std::nullopt;3267}3268 3269// Fortran 2018 expressly states (8.2 p3) that any declared type for a3270// generic intrinsic function "has no effect" on the result type of a3271// call to that intrinsic.  So one can declare "character*8 cos" and3272// still get a real result from "cos(1.)".  This is a dangerous feature,3273// especially since implementations are free to extend their sets of3274// intrinsics, and in doing so might clash with a name in a program.3275// So we emit a warning in this situation, and perhaps it should be an3276// error -- any correctly working program can silence the message by3277// simply deleting the pointless type declaration.3278void ExpressionAnalyzer::CheckBadExplicitType(3279    const SpecificCall &call, const Symbol &intrinsic) {3280  if (intrinsic.GetUltimate().GetType()) {3281    const auto &procedure{call.specificIntrinsic.characteristics.value()};3282    if (const auto &result{procedure.functionResult}) {3283      if (const auto *typeAndShape{result->GetTypeAndShape()}) {3284        if (auto declared{3285                typeAndShape->Characterize(intrinsic, GetFoldingContext())}) {3286          if (!declared->type().IsTkCompatibleWith(typeAndShape->type())) {3287            if (auto *msg{Warn(3288                    common::UsageWarning::IgnoredIntrinsicFunctionType,3289                    "The result type '%s' of the intrinsic function '%s' is not the explicit declared type '%s'"_warn_en_US,3290                    typeAndShape->AsFortran(), intrinsic.name(),3291                    declared->AsFortran())}) {3292              msg->Attach(intrinsic.name(),3293                  "Ignored declaration of intrinsic function '%s'"_en_US,3294                  intrinsic.name());3295            }3296          }3297        }3298      }3299    }3300  }3301}3302 3303void ExpressionAnalyzer::CheckForBadRecursion(3304    parser::CharBlock callSite, const semantics::Symbol &proc) {3305  if (const auto *scope{proc.scope()}) {3306    if (scope->sourceRange().Contains(callSite)) {3307      parser::Message *msg{nullptr};3308      if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3)3309        msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,3310            callSite);3311      } else if (IsAssumedLengthCharacter(proc) && IsExternal(proc)) {3312        // TODO: Also catch assumed PDT type parameters3313        msg = Say( // 15.6.2.1(3)3314            "Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,3315            callSite);3316      } else if (FindCUDADeviceContext(scope)) {3317        msg = Say(3318            "Device subprogram '%s' cannot call itself"_err_en_US, callSite);3319      }3320      AttachDeclaration(msg, proc);3321    }3322  }3323}3324 3325template <typename A> static const Symbol *AssumedTypeDummy(const A &x) {3326  if (const auto *designator{3327          std::get_if<common::Indirection<parser::Designator>>(&x.u)}) {3328    if (const auto *dataRef{3329            std::get_if<parser::DataRef>(&designator->value().u)}) {3330      if (const auto *name{std::get_if<parser::Name>(&dataRef->u)}) {3331        return AssumedTypeDummy(*name);3332      }3333    }3334  }3335  return nullptr;3336}3337template <>3338const Symbol *AssumedTypeDummy<parser::Name>(const parser::Name &name) {3339  if (const Symbol *symbol{name.symbol}) {3340    if (const auto *type{symbol->GetType()}) {3341      if (type->category() == semantics::DeclTypeSpec::TypeStar) {3342        return symbol;3343      }3344    }3345  }3346  return nullptr;3347}3348template <typename A>3349static const Symbol *AssumedTypePointerOrAllocatableDummy(const A &object) {3350  // It is illegal for allocatable of pointer objects to be TYPE(*), but at that3351  // point it is not guaranteed that it has been checked the object has3352  // POINTER or ALLOCATABLE attribute, so do not assume nullptr can be directly3353  // returned.3354  return common::visit(3355      common::visitors{3356          [&](const parser::StructureComponent &x) {3357            return AssumedTypeDummy(x.component);3358          },3359          [&](const parser::Name &x) { return AssumedTypeDummy(x); },3360      },3361      object.u);3362}3363template <>3364const Symbol *AssumedTypeDummy<parser::AllocateObject>(3365    const parser::AllocateObject &x) {3366  return AssumedTypePointerOrAllocatableDummy(x);3367}3368template <>3369const Symbol *AssumedTypeDummy<parser::PointerObject>(3370    const parser::PointerObject &x) {3371  return AssumedTypePointerOrAllocatableDummy(x);3372}3373 3374bool ExpressionAnalyzer::CheckIsValidForwardReference(3375    const semantics::DerivedTypeSpec &dtSpec) {3376  if (dtSpec.IsForwardReferenced()) {3377    Say("Cannot construct value for derived type '%s' before it is defined"_err_en_US,3378        dtSpec.name());3379    return false;3380  }3381  return true;3382}3383 3384std::optional<Chevrons> ExpressionAnalyzer::AnalyzeChevrons(3385    const parser::CallStmt &call) {3386  Chevrons result;3387  auto checkLaunchArg{[&](const Expr<SomeType> &expr, const char *which) {3388    if (auto dyType{expr.GetType()}) {3389      if (dyType->category() == TypeCategory::Integer) {3390        return true;3391      }3392      if (dyType->category() == TypeCategory::Derived &&3393          !dyType->IsPolymorphic() &&3394          IsBuiltinDerivedType(&dyType->GetDerivedTypeSpec(), "dim3")) {3395        return true;3396      }3397    }3398    Say("Kernel launch %s parameter must be either integer or TYPE(dim3)"_err_en_US,3399        which);3400    return false;3401  }};3402  if (const auto &chevrons{call.chevrons}) {3403    auto &starOrExpr{std::get<0>(chevrons->t)};3404    if (starOrExpr.v) {3405      if (auto expr{Analyze(*starOrExpr.v)};3406          expr && checkLaunchArg(*expr, "grid")) {3407        result.emplace_back(*expr);3408      } else {3409        return std::nullopt;3410      }3411    } else {3412      result.emplace_back(3413          AsGenericExpr(evaluate::Constant<evaluate::CInteger>{-1}));3414    }3415    if (auto expr{Analyze(std::get<1>(chevrons->t))};3416        expr && checkLaunchArg(*expr, "block")) {3417      result.emplace_back(*expr);3418    } else {3419      return std::nullopt;3420    }3421    if (const auto &maybeExpr{std::get<2>(chevrons->t)}) {3422      if (auto expr{Analyze(*maybeExpr)}) {3423        result.emplace_back(*expr);3424      } else {3425        return std::nullopt;3426      }3427    }3428    if (const auto &maybeExpr{std::get<3>(chevrons->t)}) {3429      if (auto expr{Analyze(*maybeExpr)}) {3430        result.emplace_back(*expr);3431      } else {3432        return std::nullopt;3433      }3434    }3435  }3436  return std::move(result);3437}3438 3439MaybeExpr ExpressionAnalyzer::Analyze(const parser::FunctionReference &funcRef,3440    std::optional<parser::StructureConstructor> *structureConstructor) {3441  const parser::Call &call{funcRef.v};3442  auto restorer{GetContextualMessages().SetLocation(funcRef.source)};3443  ArgumentAnalyzer analyzer{*this, funcRef.source, true /* isProcedureCall */};3444  for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {3445    analyzer.Analyze(arg, false /* not subroutine call */);3446  }3447  if (analyzer.fatalErrors()) {3448    return std::nullopt;3449  }3450  bool mightBeStructureConstructor{structureConstructor != nullptr};3451  if (std::optional<CalleeAndArguments> callee{GetCalleeAndArguments(3452          std::get<parser::ProcedureDesignator>(call.t), analyzer.GetActuals(),3453          false /* not subroutine */, mightBeStructureConstructor)}) {3454    if (auto *proc{std::get_if<ProcedureDesignator>(&callee->u)}) {3455      return MakeFunctionRef(3456          funcRef.source, std::move(*proc), std::move(callee->arguments));3457    }3458    CHECK(std::holds_alternative<semantics::SymbolRef>(callee->u));3459    const Symbol &symbol{*std::get<semantics::SymbolRef>(callee->u)};3460    if (mightBeStructureConstructor) {3461      // Structure constructor misparsed as function reference?3462      const auto &designator{std::get<parser::ProcedureDesignator>(call.t)};3463      if (const auto *name{std::get_if<parser::Name>(&designator.u)}) {3464        semantics::Scope &scope{context_.FindScope(name->source)};3465        semantics::DerivedTypeSpec dtSpec{name->source, symbol};3466        if (!CheckIsValidForwardReference(dtSpec)) {3467          return std::nullopt;3468        }3469        const semantics::DeclTypeSpec &type{3470            semantics::FindOrInstantiateDerivedType(scope, std::move(dtSpec))};3471        auto &mutableRef{const_cast<parser::FunctionReference &>(funcRef)};3472        *structureConstructor =3473            mutableRef.ConvertToStructureConstructor(type.derivedTypeSpec());3474        // Don't use saved typed expressions left over from argument3475        // analysis; they might not be valid structure components3476        // (e.g., a TYPE(*) argument)3477        auto restorer{DoNotUseSavedTypedExprs()};3478        return Analyze(structureConstructor->value());3479      }3480    }3481    if (!context_.HasError(symbol)) {3482      AttachDeclaration(3483          Say("'%s' is called like a function but is not a procedure"_err_en_US,3484              symbol.name()),3485          symbol);3486      context_.SetError(symbol);3487    }3488  }3489  return std::nullopt;3490}3491 3492static bool HasAlternateReturns(const evaluate::ActualArguments &args) {3493  for (const auto &arg : args) {3494    if (arg && arg->isAlternateReturn()) {3495      return true;3496    }3497  }3498  return false;3499}3500 3501void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {3502  const parser::Call &call{callStmt.call};3503  auto restorer{GetContextualMessages().SetLocation(callStmt.source)};3504  ArgumentAnalyzer analyzer{*this, callStmt.source, true /* isProcedureCall */};3505  const auto &actualArgList{std::get<std::list<parser::ActualArgSpec>>(call.t)};3506  for (const auto &arg : actualArgList) {3507    analyzer.Analyze(arg, true /* is subroutine call */);3508  }3509  if (auto chevrons{AnalyzeChevrons(callStmt)};3510      chevrons && !analyzer.fatalErrors()) {3511    if (std::optional<CalleeAndArguments> callee{3512            GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),3513                analyzer.GetActuals(), true /* subroutine */)}) {3514      ProcedureDesignator *proc{std::get_if<ProcedureDesignator>(&callee->u)};3515      CHECK(proc);3516      bool isKernel{false};3517      if (const Symbol * procSym{proc->GetSymbol()}) {3518        const Symbol &ultimate{procSym->GetUltimate()};3519        if (const auto *subpDetails{3520                ultimate.detailsIf<semantics::SubprogramDetails>()}) {3521          if (auto attrs{subpDetails->cudaSubprogramAttrs()}) {3522            isKernel = *attrs == common::CUDASubprogramAttrs::Global ||3523                *attrs == common::CUDASubprogramAttrs::Grid_Global;3524          }3525        } else if (const auto *procDetails{3526                       ultimate.detailsIf<semantics::ProcEntityDetails>()}) {3527          isKernel = procDetails->isCUDAKernel();3528        }3529        if (isKernel && chevrons->empty()) {3530          Say("'%s' is a kernel subroutine and must be called with kernel launch parameters in chevrons"_err_en_US,3531              procSym->name());3532        }3533      }3534      if (!isKernel && !chevrons->empty()) {3535        Say("Kernel launch parameters in chevrons may not be used unless calling a kernel subroutine"_err_en_US);3536      }3537      if (CheckCall(callStmt.source, *proc, callee->arguments)) {3538        callStmt.typedCall.Reset(3539            new ProcedureRef{std::move(*proc), std::move(callee->arguments),3540                HasAlternateReturns(callee->arguments)},3541            ProcedureRef::Deleter);3542        DEREF(callStmt.typedCall.get()).set_chevrons(std::move(*chevrons));3543        return;3544      }3545    }3546    if (!context_.AnyFatalError()) {3547      std::string buf;3548      llvm::raw_string_ostream dump{buf};3549      parser::DumpTree(dump, callStmt);3550      Say("Internal error: Expression analysis failed on CALL statement: %s"_err_en_US,3551          buf);3552    }3553  }3554}3555 3556const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {3557  if (!x.typedAssignment) {3558    ArgumentAnalyzer analyzer{*this};3559    const auto &variable{std::get<parser::Variable>(x.t)};3560    analyzer.Analyze(variable);3561    const auto &rhsExpr{std::get<parser::Expr>(x.t)};3562    analyzer.Analyze(rhsExpr);3563    std::optional<Assignment> assignment;3564    if (!analyzer.fatalErrors()) {3565      auto restorer{GetContextualMessages().SetLocation(variable.GetSource())};3566      std::optional<ProcedureRef> procRef{analyzer.TryDefinedAssignment()};3567      if (!procRef) {3568        analyzer.CheckForNullPointer(3569            "in a non-pointer intrinsic assignment statement");3570        analyzer.CheckForAssumedRank("in an assignment statement");3571        const Expr<SomeType> &lhs{analyzer.GetExpr(0)};3572        if (auto dyType{lhs.GetType()}) {3573          if (dyType->IsPolymorphic()) { // 10.2.1.2p1(1)3574            const Symbol *lastWhole0{UnwrapWholeSymbolOrComponentDataRef(lhs)};3575            const Symbol *lastWhole{3576                lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};3577            if (!lastWhole || !IsAllocatable(*lastWhole)) {3578              Say("Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);3579            } else if (evaluate::IsCoarray(*lastWhole)) {3580              Say("Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray"_err_en_US);3581            }3582          }3583          if (auto *derived{GetDerivedTypeSpec(*dyType)}) {3584            if (auto iter{FindAllocatableUltimateComponent(*derived)}) {3585              if (ExtractCoarrayRef(lhs)) {3586                Say("Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,3587                    iter.BuildResultDesignatorName());3588              }3589            }3590          }3591        }3592        CheckForWholeAssumedSizeArray(3593            rhsExpr.source, UnwrapWholeSymbolDataRef(analyzer.GetExpr(1)));3594      }3595      assignment.emplace(analyzer.MoveExpr(0), analyzer.MoveExpr(1));3596      if (procRef) {3597        assignment->u = std::move(*procRef);3598      }3599    }3600    x.typedAssignment.Reset(new GenericAssignmentWrapper{std::move(assignment)},3601        GenericAssignmentWrapper::Deleter);3602  }3603  return common::GetPtrFromOptional(x.typedAssignment->v);3604}3605 3606const Assignment *ExpressionAnalyzer::Analyze(3607    const parser::PointerAssignmentStmt &x) {3608  if (!x.typedAssignment) {3609    MaybeExpr lhs{Analyze(std::get<parser::DataRef>(x.t))};3610    MaybeExpr rhs;3611    {3612      auto restorer{AllowNullPointer()};3613      rhs = Analyze(std::get<parser::Expr>(x.t));3614    }3615    if (!lhs || !rhs) {3616      x.typedAssignment.Reset(3617          new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter);3618    } else {3619      Assignment assignment{std::move(*lhs), std::move(*rhs)};3620      common::visit(3621          common::visitors{3622              [&](const std::list<parser::BoundsRemapping> &list) {3623                Assignment::BoundsRemapping bounds;3624                for (const auto &elem : list) {3625                  auto lower{AsSubscript(Analyze(std::get<0>(elem.t)))};3626                  auto upper{AsSubscript(Analyze(std::get<1>(elem.t)))};3627                  if (lower && upper) {3628                    bounds.emplace_back(3629                        Fold(std::move(*lower)), Fold(std::move(*upper)));3630                  }3631                }3632                assignment.u = std::move(bounds);3633              },3634              [&](const std::list<parser::BoundsSpec> &list) {3635                Assignment::BoundsSpec bounds;3636                for (const auto &bound : list) {3637                  if (auto lower{AsSubscript(Analyze(bound.v))}) {3638                    bounds.emplace_back(Fold(std::move(*lower)));3639                  }3640                }3641                assignment.u = std::move(bounds);3642              },3643          },3644          std::get<parser::PointerAssignmentStmt::Bounds>(x.t).u);3645      x.typedAssignment.Reset(3646          new GenericAssignmentWrapper{std::move(assignment)},3647          GenericAssignmentWrapper::Deleter);3648    }3649  }3650  return common::GetPtrFromOptional(x.typedAssignment->v);3651}3652 3653static bool IsExternalCalledImplicitly(3654    parser::CharBlock callSite, const Symbol *symbol) {3655  return symbol && symbol->owner().IsGlobal() &&3656      symbol->has<semantics::SubprogramDetails>() &&3657      (!symbol->scope() /*ENTRY*/ ||3658          !symbol->scope()->sourceRange().Contains(callSite));3659}3660 3661std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(3662    parser::CharBlock callSite, const ProcedureDesignator &proc,3663    ActualArguments &arguments) {3664  bool treatExternalAsImplicit{3665      IsExternalCalledImplicitly(callSite, proc.GetSymbol())};3666  const Symbol *procSymbol{proc.GetSymbol()};3667  std::optional<characteristics::Procedure> chars;3668  if (procSymbol && procSymbol->has<semantics::ProcEntityDetails>() &&3669      procSymbol->owner().IsGlobal()) {3670    // Unknown global external, implicit interface; assume3671    // characteristics from the actual arguments, and check3672    // for consistency with other references.3673    chars = characteristics::Procedure::FromActuals(3674        proc, arguments, context_.foldingContext());3675    if (chars && procSymbol) {3676      // Ensure calls over implicit interfaces are consistent3677      auto name{procSymbol->name()};3678      if (auto iter{implicitInterfaces_.find(name)};3679          iter != implicitInterfaces_.end()) {3680        std::string whyNot;3681        if (!chars->IsCompatibleWith(iter->second.second,3682                /*ignoreImplicitVsExplicit=*/false, &whyNot)) {3683          if (auto *msg{Warn(3684                  common::UsageWarning::IncompatibleImplicitInterfaces,3685                  callSite,3686                  "Reference to the procedure '%s' has an implicit interface that is distinct from another reference: %s"_warn_en_US,3687                  name, whyNot)}) {3688            msg->Attach(3689                iter->second.first, "previous reference to '%s'"_en_US, name);3690          }3691        }3692      } else {3693        implicitInterfaces_.insert(3694            std::make_pair(name, std::make_pair(callSite, *chars)));3695      }3696    }3697  }3698  if (!chars) {3699    chars = characteristics::Procedure::Characterize(3700        proc, context_.foldingContext(), /*emitError=*/true);3701  }3702  bool ok{true};3703  if (chars) {3704    std::string whyNot;3705    if (treatExternalAsImplicit &&3706        !chars->CanBeCalledViaImplicitInterface(&whyNot, /*checkCUDA=*/false)) {3707      if (auto *msg{Say(callSite,3708              "References to the procedure '%s' require an explicit interface"_err_en_US,3709              DEREF(procSymbol).name())};3710          msg && !whyNot.empty()) {3711        msg->Attach(callSite, "%s"_because_en_US, whyNot);3712      }3713    }3714    const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()};3715    bool procIsDummy{procSymbol && IsDummy(*procSymbol)};3716    if (chars->functionResult &&3717        chars->functionResult->IsAssumedLengthCharacter() &&3718        !specificIntrinsic && !procIsDummy) {3719      Say(callSite,3720          "Assumed-length character function must be defined with a length to be called"_err_en_US);3721    }3722    if (!chars->IsPure()) {3723      if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(3724              context_.FindScope(callSite))}) {3725        std::string name;3726        if (procSymbol) {3727          name = "'"s + procSymbol->name().ToString() + "'";3728        } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {3729          name = "'"s + intrinsic->name + "'";3730        }3731        Say(callSite,3732            "Procedure %s referenced in pure subprogram '%s' must be pure too"_err_en_US,3733            name, DEREF(pure->symbol()).name());3734      }3735    }3736    ok &= semantics::CheckArguments(*chars, arguments, context_,3737        context_.FindScope(callSite), treatExternalAsImplicit,3738        /*ignoreImplicitVsExplicit=*/false, specificIntrinsic);3739  }3740  if (ok && !treatExternalAsImplicit && procSymbol &&3741      !(chars && chars->HasExplicitInterface())) {3742    if (const Symbol *global{FindGlobal(*procSymbol)};3743        global && global != procSymbol && IsProcedure(*global)) {3744      // Check a known global definition behind a local interface3745      if (auto globalChars{characteristics::Procedure::Characterize(3746              *global, context_.foldingContext())}) {3747        semantics::CheckArguments(*globalChars, arguments, context_,3748            context_.FindScope(callSite), /*treatExternalAsImplicit=*/true,3749            /*ignoreImplicitVsExplicit=*/false,3750            nullptr /*not specific intrinsic*/);3751      }3752    }3753  }3754  return chars;3755}3756 3757// Unary operations3758 3759MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {3760  if (MaybeExpr operand{Analyze(x.v.value())}) {3761    if (IsNullPointerOrAllocatable(&*operand)) {3762      Say("NULL() may not be parenthesized"_err_en_US);3763    } else if (const semantics::Symbol *symbol{GetLastSymbol(*operand)}) {3764      if (const semantics::Symbol *result{FindFunctionResult(*symbol)}) {3765        if (semantics::IsProcedurePointer(*result)) {3766          Say("A function reference that returns a procedure pointer may not be parenthesized"_err_en_US); // C10033767        }3768      }3769    }3770    return Parenthesize(std::move(*operand));3771  }3772  return std::nullopt;3773}3774 3775static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,3776    NumericOperator opr, const parser::Expr::IntrinsicUnary &x) {3777  ArgumentAnalyzer analyzer{context};3778  analyzer.Analyze(x.v);3779  if (!analyzer.fatalErrors()) {3780    if (analyzer.IsIntrinsicNumeric(opr)) {3781      analyzer.CheckForNullPointer();3782      analyzer.CheckForAssumedRank();3783      if (opr == NumericOperator::Add) {3784        // +x -> (x), not a bare x, because the bounds of the argument must3785        // not be exposed to allocatable assignments or structure constructor3786        // components.3787        return Parenthesize(analyzer.MoveExpr(0));3788      } else {3789        return Negation(context.GetContextualMessages(), analyzer.MoveExpr(0));3790      }3791    } else {3792      return analyzer.TryDefinedOp(AsFortran(opr),3793          "Operand of unary %s must be numeric; have %s"_err_en_US);3794    }3795  }3796  return std::nullopt;3797}3798 3799MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {3800  return NumericUnaryHelper(*this, NumericOperator::Add, x);3801}3802 3803MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Negate &x) {3804  if (const auto *litConst{3805          std::get_if<parser::LiteralConstant>(&x.v.value().u)}) {3806    if (const auto *intConst{3807            std::get_if<parser::IntLiteralConstant>(&litConst->u)}) {3808      return Analyze(*intConst, true);3809    }3810  }3811  return NumericUnaryHelper(*this, NumericOperator::Subtract, x);3812}3813 3814MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {3815  ArgumentAnalyzer analyzer{*this};3816  analyzer.Analyze(x.v);3817  if (!analyzer.fatalErrors()) {3818    if (analyzer.IsIntrinsicLogical()) {3819      analyzer.CheckForNullPointer();3820      analyzer.CheckForAssumedRank();3821      return AsGenericExpr(3822          LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u)));3823    } else {3824      return analyzer.TryDefinedOp(LogicalOperator::Not,3825          "Operand of %s must be LOGICAL; have %s"_err_en_US);3826    }3827  }3828  return std::nullopt;3829}3830 3831MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {3832  // Represent %LOC() exactly as if it had been a call to the LOC() extension3833  // intrinsic function.3834  // Use the actual source for the name of the call for error reporting.3835  std::optional<ActualArgument> arg;3836  if (const Symbol *assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {3837    arg = ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};3838  } else if (MaybeExpr argExpr{Analyze(x.v.value())}) {3839    arg = ActualArgument{std::move(*argExpr)};3840  } else {3841    return std::nullopt;3842  }3843  parser::CharBlock at{GetContextualMessages().at()};3844  CHECK(at.size() >= 4);3845  parser::CharBlock loc{at.begin() + 1, 3};3846  CHECK(loc == "loc");3847  return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});3848}3849 3850MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {3851  const auto &name{std::get<parser::DefinedOpName>(x.t).v};3852  ArgumentAnalyzer analyzer{*this, name.source};3853  analyzer.Analyze(std::get<1>(x.t));3854  return analyzer.TryDefinedOp(name.source.ToString().c_str(),3855      "No operator %s defined for %s"_err_en_US, /*isUserOp=*/true);3856}3857 3858// Binary (dyadic) operations3859 3860template <template <typename> class OPR, NumericOperator opr>3861MaybeExpr NumericBinaryHelper(3862    ExpressionAnalyzer &context, const parser::Expr::IntrinsicBinary &x) {3863  ArgumentAnalyzer analyzer{context};3864  analyzer.Analyze(std::get<0>(x.t));3865  analyzer.Analyze(std::get<1>(x.t));3866  if (!analyzer.fatalErrors()) {3867    if (analyzer.IsIntrinsicNumeric(opr)) {3868      analyzer.CheckForNullPointer();3869      analyzer.CheckForAssumedRank();3870      analyzer.CheckConformance();3871      return NumericOperation<OPR>(context.GetContextualMessages(),3872          analyzer.MoveExpr(0), analyzer.MoveExpr(1),3873          context.GetDefaultKind(TypeCategory::Real));3874    } else {3875      return analyzer.TryDefinedOp(AsFortran(opr),3876          "Operands of %s must be numeric; have %s and %s"_err_en_US);3877    }3878  }3879  return std::nullopt;3880}3881 3882MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Power &x) {3883  return NumericBinaryHelper<Power, NumericOperator::Power>(*this, x);3884}3885 3886MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Multiply &x) {3887  return NumericBinaryHelper<Multiply, NumericOperator::Multiply>(*this, x);3888}3889 3890MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Divide &x) {3891  return NumericBinaryHelper<Divide, NumericOperator::Divide>(*this, x);3892}3893 3894MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Add &x) {3895  return NumericBinaryHelper<Add, NumericOperator::Add>(*this, x);3896}3897 3898MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Subtract &x) {3899  return NumericBinaryHelper<Subtract, NumericOperator::Subtract>(*this, x);3900}3901 3902MaybeExpr ExpressionAnalyzer::Analyze(3903    const parser::Expr::ComplexConstructor &z) {3904  Warn(common::LanguageFeature::ComplexConstructor,3905      "nonstandard usage: generalized COMPLEX constructor"_port_en_US);3906  return AnalyzeComplex(Analyze(std::get<0>(z.t).value()),3907      Analyze(std::get<1>(z.t).value()), "complex constructor");3908}3909 3910MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {3911  ArgumentAnalyzer analyzer{*this};3912  analyzer.Analyze(std::get<0>(x.t));3913  analyzer.Analyze(std::get<1>(x.t));3914  if (!analyzer.fatalErrors()) {3915    if (analyzer.IsIntrinsicConcat()) {3916      analyzer.CheckForNullPointer();3917      analyzer.CheckForAssumedRank();3918      return common::visit(3919          [&](auto &&x, auto &&y) -> MaybeExpr {3920            using T = ResultType<decltype(x)>;3921            if constexpr (std::is_same_v<T, ResultType<decltype(y)>>) {3922              return AsGenericExpr(Concat<T::kind>{std::move(x), std::move(y)});3923            } else {3924              DIE("different types for intrinsic concat");3925            }3926          },3927          std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(0).u).u),3928          std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(1).u).u));3929    } else {3930      return analyzer.TryDefinedOp("//",3931          "Operands of %s must be CHARACTER with the same kind; have %s and %s"_err_en_US);3932    }3933  }3934  return std::nullopt;3935}3936 3937// The Name represents a user-defined intrinsic operator.3938// If the actuals match one of the specific procedures, return a function ref.3939// Otherwise report the error in messages.3940MaybeExpr ExpressionAnalyzer::AnalyzeDefinedOp(const parser::Name &name,3941    ActualArguments &&actuals, const Symbol *&symbol) {3942  if (auto callee{GetCalleeAndArguments(name, std::move(actuals))}) {3943    auto &proc{std::get<evaluate::ProcedureDesignator>(callee->u)};3944    symbol = proc.GetSymbol();3945    return MakeFunctionRef(3946        name.source, std::move(proc), std::move(callee->arguments));3947  } else {3948    return std::nullopt;3949  }3950}3951 3952MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,3953    const parser::Expr::IntrinsicBinary &x) {3954  ArgumentAnalyzer analyzer{context};3955  analyzer.Analyze(std::get<0>(x.t));3956  analyzer.Analyze(std::get<1>(x.t));3957  if (!analyzer.fatalErrors()) {3958    std::optional<DynamicType> leftType{analyzer.GetType(0)};3959    std::optional<DynamicType> rightType{analyzer.GetType(1)};3960    analyzer.ConvertBOZOperand(&leftType, 0, rightType);3961    analyzer.ConvertBOZOperand(&rightType, 1, leftType);3962    if (leftType && rightType &&3963        analyzer.IsIntrinsicRelational(opr, *leftType, *rightType)) {3964      analyzer.CheckForNullPointer("as a relational operand");3965      analyzer.CheckForAssumedRank("as a relational operand");3966      if (auto cmp{Relate(context.GetContextualMessages(), opr,3967              analyzer.MoveExpr(0), analyzer.MoveExpr(1))}) {3968        return AsMaybeExpr(ConvertToKind<TypeCategory::Logical>(3969            context.GetDefaultKind(TypeCategory::Logical),3970            AsExpr(std::move(*cmp))));3971      }3972    } else {3973      return analyzer.TryDefinedOp(opr,3974          leftType && leftType->category() == TypeCategory::Logical &&3975                  rightType && rightType->category() == TypeCategory::Logical3976              ? "LOGICAL operands must be compared using .EQV. or .NEQV."_err_en_US3977              : "Operands of %s must have comparable types; have %s and %s"_err_en_US);3978    }3979  }3980  return std::nullopt;3981}3982 3983MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LT &x) {3984  return RelationHelper(*this, RelationalOperator::LT, x);3985}3986 3987MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LE &x) {3988  return RelationHelper(*this, RelationalOperator::LE, x);3989}3990 3991MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQ &x) {3992  return RelationHelper(*this, RelationalOperator::EQ, x);3993}3994 3995MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NE &x) {3996  return RelationHelper(*this, RelationalOperator::NE, x);3997}3998 3999MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GE &x) {4000  return RelationHelper(*this, RelationalOperator::GE, x);4001}4002 4003MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GT &x) {4004  return RelationHelper(*this, RelationalOperator::GT, x);4005}4006 4007MaybeExpr LogicalBinaryHelper(ExpressionAnalyzer &context, LogicalOperator opr,4008    const parser::Expr::IntrinsicBinary &x) {4009  ArgumentAnalyzer analyzer{context};4010  analyzer.Analyze(std::get<0>(x.t));4011  analyzer.Analyze(std::get<1>(x.t));4012  if (!analyzer.fatalErrors()) {4013    if (analyzer.IsIntrinsicLogical()) {4014      analyzer.CheckForNullPointer("as a logical operand");4015      analyzer.CheckForAssumedRank("as a logical operand");4016      return AsGenericExpr(BinaryLogicalOperation(opr,4017          std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u),4018          std::get<Expr<SomeLogical>>(analyzer.MoveExpr(1).u)));4019    } else {4020      return analyzer.TryDefinedOp(4021          opr, "Operands of %s must be LOGICAL; have %s and %s"_err_en_US);4022    }4023  }4024  return std::nullopt;4025}4026 4027MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::AND &x) {4028  return LogicalBinaryHelper(*this, LogicalOperator::And, x);4029}4030 4031MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::OR &x) {4032  return LogicalBinaryHelper(*this, LogicalOperator::Or, x);4033}4034 4035MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQV &x) {4036  return LogicalBinaryHelper(*this, LogicalOperator::Eqv, x);4037}4038 4039MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NEQV &x) {4040  return LogicalBinaryHelper(*this, LogicalOperator::Neqv, x);4041}4042 4043MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {4044  const auto &name{std::get<parser::DefinedOpName>(x.t).v};4045  ArgumentAnalyzer analyzer{*this, name.source};4046  analyzer.Analyze(std::get<1>(x.t));4047  analyzer.Analyze(std::get<2>(x.t));4048  return analyzer.TryDefinedOp(name.source.ToString().c_str(),4049      "No operator %s defined for %s and %s"_err_en_US, true);4050}4051 4052// Returns true if a parsed function reference should be converted4053// into an array element reference.4054static bool CheckFuncRefToArrayElement(semantics::SemanticsContext &context,4055    const parser::FunctionReference &funcRef) {4056  // Emit message if the function reference fix will end up an array element4057  // reference with no subscripts, or subscripts on a scalar, because it will4058  // not be possible to later distinguish in expressions between an empty4059  // subscript list due to bad subscripts error recovery or because the4060  // user did not put any.4061  auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};4062  const auto *name{std::get_if<parser::Name>(&proc.u)};4063  if (!name) {4064    name = &parser::UnwrapRef<parser::StructureComponent>(4065        std::get<parser::ProcComponentRef>(proc.u))4066                .component;4067  }4068  if (!name->symbol) {4069    return false;4070  } else if (name->symbol->Rank() == 0) {4071    if (const Symbol *function{4072            semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)}) {4073      auto &msg{context.Say(funcRef.source,4074          function->flags().test(Symbol::Flag::StmtFunction)4075              ? "Recursive call to statement function '%s' is not allowed"_err_en_US4076              : "Recursive call to '%s' requires a distinct RESULT in its declaration"_err_en_US,4077          name->source)};4078      AttachDeclaration(&msg, *function);4079      name->symbol = const_cast<Symbol *>(function);4080    }4081    return false;4082  } else {4083    if (std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t).empty()) {4084      auto &msg{context.Say(funcRef.source,4085          "Reference to array '%s' with empty subscript list"_err_en_US,4086          name->source)};4087      if (name->symbol) {4088        AttachDeclaration(&msg, *name->symbol);4089      }4090    }4091    return true;4092  }4093}4094 4095// Converts, if appropriate, an original misparse of ambiguous syntax like4096// A(1) as a function reference into an array reference.4097// Misparsed structure constructors are detected elsewhere after generic4098// function call resolution fails.4099template <typename... A>4100static void FixMisparsedFunctionReference(4101    semantics::SemanticsContext &context, const std::variant<A...> &constU) {4102  // The parse tree is updated in situ when resolving an ambiguous parse.4103  using uType = std::decay_t<decltype(constU)>;4104  auto &u{const_cast<uType &>(constU)};4105  if (auto *func{4106          std::get_if<common::Indirection<parser::FunctionReference>>(&u)}) {4107    parser::FunctionReference &funcRef{func->value()};4108    // Ensure that there are no argument keywords4109    for (const auto &arg :4110        std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t)) {4111      if (std::get<std::optional<parser::Keyword>>(arg.t)) {4112        return;4113      }4114    }4115    auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};4116    if (Symbol *4117        origSymbol{common::visit(4118            common::visitors{4119                [&](parser::Name &name) { return name.symbol; },4120                [&](parser::ProcComponentRef &pcr) {4121                  return parser::UnwrapRef<parser::StructureComponent>(pcr)4122                      .component.symbol;4123                },4124            },4125            proc.u)}) {4126      Symbol &symbol{origSymbol->GetUltimate()};4127      if (symbol.has<semantics::ObjectEntityDetails>() ||4128          symbol.has<semantics::AssocEntityDetails>()) {4129        // Note that expression in AssocEntityDetails cannot be a procedure4130        // pointer as per C1105 so this cannot be a function reference.4131        if constexpr (common::HasMember<common::Indirection<parser::Designator>,4132                          uType>) {4133          if (CheckFuncRefToArrayElement(context, funcRef)) {4134            u = common::Indirection{funcRef.ConvertToArrayElementRef()};4135          }4136        } else {4137          DIE("can't fix misparsed function as array reference");4138        }4139      }4140    }4141  }4142}4143 4144// Common handling of parse tree node types that retain the4145// representation of the analyzed expression.4146template <typename PARSED>4147MaybeExpr ExpressionAnalyzer::ExprOrVariable(4148    const PARSED &x, parser::CharBlock source) {4149  auto restorer{GetContextualMessages().SetLocation(source)};4150  if constexpr (std::is_same_v<PARSED, parser::Expr> ||4151      std::is_same_v<PARSED, parser::Variable>) {4152    FixMisparsedFunctionReference(context_, x.u);4153  }4154  if (AssumedTypeDummy(x)) { // C7104155    Say("TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);4156    ResetExpr(x);4157    return std::nullopt;4158  }4159  MaybeExpr result;4160  if constexpr (common::HasMember<parser::StructureConstructor,4161                    std::decay_t<decltype(x.u)>> &&4162      common::HasMember<common::Indirection<parser::FunctionReference>,4163          std::decay_t<decltype(x.u)>>) {4164    if (const auto *funcRef{4165            std::get_if<common::Indirection<parser::FunctionReference>>(4166                &x.u)}) {4167      // Function references in Exprs might turn out to be misparsed structure4168      // constructors; we have to try generic procedure resolution4169      // first to be sure.4170      std::optional<parser::StructureConstructor> ctor;4171      result = Analyze(funcRef->value(), &ctor);4172      if (ctor) {4173        // A misparsed function reference is really a structure4174        // constructor.  Repair the parse tree in situ.4175        const_cast<PARSED &>(x).u = std::move(*ctor);4176      }4177    } else {4178      result = Analyze(x.u);4179    }4180  } else {4181    result = Analyze(x.u);4182  }4183  if (result) {4184    if constexpr (std::is_same_v<PARSED, parser::Expr>) {4185      if (!isNullPointerOk_ && IsNullPointerOrAllocatable(&*result)) {4186        Say(source,4187            "NULL() may not be used as an expression in this context"_err_en_US);4188      }4189    }4190    SetExpr(x, Fold(std::move(*result)));4191    return x.typedExpr->v;4192  } else {4193    ResetExpr(x);4194    if (!context_.AnyFatalError()) {4195      std::string buf;4196      llvm::raw_string_ostream dump{buf};4197      parser::DumpTree(dump, x);4198      Say("Internal error: Expression analysis failed on: %s"_err_en_US, buf);4199    }4200    return std::nullopt;4201  }4202}4203 4204// This is an optional preliminary pass over parser::Expr subtrees.4205// Given an expression tree, iteratively traverse it in a bottom-up order4206// to analyze all of its subexpressions.  A later normal top-down analysis4207// will then be able to use the results that will have been saved in the4208// parse tree without having to recurse deeply.  This technique keeps4209// absurdly deep expression parse trees from causing the analyzer to overflow4210// its stack.4211MaybeExpr ExpressionAnalyzer::IterativelyAnalyzeSubexpressions(4212    const parser::Expr &top) {4213  std::vector<const parser::Expr *> queue, finish;4214  queue.push_back(&top);4215  do {4216    const parser::Expr &expr{*queue.back()};4217    queue.pop_back();4218    if (!expr.typedExpr) {4219      const parser::Expr::IntrinsicUnary *unary{nullptr};4220      const parser::Expr::IntrinsicBinary *binary{nullptr};4221      common::visit(4222          [&unary, &binary](auto &y) {4223            if constexpr (std::is_convertible_v<decltype(&y),4224                              decltype(unary)>) {4225              // Don't evaluate a constant operand to Negate4226              if (!std::holds_alternative<parser::LiteralConstant>(4227                      y.v.value().u)) {4228                unary = &y;4229              }4230            } else if constexpr (std::is_convertible_v<decltype(&y),4231                                     decltype(binary)>) {4232              binary = &y;4233            }4234          },4235          expr.u);4236      if (unary) {4237        queue.push_back(&unary->v.value());4238      } else if (binary) {4239        queue.push_back(&std::get<0>(binary->t).value());4240        queue.push_back(&std::get<1>(binary->t).value());4241      }4242      finish.push_back(&expr);4243    }4244  } while (!queue.empty());4245  // Analyze the collected subexpressions in bottom-up order.4246  // On an error, bail out and leave partial results in place.4247  if (finish.size() == 1) {4248    const parser::Expr &expr{DEREF(finish.front())};4249    return ExprOrVariable(expr, expr.source);4250  } else {4251    // NULL() operand catching is deferred to operation analysis so4252    // that they can be accepted by defined operators.4253    auto restorer{AllowNullPointer()};4254    MaybeExpr result;4255    for (auto riter{finish.rbegin()}; riter != finish.rend(); ++riter) {4256      const parser::Expr &expr{**riter};4257      result = ExprOrVariable(expr, expr.source);4258      if (!result) {4259        return result;4260      }4261    }4262    return result; // last value was from analysis of "top"4263  }4264}4265 4266MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) {4267  bool wasIterativelyAnalyzing{iterativelyAnalyzingSubexpressions_};4268  MaybeExpr result;4269  if (useSavedTypedExprs_) {4270    if (expr.typedExpr) {4271      return expr.typedExpr->v;4272    }4273    if (!wasIterativelyAnalyzing) {4274      iterativelyAnalyzingSubexpressions_ = true;4275      result = IterativelyAnalyzeSubexpressions(expr);4276    }4277  }4278  if (!result) {4279    result = ExprOrVariable(expr, expr.source);4280  }4281  iterativelyAnalyzingSubexpressions_ = wasIterativelyAnalyzing;4282  return result;4283}4284 4285MaybeExpr ExpressionAnalyzer::Analyze(const parser::Variable &variable) {4286  if (useSavedTypedExprs_ && variable.typedExpr) {4287    return variable.typedExpr->v;4288  }4289  return ExprOrVariable(variable, variable.GetSource());4290}4291 4292MaybeExpr ExpressionAnalyzer::Analyze(const parser::Selector &selector) {4293  if (const auto *var{std::get_if<parser::Variable>(&selector.u)}) {4294    if (!useSavedTypedExprs_ || !var->typedExpr) {4295      parser::CharBlock source{var->GetSource()};4296      auto restorer{GetContextualMessages().SetLocation(source)};4297      FixMisparsedFunctionReference(context_, var->u);4298      if (const auto *funcRef{4299              std::get_if<common::Indirection<parser::FunctionReference>>(4300                  &var->u)}) {4301        // A Selector that parsed as a Variable might turn out during analysis4302        // to actually be a structure constructor.  In that case, repair the4303        // Variable parse tree node into an Expr4304        std::optional<parser::StructureConstructor> ctor;4305        if (MaybeExpr result{Analyze(funcRef->value(), &ctor)}) {4306          if (ctor) {4307            auto &writable{const_cast<parser::Selector &>(selector)};4308            writable.u = parser::Expr{std::move(*ctor)};4309            auto &expr{std::get<parser::Expr>(writable.u)};4310            expr.source = source;4311            SetExpr(expr, Fold(std::move(*result)));4312            return expr.typedExpr->v;4313          } else {4314            SetExpr(*var, Fold(std::move(*result)));4315            return var->typedExpr->v;4316          }4317        } else {4318          ResetExpr(*var);4319          if (context_.AnyFatalError()) {4320            return std::nullopt;4321          }4322        }4323      }4324    }4325    // Not a Variable -> FunctionReference4326    auto restorer{AllowWholeAssumedSizeArray()};4327    return Analyze(selector.u);4328  } else { // Expr4329    return Analyze(selector.u);4330  }4331}4332 4333MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtConstant &x) {4334  auto restorer{common::ScopedSet(inDataStmtConstant_, true)};4335  return ExprOrVariable(x, x.source);4336}4337 4338MaybeExpr ExpressionAnalyzer::Analyze(const parser::AllocateObject &x) {4339  return ExprOrVariable(x, parser::FindSourceLocation(x));4340}4341 4342MaybeExpr ExpressionAnalyzer::Analyze(const parser::PointerObject &x) {4343  return ExprOrVariable(x, parser::FindSourceLocation(x));4344}4345 4346Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(4347    TypeCategory category,4348    const std::optional<parser::KindSelector> &selector) {4349  int defaultKind{GetDefaultKind(category)};4350  if (!selector) {4351    return Expr<SubscriptInteger>{defaultKind};4352  }4353  return common::visit(4354      common::visitors{4355          [&](const parser::ScalarIntConstantExpr &x) {4356            if (MaybeExpr kind{Analyze(x)}) {4357              if (std::optional<std::int64_t> code{ToInt64(*kind)}) {4358                if (CheckIntrinsicKind(category, *code)) {4359                  return Expr<SubscriptInteger>{*code};4360                }4361              } else if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(*kind)}) {4362                return ConvertToType<SubscriptInteger>(std::move(*intExpr));4363              }4364            }4365            return Expr<SubscriptInteger>{defaultKind};4366          },4367          [&](const parser::KindSelector::StarSize &x) {4368            std::intmax_t size = x.v;4369            if (!CheckIntrinsicSize(category, size)) {4370              size = defaultKind;4371            } else if (category == TypeCategory::Complex) {4372              size /= 2;4373            }4374            return Expr<SubscriptInteger>{size};4375          },4376      },4377      selector->u);4378}4379 4380int ExpressionAnalyzer::GetDefaultKind(common::TypeCategory category) {4381  return context_.GetDefaultKind(category);4382}4383 4384DynamicType ExpressionAnalyzer::GetDefaultKindOfType(4385    common::TypeCategory category) {4386  return {category, GetDefaultKind(category)};4387}4388 4389bool ExpressionAnalyzer::CheckIntrinsicKind(4390    TypeCategory category, std::int64_t kind) {4391  if (foldingContext_.targetCharacteristics().IsTypeEnabled(4392          category, kind)) { // C712, C714, C715, C7274393    return true;4394  } else if (foldingContext_.targetCharacteristics().CanSupportType(4395                 category, kind)) {4396    Say("%s(KIND=%jd) is not an enabled type for this target"_err_en_US,4397        ToUpperCase(EnumToString(category)), kind);4398    return true;4399  } else {4400    Say("%s(KIND=%jd) is not a supported type"_err_en_US,4401        ToUpperCase(EnumToString(category)), kind);4402    return false;4403  }4404}4405 4406bool ExpressionAnalyzer::CheckIntrinsicSize(4407    TypeCategory category, std::int64_t size) {4408  std::int64_t kind{size};4409  if (category == TypeCategory::Complex) {4410    // COMPLEX*16 == COMPLEX(KIND=8)4411    if (size % 2 == 0) {4412      kind = size / 2;4413    } else {4414      Say("COMPLEX*%jd is not a supported type"_err_en_US, size);4415      return false;4416    }4417  }4418  return CheckIntrinsicKind(category, kind);4419}4420 4421bool ExpressionAnalyzer::AddImpliedDo(parser::CharBlock name, int kind) {4422  return impliedDos_.insert(std::make_pair(name, kind)).second;4423}4424 4425void ExpressionAnalyzer::RemoveImpliedDo(parser::CharBlock name) {4426  auto iter{impliedDos_.find(name)};4427  if (iter != impliedDos_.end()) {4428    impliedDos_.erase(iter);4429  }4430}4431 4432std::optional<int> ExpressionAnalyzer::IsImpliedDo(4433    parser::CharBlock name) const {4434  auto iter{impliedDos_.find(name)};4435  if (iter != impliedDos_.cend()) {4436    return {iter->second};4437  } else {4438    return std::nullopt;4439  }4440}4441 4442bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,4443    const MaybeExpr &result, TypeCategory category, bool defaultKind) {4444  if (result) {4445    if (auto type{result->GetType()}) {4446      if (type->category() != category) { // C8854447        Say(at, "Must have %s type, but is %s"_err_en_US,4448            ToUpperCase(EnumToString(category)),4449            ToUpperCase(type->AsFortran()));4450        return false;4451      } else if (defaultKind) {4452        int kind{context_.GetDefaultKind(category)};4453        if (type->kind() != kind) {4454          Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US,4455              kind, ToUpperCase(EnumToString(category)),4456              ToUpperCase(type->AsFortran()));4457          return false;4458        }4459      }4460    } else {4461      Say(at, "Must have %s type, but is typeless"_err_en_US,4462          ToUpperCase(EnumToString(category)));4463      return false;4464    }4465  }4466  return true;4467}4468 4469MaybeExpr ExpressionAnalyzer::MakeFunctionRef(parser::CharBlock callSite,4470    ProcedureDesignator &&proc, ActualArguments &&arguments) {4471  if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc.u)}) {4472    if (intrinsic->characteristics.value().attrs.test(4473            characteristics::Procedure::Attr::NullPointer) &&4474        arguments.empty()) {4475      return Expr<SomeType>{NullPointer{}};4476    }4477  }4478  if (const Symbol *symbol{proc.GetSymbol()}) {4479    if (!ResolveForward(*symbol)) {4480      return std::nullopt;4481    }4482  }4483  if (auto chars{CheckCall(callSite, proc, arguments)}) {4484    if (chars->functionResult) {4485      const auto &result{*chars->functionResult};4486      ProcedureRef procRef{std::move(proc), std::move(arguments)};4487      if (result.IsProcedurePointer()) {4488        return Expr<SomeType>{std::move(procRef)};4489      } else {4490        // Not a procedure pointer, so type and shape are known.4491        return TypedWrapper<FunctionRef, ProcedureRef>(4492            DEREF(result.GetTypeAndShape()).type(), std::move(procRef));4493      }4494    } else {4495      Say("Function result characteristics are not known"_err_en_US);4496    }4497  }4498  return std::nullopt;4499}4500 4501MaybeExpr ExpressionAnalyzer::MakeFunctionRef(4502    parser::CharBlock intrinsic, ActualArguments &&arguments) {4503  if (std::optional<SpecificCall> specificCall{4504          context_.intrinsics().Probe(CallCharacteristics{intrinsic.ToString()},4505              arguments, GetFoldingContext())}) {4506    return MakeFunctionRef(intrinsic,4507        ProcedureDesignator{std::move(specificCall->specificIntrinsic)},4508        std::move(specificCall->arguments));4509  } else {4510    return std::nullopt;4511  }4512}4513 4514MaybeExpr ExpressionAnalyzer::AnalyzeComplex(4515    MaybeExpr &&re, MaybeExpr &&im, const char *what) {4516  if (re && re->Rank() > 0) {4517    Warn(common::LanguageFeature::ComplexConstructor,4518        "Real part of %s is not scalar"_port_en_US, what);4519  }4520  if (im && im->Rank() > 0) {4521    Warn(common::LanguageFeature::ComplexConstructor,4522        "Imaginary part of %s is not scalar"_port_en_US, what);4523  }4524  if (re && im) {4525    ConformabilityCheck(GetContextualMessages(), *re, *im);4526  }4527  return AsMaybeExpr(ConstructComplex(GetContextualMessages(), std::move(re),4528      std::move(im), GetDefaultKind(TypeCategory::Real)));4529}4530 4531std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeVariable(4532    const parser::Variable &x) {4533  source_.ExtendToCover(x.GetSource());4534  if (MaybeExpr expr{context_.Analyze(x)}) {4535    if (!IsConstantExpr(*expr)) {4536      ActualArgument actual{std::move(*expr)};4537      SetArgSourceLocation(actual, x.GetSource());4538      return actual;4539    }4540    const Symbol *symbol{GetLastSymbol(*expr)};4541    if (!symbol) {4542      context_.SayAt(x, "Assignment to constant '%s' is not allowed"_err_en_US,4543          x.GetSource());4544    } else if (IsProcedure(*symbol)) {4545      if (auto *msg{context_.SayAt(x,4546              "Assignment to procedure '%s' is not allowed"_err_en_US,4547              symbol->name())}) {4548        if (auto *subp{symbol->detailsIf<semantics::SubprogramDetails>()}) {4549          if (subp->isFunction()) {4550            const auto &result{subp->result().name()};4551            msg->Attach(result, "Function result is '%s'"_en_US, result);4552          }4553        }4554      }4555    } else {4556      context_.SayAt(4557          x, "Assignment to '%s' is not allowed"_err_en_US, symbol->name());4558    }4559  }4560  fatalErrors_ = true;4561  return std::nullopt;4562}4563 4564void ArgumentAnalyzer::Analyze(const parser::Variable &x) {4565  if (auto actual = AnalyzeVariable(x)) {4566    actuals_.emplace_back(std::move(actual));4567  }4568}4569 4570void ArgumentAnalyzer::Analyze(4571    const parser::ActualArgSpec &arg, bool isSubroutine) {4572  // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.4573  std::optional<ActualArgument> actual;4574  auto restorer{context_.AllowWholeAssumedSizeArray()};4575  common::visit(4576      common::visitors{4577          [&](const common::Indirection<parser::Expr> &x) {4578            actual = AnalyzeExpr(x.value());4579          },4580          [&](const parser::AltReturnSpec &label) {4581            if (!isSubroutine) {4582              context_.Say(4583                  "alternate return specification may not appear on function reference"_err_en_US);4584            }4585            actual = ActualArgument(label.v);4586          },4587          [&](const parser::ActualArg::PercentRef &percentRef) {4588            actual = AnalyzeExpr(percentRef.v);4589            if (actual.has_value()) {4590              actual->set_isPercentRef();4591            }4592          },4593          [&](const parser::ActualArg::PercentVal &percentVal) {4594            actual = AnalyzeExpr(percentVal.v);4595            if (actual.has_value()) {4596              actual->set_isPercentVal();4597            }4598          },4599      },4600      std::get<parser::ActualArg>(arg.t).u);4601  if (actual) {4602    if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {4603      actual->set_keyword(argKW->v.source);4604    }4605    actuals_.emplace_back(std::move(*actual));4606  } else {4607    fatalErrors_ = true;4608  }4609}4610 4611bool ArgumentAnalyzer::IsIntrinsicRelational(RelationalOperator opr,4612    const DynamicType &leftType, const DynamicType &rightType) const {4613  CHECK(actuals_.size() == 2);4614  return !(context_.context().languageFeatures().IsEnabled(4615               common::LanguageFeature::CUDA) &&4616             HasDeviceDefinedIntrinsicOpOverride(opr)) &&4617      semantics::IsIntrinsicRelational(4618          opr, leftType, GetRank(0), rightType, GetRank(1));4619}4620 4621bool ArgumentAnalyzer::IsIntrinsicNumeric(NumericOperator opr) const {4622  std::optional<DynamicType> leftType{GetType(0)};4623  if (context_.context().languageFeatures().IsEnabled(4624          common::LanguageFeature::CUDA) &&4625      HasDeviceDefinedIntrinsicOpOverride(AsFortran(opr))) {4626    return false;4627  } else if (actuals_.size() == 1) {4628    if (IsBOZLiteral(0)) {4629      return opr == NumericOperator::Add; // unary '+'4630    } else {4631      return leftType && semantics::IsIntrinsicNumeric(*leftType);4632    }4633  } else {4634    std::optional<DynamicType> rightType{GetType(1)};4635    if (IsBOZLiteral(0) && rightType) { // BOZ opr Integer/Unsigned/Real4636      auto cat1{rightType->category()};4637      return cat1 == TypeCategory::Integer || cat1 == TypeCategory::Unsigned ||4638          cat1 == TypeCategory::Real;4639    } else if (IsBOZLiteral(1) && leftType) { // Integer/Unsigned/Real opr BOZ4640      auto cat0{leftType->category()};4641      return cat0 == TypeCategory::Integer || cat0 == TypeCategory::Unsigned ||4642          cat0 == TypeCategory::Real;4643    } else {4644      return leftType && rightType &&4645          semantics::IsIntrinsicNumeric(4646              *leftType, GetRank(0), *rightType, GetRank(1));4647    }4648  }4649}4650 4651bool ArgumentAnalyzer::IsIntrinsicLogical() const {4652  if (std::optional<DynamicType> leftType{GetType(0)}) {4653    if (actuals_.size() == 1) {4654      return semantics::IsIntrinsicLogical(*leftType);4655    } else if (std::optional<DynamicType> rightType{GetType(1)}) {4656      return semantics::IsIntrinsicLogical(4657          *leftType, GetRank(0), *rightType, GetRank(1));4658    }4659  }4660  return false;4661}4662 4663bool ArgumentAnalyzer::IsIntrinsicConcat() const {4664  if (std::optional<DynamicType> leftType{GetType(0)}) {4665    if (std::optional<DynamicType> rightType{GetType(1)}) {4666      return semantics::IsIntrinsicConcat(4667          *leftType, GetRank(0), *rightType, GetRank(1));4668    }4669  }4670  return false;4671}4672 4673bool ArgumentAnalyzer::CheckConformance() {4674  if (actuals_.size() == 2) {4675    const auto *lhs{actuals_.at(0).value().UnwrapExpr()};4676    const auto *rhs{actuals_.at(1).value().UnwrapExpr()};4677    if (lhs && rhs) {4678      auto &foldingContext{context_.GetFoldingContext()};4679      auto lhShape{GetShape(foldingContext, *lhs)};4680      auto rhShape{GetShape(foldingContext, *rhs)};4681      if (lhShape && rhShape) {4682        if (!evaluate::CheckConformance(foldingContext.messages(), *lhShape,4683                *rhShape, CheckConformanceFlags::EitherScalarExpandable,4684                "left operand", "right operand")4685                 .value_or(false /*fail when conformance is not known now*/)) {4686          fatalErrors_ = true;4687          return false;4688        }4689      }4690    }4691  }4692  return true; // no proven problem4693}4694 4695bool ArgumentAnalyzer::CheckAssignmentConformance() {4696  if (actuals_.size() == 2 && actuals_[0] && actuals_[1]) {4697    const auto *lhs{actuals_[0]->UnwrapExpr()};4698    const auto *rhs{actuals_[1]->UnwrapExpr()};4699    if (lhs && rhs) {4700      auto &foldingContext{context_.GetFoldingContext()};4701      auto lhShape{GetShape(foldingContext, *lhs)};4702      auto rhShape{GetShape(foldingContext, *rhs)};4703      if (lhShape && rhShape) {4704        if (!evaluate::CheckConformance(foldingContext.messages(), *lhShape,4705                *rhShape, CheckConformanceFlags::RightScalarExpandable,4706                "left-hand side", "right-hand side")4707                 .value_or(true /*ok when conformance is not known now*/)) {4708          fatalErrors_ = true;4709          return false;4710        }4711      }4712    }4713  }4714  return true; // no proven problem4715}4716 4717bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {4718  for (const std::optional<ActualArgument> &arg : actuals_) {4719    if (arg && IsNullPointerOrAllocatable(arg->UnwrapExpr())) {4720      context_.Say(4721          source_, "A NULL() pointer is not allowed %s"_err_en_US, where);4722      fatalErrors_ = true;4723      return false;4724    }4725  }4726  return true;4727}4728 4729bool ArgumentAnalyzer::CheckForAssumedRank(const char *where) {4730  for (const std::optional<ActualArgument> &arg : actuals_) {4731    if (arg && semantics::IsAssumedRank(arg->UnwrapExpr())) {4732      context_.Say(source_,4733          "An assumed-rank dummy argument is not allowed %s"_err_en_US, where);4734      fatalErrors_ = true;4735      return false;4736    }4737  }4738  return true;4739}4740 4741bool ArgumentAnalyzer::AnyCUDADeviceData() const {4742  for (const std::optional<ActualArgument> &arg : actuals_) {4743    if (arg) {4744      if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {4745        if (HasCUDADeviceAttrs(*expr)) {4746          return true;4747        }4748      }4749    }4750  }4751  return false;4752}4753 4754// Some operations can be defined with explicit non-type-bound interfaces4755// that would erroneously conflict with intrinsic operations in their4756// types and ranks but have one or more dummy arguments with the DEVICE4757// attribute.4758bool ArgumentAnalyzer::HasDeviceDefinedIntrinsicOpOverride(4759    const char *opr) const {4760  if (AnyCUDADeviceData() && !AnyUntypedOperand() && !AnyMissingOperand()) {4761    std::string oprNameString{"operator("s + opr + ')'};4762    parser::CharBlock oprName{oprNameString};4763    parser::Messages buffer;4764    auto restorer{context_.GetContextualMessages().SetMessages(buffer)};4765    const auto &scope{context_.context().FindScope(source_)};4766    if (Symbol * generic{scope.FindSymbol(oprName)}) {4767      parser::Name name{generic->name(), generic};4768      const Symbol *resultSymbol{nullptr};4769      if (context_.AnalyzeDefinedOp(4770              name, ActualArguments{actuals_}, resultSymbol)) {4771        return true;4772      }4773    }4774  }4775  return false;4776}4777 4778bool ArgumentAnalyzer::HasDeviceDefinedIntrinsicOpOverride(4779    const std::vector<const char *> &oprNames) const {4780  for (const char *opr : oprNames) {4781    if (HasDeviceDefinedIntrinsicOpOverride(opr)) {4782      return true;4783    }4784  }4785  return false;4786}4787 4788MaybeExpr ArgumentAnalyzer::TryDefinedOp(const char *opr,4789    parser::MessageFixedText error, bool isUserOp, bool checkForNullPointer) {4790  if (AnyMissingOperand()) {4791    context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));4792    return std::nullopt;4793  }4794  MaybeExpr result;4795  bool anyPossibilities{false};4796  std::optional<parser::MessageFormattedText> inaccessible;4797  std::vector<const Symbol *> hit;4798  std::string oprNameString{4799      isUserOp ? std::string{opr} : "operator("s + opr + ')'};4800  parser::CharBlock oprName{oprNameString};4801  parser::Messages hitBuffer;4802  {4803    parser::Messages buffer;4804    auto restorer{context_.GetContextualMessages().SetMessages(buffer)};4805    const auto &scope{context_.context().FindScope(source_)};4806 4807    auto FoundOne{[&](MaybeExpr &&thisResult, const Symbol &generic,4808                      const Symbol *resolution) {4809      anyPossibilities = true;4810      if (thisResult) {4811        if (auto thisInaccessible{CheckAccessibleSymbol(scope, generic)}) {4812          inaccessible = thisInaccessible;4813        } else {4814          bool isElemental{IsElementalProcedure(DEREF(resolution))};4815          bool hitsAreNonElemental{4816              !hit.empty() && !IsElementalProcedure(DEREF(hit[0]))};4817          if (isElemental && hitsAreNonElemental) {4818            // ignore elemental resolutions in favor of a non-elemental one4819          } else {4820            if (!isElemental && !hitsAreNonElemental) {4821              hit.clear();4822            }4823            result = std::move(thisResult);4824            hit.push_back(resolution);4825            hitBuffer = std::move(buffer);4826          }4827        }4828      }4829    }};4830 4831    if (Symbol * generic{scope.FindSymbol(oprName)}; generic && !fatalErrors_) {4832      parser::Name name{generic->name(), generic};4833      const Symbol *resultSymbol{nullptr};4834      MaybeExpr possibleResult{context_.AnalyzeDefinedOp(4835          name, ActualArguments{actuals_}, resultSymbol)};4836      FoundOne(std::move(possibleResult), *generic, resultSymbol);4837    }4838    for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {4839      buffer.clear();4840      const Symbol *generic{nullptr};4841      if (const Symbol *4842          binding{FindBoundOp(4843              oprName, passIndex, generic, /*isSubroutine=*/false)}) {4844        FoundOne(TryBoundOp(*binding, passIndex), DEREF(generic), binding);4845      }4846    }4847  }4848  if (result) {4849    if (hit.size() > 1) {4850      if (auto *msg{context_.Say(4851              "%zd matching accessible generic interfaces for %s were found"_err_en_US,4852              hit.size(), ToUpperCase(opr))}) {4853        for (const Symbol *symbol : hit) {4854          AttachDeclaration(*msg, *symbol);4855        }4856      }4857    }4858    if (auto *msgs{context_.GetContextualMessages().messages()}) {4859      msgs->Annex(std::move(hitBuffer));4860    }4861  } else if (inaccessible) {4862    context_.Say(source_, std::move(*inaccessible));4863  } else if (anyPossibilities) {4864    SayNoMatch(ToUpperCase(oprNameString), false);4865  } else if (actuals_.size() == 2 && !AreConformable()) {4866    context_.Say(4867        "Operands of %s are not conformable; have rank %d and rank %d"_err_en_US,4868        ToUpperCase(opr), actuals_[0]->Rank(), actuals_[1]->Rank());4869  } else if (!CheckForAssumedRank()) {4870  } else if (checkForNullPointer && !CheckForNullPointer()) {4871  } else { // use the supplied error4872    context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));4873  }4874  return result;4875}4876 4877MaybeExpr ArgumentAnalyzer::TryDefinedOp(4878    const std::vector<const char *> &oprs, parser::MessageFixedText error) {4879  if (oprs.size() == 1) {4880    return TryDefinedOp(oprs[0], error);4881  }4882  MaybeExpr result;4883  std::vector<const char *> hit;4884  parser::Messages hitBuffer;4885  {4886    for (std::size_t i{0}; i < oprs.size(); ++i) {4887      parser::Messages buffer;4888      auto restorer{context_.GetContextualMessages().SetMessages(buffer)};4889      if (MaybeExpr thisResult{TryDefinedOp(oprs[i], error, /*isUserOp=*/false,4890              /*checkForNullPointer=*/false)}) {4891        result = std::move(thisResult);4892        hit.push_back(oprs[i]);4893        hitBuffer = std::move(buffer);4894      }4895    }4896  }4897  if (hit.empty()) { // run TryDefinedOp() again just to emit errors4898    CHECK(!TryDefinedOp(oprs[0], error).has_value());4899  } else if (hit.size() > 1) {4900    context_.Say(4901        "Matching accessible definitions were found with %zd variant spellings of the generic operator ('%s', '%s')"_err_en_US,4902        hit.size(), ToUpperCase(hit[0]), ToUpperCase(hit[1]));4903  } else { // one hit; preserve errors4904    context_.context().messages().Annex(std::move(hitBuffer));4905  }4906  return result;4907}4908 4909MaybeExpr ArgumentAnalyzer::TryBoundOp(const Symbol &symbol, int passIndex) {4910  ActualArguments localActuals{actuals_};4911  const Symbol *proc{GetBindingResolution(GetType(passIndex), symbol)};4912  if (!proc) {4913    proc = &symbol;4914    localActuals.at(passIndex).value().set_isPassedObject();4915  }4916  CheckConformance();4917  return context_.MakeFunctionRef(4918      source_, ProcedureDesignator{*proc}, std::move(localActuals));4919}4920 4921std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {4922  using semantics::Tristate;4923  const Expr<SomeType> &lhs{GetExpr(0)};4924  const Expr<SomeType> &rhs{GetExpr(1)};4925  std::optional<DynamicType> lhsType{lhs.GetType()};4926  std::optional<DynamicType> rhsType{rhs.GetType()};4927  int lhsRank{lhs.Rank()};4928  int rhsRank{rhs.Rank()};4929  Tristate isDefined{4930      semantics::IsDefinedAssignment(lhsType, lhsRank, rhsType, rhsRank)};4931  if (isDefined == Tristate::No) {4932    // Make implicit conversion explicit, unless it is an assignment to a whole4933    // allocatable (the explicit conversion would prevent the propagation of the4934    // right hand side if it is a variable). Lowering will deal with the4935    // conversion in this case.4936    if (lhsType) {4937      if (rhsType) {4938        FoldingContext &foldingContext{context_.GetFoldingContext()};4939        auto restorer{foldingContext.messages().SetLocation(4940            actuals_.at(1).value().sourceLocation().value_or(4941                foldingContext.messages().at()))};4942        CheckRealWidening(rhs, lhsType, foldingContext);4943        if (!IsAllocatableDesignator(lhs) || context_.inWhereBody()) {4944          AddAssignmentConversion(*lhsType, *rhsType);4945        }4946      } else if (IsBOZLiteral(1)) {4947        ConvertBOZAssignmentRHS(*lhsType);4948        if (IsBOZLiteral(1)) {4949          context_.Say(4950              "Right-hand side of this assignment may not be BOZ"_err_en_US);4951          fatalErrors_ = true;4952        }4953      }4954    }4955    if (!fatalErrors_) {4956      CheckAssignmentConformance();4957    }4958    return std::nullopt; // user-defined assignment not allowed for these args4959  }4960  auto restorer{context_.GetContextualMessages().SetLocation(source_)};4961  bool isAmbiguous{false};4962  if (std::optional<ProcedureRef> procRef{4963          GetDefinedAssignmentProc(isAmbiguous)}) {4964    if (context_.inWhereBody() && !procRef->proc().IsElemental()) { // C10324965      context_.Say(4966          "Defined assignment in WHERE must be elemental, but '%s' is not"_err_en_US,4967          DEREF(procRef->proc().GetSymbol()).name());4968    }4969    context_.CheckCall(source_, procRef->proc(), procRef->arguments());4970    return std::move(*procRef);4971  }4972  if (isDefined == Tristate::Yes) {4973    if (isAmbiguous || !lhsType || !rhsType ||4974        (lhsRank != rhsRank && rhsRank != 0) ||4975        !OkLogicalIntegerAssignment(lhsType->category(), rhsType->category())) {4976      SayNoMatch(4977          "ASSIGNMENT(=)", /*isAssignment=*/true, /*isAmbiguous=*/isAmbiguous);4978    }4979  } else if (!fatalErrors_) {4980    CheckAssignmentConformance();4981  }4982  return std::nullopt;4983}4984 4985bool ArgumentAnalyzer::OkLogicalIntegerAssignment(4986    TypeCategory lhs, TypeCategory rhs) {4987  if (!context_.context().languageFeatures().IsEnabled(4988          common::LanguageFeature::LogicalIntegerAssignment)) {4989    return false;4990  }4991  std::optional<parser::MessageFixedText> msg;4992  if (lhs == TypeCategory::Integer && rhs == TypeCategory::Logical) {4993    // allow assignment to LOGICAL from INTEGER as a legacy extension4994    msg = "assignment of LOGICAL to INTEGER"_port_en_US;4995  } else if (lhs == TypeCategory::Logical && rhs == TypeCategory::Integer) {4996    // ... and assignment to LOGICAL from INTEGER4997    msg = "assignment of INTEGER to LOGICAL"_port_en_US;4998  } else {4999    return false;5000  }5001  context_.Warn(5002      common::LanguageFeature::LogicalIntegerAssignment, std::move(*msg));5003  return true;5004}5005 5006std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc(5007    bool &isAmbiguous) {5008  const Symbol *proc{nullptr};5009  bool isProcElemental{false};5010  std::optional<int> passedObjectIndex;5011  std::string oprNameString{"assignment(=)"};5012  parser::CharBlock oprName{oprNameString};5013  const auto &scope{context_.context().FindScope(source_)};5014  isAmbiguous = false;5015  {5016    auto restorer{context_.GetContextualMessages().DiscardMessages()};5017    if (const Symbol *symbol{scope.FindSymbol(oprName)}) {5018      ExpressionAnalyzer::AdjustActuals noAdjustment;5019      proc = context_5020                 .ResolveGeneric(5021                     *symbol, actuals_, noAdjustment, true, SymbolVector{})5022                 .specific;5023      if (proc) {5024        isProcElemental = IsElementalProcedure(*proc);5025      }5026    }5027    for (std::size_t i{0}; (!proc || isProcElemental) && i < actuals_.size();5028        ++i) {5029      const Symbol *generic{nullptr};5030      if (const Symbol *binding{FindBoundOp(oprName, i, generic,5031              /*isSubroutine=*/true, /*isAmbiguous=*/&isAmbiguous)}) {5032        // ignore inaccessible type-bound ASSIGNMENT(=) generic5033        if (!CheckAccessibleSymbol(scope, DEREF(generic))) {5034          const Symbol *resolution{GetBindingResolution(GetType(i), *binding)};5035          const Symbol &newProc{*(resolution ? resolution : binding)};5036          bool isElemental{IsElementalProcedure(newProc)};5037          if (!proc || !isElemental) {5038            // Non-elemental resolution overrides elemental5039            proc = &newProc;5040            isProcElemental = isElemental;5041            if (resolution) {5042              passedObjectIndex.reset();5043            } else {5044              passedObjectIndex = i;5045            }5046          }5047        }5048      }5049    }5050  }5051  if (!proc) {5052    return std::nullopt;5053  }5054  ActualArguments actualsCopy{actuals_};5055  // Ensure that the RHS argument is not passed as a variable unless5056  // the dummy argument has the VALUE attribute.5057  if (evaluate::IsVariable(actualsCopy.at(1).value().UnwrapExpr())) {5058    auto chars{evaluate::characteristics::Procedure::Characterize(5059        *proc, context_.GetFoldingContext())};5060    const auto *rhsDummy{chars && chars->dummyArguments.size() == 25061            ? std::get_if<evaluate::characteristics::DummyDataObject>(5062                  &chars->dummyArguments.at(1).u)5063            : nullptr};5064    if (!rhsDummy ||5065        !rhsDummy->attrs.test(5066            evaluate::characteristics::DummyDataObject::Attr::Value)) {5067      actualsCopy.at(1).value().Parenthesize();5068    }5069  }5070  if (passedObjectIndex) {5071    actualsCopy[*passedObjectIndex]->set_isPassedObject();5072  }5073  return ProcedureRef{ProcedureDesignator{*proc}, std::move(actualsCopy)};5074}5075 5076void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {5077  os << "source_: " << source_.ToString() << " fatalErrors_ = " << fatalErrors_5078     << '\n';5079  for (const auto &actual : actuals_) {5080    if (!actual.has_value()) {5081      os << "- error\n";5082    } else if (const Symbol *symbol{actual->GetAssumedTypeDummy()}) {5083      os << "- assumed type: " << symbol->name().ToString() << '\n';5084    } else if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {5085      expr->AsFortran(os << "- expr: ") << '\n';5086    } else {5087      DIE("bad ActualArgument");5088    }5089  }5090}5091 5092std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(5093    const parser::Expr &expr) {5094  source_.ExtendToCover(expr.source);5095  if (const Symbol *assumedTypeDummy{AssumedTypeDummy(expr)}) {5096    ResetExpr(expr);5097    if (isProcedureCall_) {5098      ActualArgument arg{ActualArgument::AssumedType{*assumedTypeDummy}};5099      SetArgSourceLocation(arg, expr.source);5100      return std::move(arg);5101    }5102    context_.SayAt(expr.source,5103        "TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);5104  } else if (MaybeExpr argExpr{AnalyzeExprOrWholeAssumedSizeArray(expr)}) {5105    if (isProcedureCall_ || !IsProcedureDesignator(*argExpr)) {5106      // Pad Hollerith actual argument with spaces up to a multiple of 85107      // bytes, in case the data are interpreted as double precision5108      // (or a smaller numeric type) by legacy code.5109      if (auto hollerith{UnwrapExpr<Constant<Ascii>>(*argExpr)};5110          hollerith && hollerith->wasHollerith()) {5111        std::string bytes{hollerith->values()};5112        while ((bytes.size() % 8) != 0) {5113          bytes += ' ';5114        }5115        Constant<Ascii> c{std::move(bytes)};5116        c.set_wasHollerith(true);5117        argExpr = AsGenericExpr(std::move(c));5118      }5119      ActualArgument arg{std::move(*argExpr)};5120      SetArgSourceLocation(arg, expr.source);5121      return std::move(arg);5122    }5123    context_.SayAt(expr.source,5124        IsFunctionDesignator(*argExpr)5125            ? "Function call must have argument list"_err_en_US5126            : "Subroutine name is not allowed here"_err_en_US);5127  }5128  return std::nullopt;5129}5130 5131MaybeExpr ArgumentAnalyzer::AnalyzeExprOrWholeAssumedSizeArray(5132    const parser::Expr &expr) {5133  // If an expression's parse tree is a whole assumed-size array:5134  //   Expr -> Designator -> DataRef -> Name5135  // treat it as a special case for argument passing and bypass5136  // the C1002/C1014 constraint checking in expression semantics.5137  if (const auto *name{parser::Unwrap<parser::Name>(expr)}) {5138    if (name->symbol && semantics::IsAssumedSizeArray(*name->symbol)) {5139      auto restorer{context_.AllowWholeAssumedSizeArray()};5140      return context_.Analyze(expr);5141    }5142  }5143  auto restorer{context_.AllowNullPointer()};5144  return context_.Analyze(expr);5145}5146 5147bool ArgumentAnalyzer::AreConformable() const {5148  CHECK(actuals_.size() == 2);5149  return actuals_[0] && actuals_[1] &&5150      evaluate::AreConformable(*actuals_[0], *actuals_[1]);5151}5152 5153// Look for a type-bound operator in the type of arg number passIndex.5154const Symbol *ArgumentAnalyzer::FindBoundOp(parser::CharBlock oprName,5155    int passIndex, const Symbol *&generic, bool isSubroutine,5156    bool *isAmbiguous) {5157  const auto *type{GetDerivedTypeSpec(GetType(passIndex))};5158  const semantics::Scope *scope{type ? type->scope() : nullptr};5159  if (scope) {5160    // Use the original type definition's scope, since PDT5161    // instantiations don't have redundant copies of bindings or5162    // generics.5163    scope = DEREF(scope->derivedTypeSpec()).typeSymbol().scope();5164  }5165  generic = scope ? scope->FindComponent(oprName) : nullptr;5166  if (generic) {5167    ExpressionAnalyzer::AdjustActuals adjustment{5168        [&](const Symbol &proc, ActualArguments &) {5169          return passIndex == GetPassIndex(proc).value_or(-1);5170        }};5171    auto result{context_.ResolveGeneric(5172        *generic, actuals_, adjustment, isSubroutine, SymbolVector{})};5173    if (const Symbol *binding{result.specific}) {5174      CHECK(binding->has<semantics::ProcBindingDetails>());5175      // Use the most recent override of the binding, if any5176      return scope->FindComponent(binding->name());5177    } else {5178      if (isAmbiguous) {5179        *isAmbiguous = result.failedDueToAmbiguity;5180      }5181      context_.EmitGenericResolutionError(*generic, result.failedDueToAmbiguity,5182          isSubroutine, actuals_, result.tried);5183    }5184  }5185  return nullptr;5186}5187 5188// If there is an implicit conversion between intrinsic types, make it explicit5189void ArgumentAnalyzer::AddAssignmentConversion(5190    const DynamicType &lhsType, const DynamicType &rhsType) {5191  if (lhsType.category() == rhsType.category() &&5192      (lhsType.category() == TypeCategory::Derived ||5193          lhsType.kind() == rhsType.kind())) {5194    // no conversion necessary5195  } else if (auto rhsExpr{evaluate::Fold(context_.GetFoldingContext(),5196                 evaluate::ConvertToType(lhsType, MoveExpr(1)))}) {5197    std::optional<parser::CharBlock> source;5198    if (actuals_[1]) {5199      source = actuals_[1]->sourceLocation();5200    }5201    actuals_[1] = ActualArgument{*rhsExpr};5202    SetArgSourceLocation(actuals_[1], source);5203  } else {5204    actuals_[1] = std::nullopt;5205  }5206}5207 5208std::optional<DynamicType> ArgumentAnalyzer::GetType(std::size_t i) const {5209  return i < actuals_.size() ? actuals_[i].value().GetType() : std::nullopt;5210}5211int ArgumentAnalyzer::GetRank(std::size_t i) const {5212  return i < actuals_.size() ? actuals_[i].value().Rank() : 0;5213}5214 5215// If the argument at index i is a BOZ literal, convert its type to match the5216// otherType.  If it's REAL, convert to REAL; if it's UNSIGNED, convert to5217// UNSIGNED; otherwise, convert to INTEGER.5218// Note that IBM supports comparing BOZ literals to CHARACTER operands.  That5219// is not currently supported.5220void ArgumentAnalyzer::ConvertBOZOperand(std::optional<DynamicType> *thisType,5221    std::size_t i, std::optional<DynamicType> otherType) {5222  if (IsBOZLiteral(i)) {5223    Expr<SomeType> &&argExpr{MoveExpr(i)};5224    auto *boz{std::get_if<BOZLiteralConstant>(&argExpr.u)};5225    if (otherType && otherType->category() == TypeCategory::Real) {5226      int kind{context_.context().GetDefaultKind(TypeCategory::Real)};5227      MaybeExpr realExpr{5228          ConvertToKind<TypeCategory::Real>(kind, std::move(*boz))};5229      actuals_[i] = std::move(realExpr.value());5230      if (thisType) {5231        thisType->emplace(TypeCategory::Real, kind);5232      }5233    } else if (otherType && otherType->category() == TypeCategory::Unsigned) {5234      int kind{context_.context().GetDefaultKind(TypeCategory::Unsigned)};5235      MaybeExpr unsignedExpr{5236          ConvertToKind<TypeCategory::Unsigned>(kind, std::move(*boz))};5237      actuals_[i] = std::move(unsignedExpr.value());5238      if (thisType) {5239        thisType->emplace(TypeCategory::Unsigned, kind);5240      }5241    } else {5242      int kind{context_.context().GetDefaultKind(TypeCategory::Integer)};5243      MaybeExpr intExpr{5244          ConvertToKind<TypeCategory::Integer>(kind, std::move(*boz))};5245      actuals_[i] = std::move(*intExpr);5246      if (thisType) {5247        thisType->emplace(TypeCategory::Integer, kind);5248      }5249    }5250  }5251}5252 5253void ArgumentAnalyzer::ConvertBOZAssignmentRHS(const DynamicType &lhsType) {5254  if (lhsType.category() == TypeCategory::Integer ||5255      lhsType.category() == TypeCategory::Unsigned ||5256      lhsType.category() == TypeCategory::Real) {5257    Expr<SomeType> rhs{MoveExpr(1)};5258    if (MaybeExpr converted{ConvertToType(lhsType, std::move(rhs))}) {5259      actuals_[1] = std::move(*converted);5260    }5261  }5262}5263 5264// Report error resolving opr when there is a user-defined one available5265void ArgumentAnalyzer::SayNoMatch(5266    const std::string &opr, bool isAssignment, bool isAmbiguous) {5267  std::string type0{TypeAsFortran(0)};5268  auto rank0{actuals_[0]->Rank()};5269  std::string prefix{"No intrinsic or user-defined "s + opr + " matches"};5270  if (isAmbiguous) {5271    prefix = "Multiple specific procedures for the generic "s + opr + " match";5272  }5273  if (actuals_.size() == 1) {5274    if (rank0 > 0) {5275      context_.Say("%s rank %d array of %s"_err_en_US, prefix, rank0, type0);5276    } else {5277      context_.Say("%s operand type %s"_err_en_US, prefix, type0);5278    }5279  } else {5280    std::string type1{TypeAsFortran(1)};5281    auto rank1{actuals_[1]->Rank()};5282    if (rank0 > 0 && rank1 > 0 && rank0 != rank1) {5283      context_.Say("%s rank %d array of %s and rank %d array of %s"_err_en_US,5284          prefix, rank0, type0, rank1, type1);5285    } else if (isAssignment && rank0 != rank1) {5286      if (rank0 == 0) {5287        context_.Say("%s scalar %s and rank %d array of %s"_err_en_US, prefix,5288            type0, rank1, type1);5289      } else {5290        context_.Say("%s rank %d array of %s and scalar %s"_err_en_US, prefix,5291            rank0, type0, type1);5292      }5293    } else {5294      context_.Say(5295          "%s operand types %s and %s"_err_en_US, prefix, type0, type1);5296    }5297  }5298}5299 5300std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {5301  if (i >= actuals_.size() || !actuals_[i]) {5302    return "missing argument";5303  } else if (std::optional<DynamicType> type{GetType(i)}) {5304    return type->IsAssumedType()         ? "TYPE(*)"s5305        : type->IsUnlimitedPolymorphic() ? "CLASS(*)"s5306        : type->IsPolymorphic()          ? type->AsFortran()5307        : type->category() == TypeCategory::Derived5308        ? "TYPE("s + type->AsFortran() + ')'5309        : type->category() == TypeCategory::Character5310        ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'5311        : ToUpperCase(type->AsFortran());5312  } else {5313    return "untyped";5314  }5315}5316 5317bool ArgumentAnalyzer::AnyUntypedOperand() const {5318  for (const auto &actual : actuals_) {5319    if (actual && !actual->GetType() &&5320        !IsBareNullPointer(actual->UnwrapExpr())) {5321      return true;5322    }5323  }5324  return false;5325}5326 5327bool ArgumentAnalyzer::AnyMissingOperand() const {5328  for (const auto &actual : actuals_) {5329    if (!actual) {5330      return true;5331    }5332  }5333  return false;5334}5335} // namespace Fortran::evaluate5336 5337namespace Fortran::semantics {5338evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(5339    SemanticsContext &context, common::TypeCategory category,5340    const std::optional<parser::KindSelector> &selector) {5341  evaluate::ExpressionAnalyzer analyzer{context};5342  CHECK(context.location().has_value());5343  auto restorer{5344      analyzer.GetContextualMessages().SetLocation(*context.location())};5345  return analyzer.AnalyzeKindSelector(category, selector);5346}5347 5348ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}5349 5350bool ExprChecker::Pre(const parser::DataStmtObject &obj) {5351  exprAnalyzer_.set_inDataStmtObject(true);5352  return true;5353}5354 5355void ExprChecker::Post(const parser::DataStmtObject &obj) {5356  exprAnalyzer_.set_inDataStmtObject(false);5357}5358 5359bool ExprChecker::Pre(const parser::DataImpliedDo &ido) {5360  parser::Walk(std::get<parser::DataImpliedDo::Bounds>(ido.t), *this);5361  const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(ido.t)};5362  const auto &name{parser::UnwrapRef<parser::Name>(bounds.name)};5363  int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};5364  if (const auto dynamicType{evaluate::DynamicType::From(DEREF(name.symbol))}) {5365    if (dynamicType->category() == TypeCategory::Integer) {5366      kind = dynamicType->kind();5367    }5368  }5369  exprAnalyzer_.AddImpliedDo(name.source, kind);5370  parser::Walk(std::get<std::list<parser::DataIDoObject>>(ido.t), *this);5371  exprAnalyzer_.RemoveImpliedDo(name.source);5372  return false;5373}5374 5375bool ExprChecker::Walk(const parser::Program &program) {5376  parser::Walk(program, *this);5377  return !context_.AnyFatalError();5378}5379} // namespace Fortran::semantics5380