call.h

//===-- include/flang/Evaluate/call.h ---------------------------*- C++ -*-===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//
 
#ifndef FORTRAN_EVALUATE_CALL_H_
#define FORTRAN_EVALUATE_CALL_H_
 
#include "common.h"
#include "constant.h"
#include "formatting.h"
#include "type.h"
#include "flang/Common/indirection.h"
#include "flang/Common/reference.h"
#include "flang/Parser/char-block.h"
#include "flang/Semantics/attr.h"
#include "flang/Support/Fortran.h"
#include <optional>
#include <vector>
 
namespace llvm {
class raw_ostream;
}
 
namespace Fortran::semantics {
class Symbol;
}
 
// Mutually referential data structures are represented here with forward
// declarations of hitherto undefined class types and a level of indirection.
namespace Fortran::evaluate {
class Component;
class IntrinsicProcTable;
} // namespace Fortran::evaluate
namespace Fortran::evaluate::characteristics {
struct DummyArgument;
struct Procedure;
} // namespace Fortran::evaluate::characteristics
 
extern template class Fortran::common::Indirection<Fortran::evaluate::Component,
    true>;
extern template class Fortran::common::Indirection<
    Fortran::evaluate::characteristics::Procedure, true>;
 
namespace Fortran::evaluate {
 
using semantics::Symbol;
using SymbolRef = common::Reference<const Symbol>;
 
class ActualArgument {
public:
  ENUM_CLASS(Attr, PassedObject, PercentVal, PercentRef);
  using Attrs = common::EnumSet<Attr, Attr_enumSize>;
 
  // Dummy arguments that are TYPE(*) can be forwarded as actual arguments.
  // Since that's the only thing one may do with them in Fortran, they're
  // represented in expressions as a special case of an actual argument.
  class AssumedType {
  public:
    explicit AssumedType(const Symbol &);
    DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(AssumedType)
    const Symbol &symbol() const { return symbol_; }
    int Rank() const;
    bool operator==(const AssumedType &that) const {
      return &*symbol_ == &*that.symbol_;
    }
    llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
  private:
    SymbolRef symbol_;
  };
 
  // F2023 R1526 conditional-arg: runtime selection of actual arguments.
  // Recursive structure mirroring the parser: each ConditionalArg holds
  // a condition, a consequent, and a tail that is either another
  // ConditionalArg (continuing the chain) or a terminal Consequent.
  // std::nullopt represents .NIL. (absent optional argument).
  class ConditionalArg {
  public:
    using Consequent =
        std::optional<common::CopyableIndirection<Expr<SomeType>>>;
    using ConditionalArgPartOrConsequent =
        std::variant<common::CopyableIndirection<ConditionalArg>, Consequent>;
 
    ConditionalArg(Expr<SomeLogical> &&condition, Consequent &&consequent,
        ConditionalArgPartOrConsequent &&tail);
    DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ConditionalArg)
 
    Expr<SomeLogical> &condition() { return condition_.value(); }
    const Expr<SomeLogical> &condition() const { return condition_.value(); }
    const Consequent &consequent() const { return consequent_; }
    Consequent &consequent() { return consequent_; }
    ConditionalArgPartOrConsequent &tail() { return tail_; }
    const ConditionalArgPartOrConsequent &tail() const { return tail_; }
 
    // Dispatch on the tail: calls onConditionalArg(const ConditionalArg &)
    // if the tail continues the chain, or onConsequent(const Consequent &)
    // if the tail is the terminal consequent.
    template <typename F, typename G>
    auto VisitTail(F onConditionalArg, G onConsequent) const {
      return common::visit(
          common::visitors{
              [&](const common::CopyableIndirection<ConditionalArg> &inner) {
                return onConditionalArg(inner.value());
              },
              [&](const Consequent &cons) { return onConsequent(cons); },
          },
          tail_);
    }
 
    template <typename F, typename G>
    auto VisitTail(F onConditionalArg, G onConsequent) {
      return common::visit(
          common::visitors{
              [&](common::CopyableIndirection<ConditionalArg> &inner) {
                return onConditionalArg(inner.value());
              },
              [&](Consequent &cons) { return onConsequent(cons); },
          },
          tail_);
    }
 
    // Apply a callback to every Consequent in the chain (including .NIL.
    // entries).  This encapsulates the recurring "process consequent, then
    // VisitTail with recursion" pattern.
    template <typename F> void ForEachConsequent(F f) const {
      f(consequent_);
      VisitTail(
          [&](const ConditionalArg &inner) { inner.ForEachConsequent(f); },
          [&](const Consequent &cons) { f(cons); });
    }
    template <typename F> void ForEachConsequent(F f) {
      f(consequent_);
      VisitTail([&](ConditionalArg &inner) { inner.ForEachConsequent(f); },
          [&](Consequent &cons) { f(cons); });
    }
 
    // Returns the first non-.NIL. consequent expression, or nullptr.
    const Expr<SomeType> *FirstNonNilConsequent() const;
    bool HasNilConsequent() const;
 
    bool operator==(const ConditionalArg &) const;
    llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
  private:
    common::CopyableIndirection<Expr<SomeLogical>> condition_;
    Consequent consequent_;
    ConditionalArgPartOrConsequent tail_;
  };
 
  DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)
  explicit ActualArgument(Expr<SomeType> &&);
  explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
  explicit ActualArgument(AssumedType);
  explicit ActualArgument(common::Label);
  explicit ActualArgument(ConditionalArg &&);
  ~ActualArgument();
  ActualArgument &operator=(Expr<SomeType> &&);
 
  Expr<SomeType> *UnwrapExpr() {
    if (auto *p{
            std::get_if<common::CopyableIndirection<Expr<SomeType>>>(&u_)}) {
      return &p->value();
    } else {
      return nullptr;
    }
  }
  const Expr<SomeType> *UnwrapExpr() const {
    if (const auto *p{
            std::get_if<common::CopyableIndirection<Expr<SomeType>>>(&u_)}) {
      return &p->value();
    } else {
      return nullptr;
    }
  }
 
  const Symbol *GetAssumedTypeDummy() const {
    if (const AssumedType * aType{std::get_if<AssumedType>(&u_)}) {
      return &aType->symbol();
    } else {
      return nullptr;
    }
  }
 
  common::Label GetLabel() const { return std::get<common::Label>(u_); }
 
  std::optional<DynamicType> GetType() const;
  int Rank() const;
  bool operator==(const ActualArgument &) const;
  llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
  std::string AsFortran() const;
 
  std::optional<parser::CharBlock> keyword() const { return keyword_; }
  ActualArgument &set_keyword(parser::CharBlock x) {
    keyword_ = x;
    return *this;
  }
  bool isAlternateReturn() const {
    return std::holds_alternative<common::Label>(u_);
  }
  bool isConditionalArg() const {
    return std::holds_alternative<ConditionalArg>(u_);
  }
  const ConditionalArg *GetConditionalArg() const {
    return std::get_if<ConditionalArg>(&u_);
  }
  ConditionalArg *GetConditionalArg() {
    return std::get_if<ConditionalArg>(&u_);
  }
  const Expr<SomeType> *GetConditionalArgExpr() const {
    const auto *condArg{GetConditionalArg()};
    return condArg ? condArg->FirstNonNilConsequent() : nullptr;
  }
  // Returns the expression from a direct Expr argument or, failing that,
  // the first non-NIL consequent from a ConditionalArg.
  const Expr<SomeType> *GetArgExpr() const {
    if (const auto *expr{UnwrapExpr()}) {
      return expr;
    }
    return GetConditionalArgExpr();
  }
  bool isPassedObject() const { return attrs_.test(Attr::PassedObject); }
  ActualArgument &set_isPassedObject(bool yes = true) {
    if (yes) {
      attrs_ = attrs_ + Attr::PassedObject;
    } else {
      attrs_ = attrs_ - Attr::PassedObject;
    }
    return *this;
  }
 
  bool Matches(const characteristics::DummyArgument &) const;
  common::Intent dummyIntent() const { return dummyIntent_; }
  ActualArgument &set_dummyIntent(common::Intent intent) {
    dummyIntent_ = intent;
    return *this;
  }
  std::optional<parser::CharBlock> sourceLocation() const {
    return sourceLocation_;
  }
  ActualArgument &set_sourceLocation(std::optional<parser::CharBlock> at) {
    sourceLocation_ = at;
    return *this;
  }
 
  // Wrap this argument in parentheses
  void Parenthesize();
 
  // Legacy %VAL.
  bool isPercentVal() const { return attrs_.test(Attr::PercentVal); };
  ActualArgument &set_isPercentVal() {
    attrs_ = attrs_ + Attr::PercentVal;
    return *this;
  }
  // Legacy %REF.
  bool isPercentRef() const { return attrs_.test(Attr::PercentRef); };
  ActualArgument &set_isPercentRef() {
    attrs_ = attrs_ + Attr::PercentRef;
    return *this;
  }
 
private:
  // Subtlety: There is a distinction that must be maintained here between an
  // actual argument expression that is a variable and one that is not,
  // e.g. between X and (X).  The parser attempts to parse each argument
  // first as a variable, then as an expression, and the distinction appears
  // in the parse tree.
  std::variant<common::CopyableIndirection<Expr<SomeType>>, AssumedType,
      common::Label, ConditionalArg>
      u_;
  std::optional<parser::CharBlock> keyword_;
  Attrs attrs_;
  common::Intent dummyIntent_{common::Intent::Default};
  std::optional<parser::CharBlock> sourceLocation_;
};
 
using ActualArguments = std::vector<std::optional<ActualArgument>>;
 
// Intrinsics are identified by their names and the characteristics
// of their arguments, at least for now.
using IntrinsicProcedure = std::string;
 
struct SpecificIntrinsic {
  SpecificIntrinsic(IntrinsicProcedure, characteristics::Procedure &&);
  DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic)
  ~SpecificIntrinsic();
  bool operator==(const SpecificIntrinsic &) const;
  llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
  IntrinsicProcedure name;
  bool isRestrictedSpecific{false}; // if true, can only call it, not pass it
  common::CopyableIndirection<characteristics::Procedure> characteristics;
};
 
struct ProcedureDesignator {
  EVALUATE_UNION_CLASS_BOILERPLATE(ProcedureDesignator)
  explicit ProcedureDesignator(SpecificIntrinsic &&i) : u{std::move(i)} {}
  explicit ProcedureDesignator(const Symbol &n) : u{n} {}
  explicit ProcedureDesignator(Component &&);
 
  // Exactly one of these will return a non-null pointer.
  const SpecificIntrinsic *GetSpecificIntrinsic() const;
  const Symbol *GetSymbol() const; // symbol or component symbol
  const SymbolRef *UnwrapSymbolRef() const; // null if intrinsic or component
 
  // For references to NOPASS components and bindings only.
  // References to PASS components and bindings are represented
  // with the symbol below and the base object DataRef in the
  // passed-object ActualArgument.
  // Always null when the procedure is intrinsic.
  const Component *GetComponent() const;
 
  const Symbol *GetInterfaceSymbol() const;
 
  std::string GetName() const;
  std::optional<DynamicType> GetType() const;
  int Rank() const;
  bool IsElemental() const;
  bool IsPure() const;
  bool IsSimple() const;
  std::optional<Expr<SubscriptInteger>> LEN() const;
  llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
  std::variant<SpecificIntrinsic, SymbolRef,
      common::CopyableIndirection<Component>>
      u;
};
 
using Chevrons = std::vector<Expr<SomeType>>;
 
class ProcedureRef {
public:
  CLASS_BOILERPLATE(ProcedureRef)
  ProcedureRef(ProcedureDesignator &&p, ActualArguments &&a,
      bool hasAlternateReturns = false)
      : proc_{std::move(p)}, arguments_{std::move(a)},
        hasAlternateReturns_{hasAlternateReturns} {}
  ~ProcedureRef();
  static void Deleter(ProcedureRef *);
 
  ProcedureDesignator &proc() { return proc_; }
  const ProcedureDesignator &proc() const { return proc_; }
  ActualArguments &arguments() { return arguments_; }
  const ActualArguments &arguments() const { return arguments_; }
  // CALL subr <<< kernel launch >>> (...); not function
  Chevrons &chevrons() { return chevrons_; }
  const Chevrons &chevrons() const { return chevrons_; }
  void set_chevrons(Chevrons &&chevrons) { chevrons_ = std::move(chevrons); }
 
  std::optional<Expr<SubscriptInteger>> LEN() const;
  int Rank() const;
  static constexpr int Corank() { return 0; } // TODO
  bool IsElemental() const { return proc_.IsElemental(); }
  bool hasAlternateReturns() const { return hasAlternateReturns_; }
 
  bool hasNoInline() const { return noInline_; }
  void setNoInline(bool ni) { noInline_ = ni; }
  bool hasAlwaysInline() const { return alwaysInline_; }
  void setAlwaysInline(bool ai) { alwaysInline_ = ai; }
  bool hasInlineHint() const { return inlineHint_; }
  void setInlineHint(bool ih) { inlineHint_ = ih; }
 
  Expr<SomeType> *UnwrapArgExpr(int n) {
    if (static_cast<std::size_t>(n) < arguments_.size() && arguments_[n]) {
      return arguments_[n]->UnwrapExpr();
    } else {
      return nullptr;
    }
  }
  const Expr<SomeType> *UnwrapArgExpr(int n) const {
    if (static_cast<std::size_t>(n) < arguments_.size() && arguments_[n]) {
      return arguments_[n]->UnwrapExpr();
    } else {
      return nullptr;
    }
  }
 
  bool operator==(const ProcedureRef &) const;
  llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
protected:
  ProcedureDesignator proc_;
  ActualArguments arguments_;
  Chevrons chevrons_;
  bool hasAlternateReturns_;
  bool noInline_{false};
  bool alwaysInline_{false};
  bool inlineHint_{false};
};
 
template <typename A> class FunctionRef : public ProcedureRef {
public:
  using Result = A;
  CLASS_BOILERPLATE(FunctionRef)
  explicit FunctionRef(ProcedureRef &&pr) : ProcedureRef{std::move(pr)} {}
  FunctionRef(ProcedureDesignator &&p, ActualArguments &&a)
      : ProcedureRef{std::move(p), std::move(a)} {}
 
  std::optional<DynamicType> GetType() const {
    if constexpr (IsLengthlessIntrinsicType<A>) {
      return A::GetType();
    } else if (auto type{proc_.GetType()}) {
      // TODO: Non constant explicit length parameters of PDTs result should
      // likely be dropped too. This is not as easy as for characters since some
      // long lived DerivedTypeSpec pointer would need to be created here. It is
      // not clear if this is causing any issue so far since the storage size of
      // PDTs is independent of length parameters.
      return type->DropNonConstantCharacterLength();
    } else {
      return std::nullopt;
    }
  }
};
} // namespace Fortran::evaluate
#endif // FORTRAN_EVALUATE_CALL_H_