// SearchTypes will traverse the element types in the tuple in order
// and invoke VISITOR::Test<T>() on each until it returns a value that
// casts to true. If no invocation of Test succeeds, SearchTypes will
-// return a default-constructed value VISITOR::Result{}.
+// return a default value.
template<std::size_t J, typename VISITOR>
common::IfNoLvalue<typename VISITOR::Result, VISITOR> SearchTypesHelper(
- VISITOR &&visitor) {
+ VISITOR &&visitor, typename VISITOR::Result &&defaultResult) {
using Tuple = typename VISITOR::Types;
if constexpr (J < std::tuple_size_v<Tuple>) {
if (auto result{visitor.template Test<std::tuple_element_t<J, Tuple>>()}) {
return result;
}
- return SearchTypesHelper<J + 1, VISITOR>(std::move(visitor));
+ return SearchTypesHelper<J + 1, VISITOR>(std::move(visitor),
+ std::move(defaultResult));
} else {
- return typename VISITOR::Result{};
+ return std::move(defaultResult);
}
}
template<typename VISITOR>
common::IfNoLvalue<typename VISITOR::Result, VISITOR> SearchTypes(
- VISITOR &&visitor) {
- return SearchTypesHelper<0, VISITOR>(std::move(visitor));
+ VISITOR &&visitor,
+ typename VISITOR::Result defaultResult = typename VISITOR::Result{}) {
+ return SearchTypesHelper<0, VISITOR>(
+ std::move(visitor), std::move(defaultResult));
}
}
#endif // FORTRAN_COMMON_TEMPLATE_H_
}
std::optional<DynamicType> ActualArgument::GetType() const {
- if (const auto *expr{GetExpr()}) {
+ if (const auto *expr{UnwrapExpr()}) {
return expr->GetType();
} else {
return std::nullopt;
}
int ActualArgument::Rank() const {
- if (const auto *expr{GetExpr()}) {
+ if (const auto *expr{UnwrapExpr()}) {
return expr->Rank();
} else {
return std::get<AssumedType>(u_).Rank();
~ActualArgument();
ActualArgument &operator=(Expr<SomeType> &&);
- Expr<SomeType> *GetExpr() {
+ Expr<SomeType> *UnwrapExpr() {
if (auto *p{
std::get_if<common::CopyableIndirection<Expr<SomeType>>>(&u_)}) {
return &p->value();
return nullptr;
}
}
- const Expr<SomeType> *GetExpr() const {
+ const Expr<SomeType> *UnwrapExpr() const {
if (const auto *p{
std::get_if<common::CopyableIndirection<Expr<SomeType>>>(&u_)}) {
return &p->value();
bool operator==(const TypeAndShape &) const;
bool IsAssumedRank() const { return isAssumedRank_; }
- int Rank() const { return static_cast<int>(shape().size()); }
+ int Rank() const { return GetRank(shape_); }
bool IsCompatibleWith(
parser::ContextualMessages &, const TypeAndShape &) const;
#include "constant.h"
#include "expression.h"
+#include "shape.h"
#include "type.h"
#include <string>
bool IncrementSubscripts(
ConstantSubscripts &indices, const ConstantSubscripts &shape) {
- auto rank{shape.size()};
- CHECK(indices.size() == rank);
- for (std::size_t j{0}; j < rank; ++j) {
+ int rank{GetRank(shape)};
+ CHECK(GetRank(indices) == rank);
+ for (int j{0}; j < rank; ++j) {
CHECK(indices[j] >= 1);
if (++indices[j] <= shape[j]) {
return true;
}
template<typename RESULT, typename ELEMENT>
+ConstantBase<RESULT, ELEMENT>::ConstantBase(
+ std::vector<Element> &&x, ConstantSubscripts &&dims, Result res)
+ : result_{res}, values_(std::move(x)), shape_(std::move(dims)) {
+ CHECK(size() == TotalElementCount(shape_));
+}
+
+template<typename RESULT, typename ELEMENT>
ConstantBase<RESULT, ELEMENT>::~ConstantBase() {}
template<typename RESULT, typename ELEMENT>
static ConstantSubscript SubscriptsToOffset(
const ConstantSubscripts &index, const ConstantSubscripts &shape) {
- CHECK(index.size() == shape.size());
+ CHECK(GetRank(index) == GetRank(shape));
ConstantSubscript stride{1}, offset{0};
int dim{0};
for (auto j : index) {
return offset;
}
-static Constant<SubscriptInteger> ShapeAsConstant(
- const ConstantSubscripts &shape) {
- using IntType = Scalar<SubscriptInteger>;
- std::vector<IntType> result;
- for (auto dim : shape) {
- result.emplace_back(dim);
- }
- return {std::move(result),
- ConstantSubscripts{static_cast<std::int64_t>(shape.size())}};
+template<typename RESULT, typename ELEMENT>
+Constant<SubscriptInteger> ConstantBase<RESULT, ELEMENT>::SHAPE() const {
+ return AsConstantShape(shape_);
}
template<typename RESULT, typename ELEMENT>
-Constant<SubscriptInteger> ConstantBase<RESULT, ELEMENT>::SHAPE() const {
- return ShapeAsConstant(shape_);
+auto ConstantBase<RESULT, ELEMENT>::Reshape(
+ const ConstantSubscripts &dims) const -> std::vector<Element> {
+ std::size_t n{TotalElementCount(dims)};
+ CHECK(!empty() || n == 0);
+ std::vector<Element> elements;
+ auto iter{values().cbegin()};
+ while (n-- > 0) {
+ elements.push_back(*iter);
+ if (++iter == values().cend()) {
+ iter = values().cbegin();
+ }
+ }
+ return elements;
}
template<typename T>
return Base::values_.at(SubscriptsToOffset(index, Base::shape_));
}
+template<typename T>
+auto Constant<T>::Reshape(ConstantSubscripts &&dims) const -> Constant {
+ return {Base::Reshape(dims), std::move(dims)};
+}
+
// Constant<Type<TypeCategory::Character, KIND> specializations
template<int KIND>
Constant<Type<TypeCategory::Character, KIND>>::Constant(
Constant<Type<TypeCategory::Character, KIND>>::Constant(std::int64_t len,
std::vector<Scalar<Result>> &&strings, ConstantSubscripts &&dims)
: length_{len}, shape_{std::move(dims)} {
+ CHECK(strings.size() == TotalElementCount(shape_));
values_.assign(strings.size() * length_,
static_cast<typename Scalar<Result>::value_type>(' '));
std::int64_t at{0};
template<int KIND> Constant<Type<TypeCategory::Character, KIND>>::~Constant() {}
-static ConstantSubscript ShapeElements(const ConstantSubscripts &shape) {
- ConstantSubscript elements{1};
- for (auto dim : shape) {
- elements *= dim;
- }
- return elements;
-}
-
template<int KIND>
bool Constant<Type<TypeCategory::Character, KIND>>::empty() const {
return size() == 0;
template<int KIND>
std::size_t Constant<Type<TypeCategory::Character, KIND>>::size() const {
if (length_ == 0) {
- return ShapeElements(shape_);
+ return TotalElementCount(shape_);
} else {
return static_cast<std::int64_t>(values_.size()) / length_;
}
}
template<int KIND>
+auto Constant<Type<TypeCategory::Character, KIND>>::Reshape(
+ ConstantSubscripts &&dims) const -> Constant<Result> {
+ std::size_t n{TotalElementCount(dims)};
+ CHECK(!empty() || n == 0);
+ std::vector<Element> elements;
+ std::int64_t at{0}, limit{static_cast<std::int64_t>(values_.size())};
+ while (n-- > 0) {
+ elements.push_back(values_.substr(at, length_));
+ at += length_;
+ if (at == limit) { // subtle: at > limit somehow? substr() will catch it
+ at = 0;
+ }
+ }
+ return {length_, std::move(elements), std::move(dims)};
+}
+
+template<int KIND>
Constant<SubscriptInteger>
Constant<Type<TypeCategory::Character, KIND>>::SHAPE() const {
- return ShapeAsConstant(shape_);
+ return AsConstantShape(shape_);
}
// Constant<SomeDerived> specialization
values_.at(SubscriptsToOffset(index, shape_))};
}
+auto Constant<SomeDerived>::Reshape(ConstantSubscripts &&dims) const
+ -> Constant {
+ return {result().derivedTypeSpec(), Base::Reshape(dims), std::move(dims)};
+}
+
INSTANTIATE_CONSTANT_TEMPLATES
}
#include "type.h"
#include <map>
#include <ostream>
+#include <vector>
namespace Fortran::evaluate {
// values as indices into constants, use a vector of integers.
using ConstantSubscript = std::int64_t;
using ConstantSubscripts = std::vector<ConstantSubscript>;
+inline int GetRank(const ConstantSubscripts &s) {
+ return static_cast<int>(s.size());
+}
std::size_t TotalElementCount(const ConstantSubscripts &);
return ConstantSubscripts(rank, 1); // parens, not braces: "rank" copies of 1
}
inline ConstantSubscripts InitialSubscripts(const ConstantSubscripts &shape) {
- return InitialSubscripts(static_cast<int>(shape.size()));
+ return InitialSubscripts(GetRank(shape));
}
// Increments a vector of subscripts in Fortran array order (first dimension
template<typename A, typename = common::NoLvalue<A>>
ConstantBase(A &&x, Result res = Result{})
: result_{res}, values_{std::move(x)} {}
- ConstantBase(std::vector<Element> &&x, ConstantSubscripts &&dims,
- Result res = Result{})
- : result_{res}, values_(std::move(x)), shape_(std::move(dims)) {}
+ ConstantBase(
+ std::vector<Element> &&, ConstantSubscripts &&, Result = Result{});
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ConstantBase)
~ConstantBase();
- int Rank() const { return static_cast<int>(shape_.size()); }
+ int Rank() const { return GetRank(shape_); }
bool operator==(const ConstantBase &) const;
bool empty() const { return values_.empty(); }
std::size_t size() const { return values_.size(); }
const std::vector<Element> &values() const { return values_; }
const ConstantSubscripts &shape() const { return shape_; }
- ConstantSubscripts &shape() { return shape_; }
constexpr Result result() const { return result_; }
constexpr DynamicType GetType() const { return result_.GetType(); }
std::ostream &AsFortran(std::ostream &) const;
protected:
+ std::vector<Element> Reshape(const ConstantSubscripts &) const;
+
Result result_;
std::vector<Element> values_;
ConstantSubscripts shape_;
// Apply 1-based subscripts
Element At(const ConstantSubscripts &) const;
+ Constant Reshape(ConstantSubscripts &&) const;
};
template<int KIND> class Constant<Type<TypeCategory::Character, KIND>> {
Constant(std::int64_t, std::vector<Element> &&, ConstantSubscripts &&);
~Constant();
- int Rank() const { return static_cast<int>(shape_.size()); }
+ int Rank() const { return GetRank(shape_); }
bool operator==(const Constant &that) const {
return shape_ == that.shape_ && values_ == that.values_;
}
bool empty() const;
std::size_t size() const;
const ConstantSubscripts &shape() const { return shape_; }
- ConstantSubscripts &shape() { return shape_; }
std::int64_t LEN() const { return length_; }
// Apply 1-based subscripts
Scalar<Result> At(const ConstantSubscripts &) const;
+ Constant Reshape(ConstantSubscripts &&) const;
Constant<SubscriptInteger> SHAPE() const;
std::ostream &AsFortran(std::ostream &) const;
std::optional<StructureConstructor> GetScalarValue() const;
StructureConstructor At(const ConstantSubscripts &) const;
+ Constant Reshape(ConstantSubscripts &&) const;
};
FOR_EACH_LENGTHLESS_INTRINSIC_KIND(extern template class ConstantBase, )
template<typename T> void Descend(Variable<T> &var) { Visit(var.u); }
void Descend(const ActualArgument &arg) {
- if (const auto *expr{arg.GetExpr()}) {
+ if (const auto *expr{arg.UnwrapExpr()}) {
Visit(*expr);
} else {
const semantics::Symbol *aType{arg.GetAssumedTypeDummy()};
}
}
void Descend(ActualArgument &arg) {
- if (auto *expr{arg.GetExpr()}) {
+ if (auto *expr{arg.UnwrapExpr()}) {
Visit(*expr);
} else {
const semantics::Symbol *aType{arg.GetAssumedTypeDummy()};
DynamicType StructureConstructor::GetType() const { return result_.GetType(); }
+const Expr<SomeType> *StructureConstructor::Find(
+ const Symbol *component) const {
+ if (auto iter{values_.find(component)}; iter != values_.end()) {
+ return &iter->second.value();
+ } else {
+ return nullptr;
+ }
+}
+
StructureConstructor &StructureConstructor::Add(
const Symbol &symbol, Expr<SomeType> &&expr) {
values_.emplace(&symbol, std::move(expr));
return values_.end();
}
+ const Expr<SomeType> *Find(const Symbol *) const; // can return null
+
StructureConstructor &Add(const semantics::Symbol &, Expr<SomeType> &&);
int Rank() const { return 0; }
DynamicType GetType() const;
namespace Fortran::evaluate {
+// FoldOperation() rewrites expression tree nodes.
+// If there is any possibility that the rewritten node will
+// not have the same representation type, the result of
+// FoldOperation() will be packaged in an Expr<> of the same
+// specific type.
+
// no-op base case
template<typename A>
common::IfNoLvalue<Expr<ResultType<A>>, A> FoldOperation(
FoldingContext &, A &&x) {
+ static_assert(!std::is_same_v<A, Expr<ResultType<A>>> &&
+ "call Fold() instead for Expr<>");
return Expr<ResultType<A>>{std::move(x)};
}
// Forward declarations of overloads, template instantiations, and template
// specializations of FoldOperation() to enable mutual recursion between them.
-BaseObject FoldOperation(FoldingContext &, BaseObject &&);
-Component FoldOperation(FoldingContext &, Component &&);
-Triplet FoldOperation(FoldingContext &, Triplet &&);
-Subscript FoldOperation(FoldingContext &, Subscript &&);
-ArrayRef FoldOperation(FoldingContext &, ArrayRef &&);
-CoarrayRef FoldOperation(FoldingContext &, CoarrayRef &&);
-DataRef FoldOperation(FoldingContext &, DataRef &&);
-Substring FoldOperation(FoldingContext &, Substring &&);
-ComplexPart FoldOperation(FoldingContext &, ComplexPart &&);
+static Component FoldOperation(FoldingContext &, Component &&);
+static Triplet FoldOperation(
+ FoldingContext &, Triplet &&, const Symbol &, int dim);
+static Subscript FoldOperation(
+ FoldingContext &, Subscript &&, const Symbol &, int dim);
+static ArrayRef FoldOperation(FoldingContext &, ArrayRef &&);
+static CoarrayRef FoldOperation(FoldingContext &, CoarrayRef &&);
+static DataRef FoldOperation(FoldingContext &, DataRef &&);
+static Substring FoldOperation(FoldingContext &, Substring &&);
+static ComplexPart FoldOperation(FoldingContext &, ComplexPart &&);
template<int KIND>
Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(
FoldingContext &context, FunctionRef<Type<TypeCategory::Integer, KIND>> &&);
template<int KIND>
Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(
FoldingContext &, TypeParamInquiry<KIND> &&);
+static Expr<ImpliedDoIndex::Result> FoldOperation(
+ FoldingContext &context, ImpliedDoIndex &&);
template<typename T>
Expr<T> FoldOperation(FoldingContext &, ArrayConstructor<T> &&);
-Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
+static Expr<SomeDerived> FoldOperation(
+ FoldingContext &, StructureConstructor &&);
// Overloads, instantiations, and specializations of FoldOperation().
-BaseObject FoldOperation(FoldingContext &, BaseObject &&object) {
- return std::move(object);
-}
-
Component FoldOperation(FoldingContext &context, Component &&component) {
return {FoldOperation(context, std::move(component.base())),
component.GetLastSymbol()};
}
-Triplet FoldOperation(FoldingContext &context, Triplet &&triplet) {
- return {Fold(context, triplet.lower()), Fold(context, triplet.upper()),
- Fold(context, common::Clone(triplet.stride()))};
+Triplet FoldOperation(
+ FoldingContext &context, Triplet &&triplet, const Symbol &symbol, int dim) {
+ MaybeExtentExpr lower{triplet.lower()};
+ if (!lower.has_value()) {
+ lower = GetLowerBound(context, symbol, dim);
+ }
+ MaybeExtentExpr upper{triplet.upper()};
+ if (!upper.has_value()) {
+ upper = GetUpperBound(
+ context, common::Clone(lower), GetExtent(context, symbol, dim));
+ }
+ return {Fold(context, std::move(lower)), Fold(context, std::move(upper)),
+ Fold(context, triplet.stride())};
}
-Subscript FoldOperation(FoldingContext &context, Subscript &&subscript) {
+Subscript FoldOperation(FoldingContext &context, Subscript &&subscript,
+ const Symbol &symbol, int dim) {
return std::visit(
common::visitors{
[&](IndirectSubscriptIntegerExpr &&expr) {
return Subscript(std::move(expr));
},
[&](Triplet &&triplet) {
- return Subscript(FoldOperation(context, std::move(triplet)));
+ return Subscript(
+ FoldOperation(context, std::move(triplet), symbol, dim));
},
},
std::move(subscript.u));
}
ArrayRef FoldOperation(FoldingContext &context, ArrayRef &&arrayRef) {
+ const Symbol &symbol{arrayRef.GetLastSymbol()};
+ int dim{0};
for (Subscript &subscript : arrayRef.subscript()) {
- subscript = FoldOperation(context, std::move(subscript));
+ subscript = FoldOperation(context, std::move(subscript), symbol, dim++);
}
return std::visit(
common::visitors{
}
CoarrayRef FoldOperation(FoldingContext &context, CoarrayRef &&coarrayRef) {
+ const Symbol &symbol{coarrayRef.GetLastSymbol()};
std::vector<Subscript> subscript;
+ int dim{0};
for (Subscript x : coarrayRef.subscript()) {
- subscript.emplace_back(FoldOperation(context, std::move(x)));
+ subscript.emplace_back(FoldOperation(context, std::move(x), symbol, dim++));
}
std::vector<Expr<SubscriptInteger>> cosubscript;
for (Expr<SubscriptInteger> x : coarrayRef.cosubscript()) {
static_assert(
(... && IsSpecificIntrinsicType<TA>)); // TODO derived types for MERGE?
static_assert(sizeof...(TA) > 0);
- std::tuple<const Constant<TA> *...> args{
- GetConstantValue<TA>(*funcRef.arguments()[I].value().GetExpr())...};
+ std::tuple<const Constant<TA> *...> args{UnwrapExpr<Constant<TA>>(
+ *funcRef.arguments()[I].value().UnwrapExpr())...};
if ((... && (std::get<I>(args) != nullptr))) {
// Compute the shape of the result based on shapes of arguments
ConstantSubscripts shape;
// same. Shouldn't this be checked elsewhere so that this is also
// checked for non constexpr call to elemental intrinsics function?
context.messages().Say(
- "arguments in elemental intrinsic function are not conformable"_err_en_US);
+ "Arguments in elemental intrinsic function are not conformable"_err_en_US);
return Expr<TR>{std::move(funcRef)};
}
}
}
}
- CHECK(rank == static_cast<int>(shape.size()));
+ CHECK(rank == GetRank(shape));
// Compute all the scalar values of the results
std::vector<Scalar<TR>> results;
}
template<typename TR, typename... TA>
-static Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
+Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
FunctionRef<TR> &&funcRef, ScalarFunc<TR, TA...> func) {
return FoldElementalIntrinsicHelper<ScalarFunc, TR, TA...>(
context, std::move(funcRef), func, std::index_sequence_for<TA...>{});
}
template<typename TR, typename... TA>
-static Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
+Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
FunctionRef<TR> &&funcRef, ScalarFuncWithContext<TR, TA...> func) {
return FoldElementalIntrinsicHelper<ScalarFuncWithContext, TR, TA...>(
context, std::move(funcRef), func, std::index_sequence_for<TA...>{});
}
-template<typename T>
-
static Expr<T> *UnwrapArgument(std::optional<ActualArgument> &arg) {
- if (arg.has_value()) {
- if (Expr<SomeType> * expr{arg->GetExpr()}) {
- return UnwrapExpr<Expr<T>>(*expr);
- }
+static std::optional<std::int64_t> GetInt64Arg(
+
const std::optional<ActualArgument> &arg) {
+ if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(arg)}) {
+ return ToInt64(*intExpr);
+ } else {
+ return std::nullopt;
}
- return nullptr;
}
-static BOZLiteralConstant *UnwrapBozArgument(
- std::optional<ActualArgument> &arg) {
- if (auto *expr{UnwrapArgument<SomeType>(arg)}) {
- return std::get_if<BOZLiteralConstant>(&expr->u);
+static std::optional<std::int64_t> GetInt64ArgOr(
+ const std::optional<ActualArgument> &arg, std::int64_t defaultValue) {
+ if (!arg.has_value()) {
+ return defaultValue;
+ } else if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(arg)}) {
+ return ToInt64(*intExpr);
} else {
- return nullptr;
+ return std::nullopt;
}
}
using T = Type<TypeCategory::Integer, KIND>;
ActualArguments &args{funcRef.arguments()};
for (std::optional<ActualArgument> &arg : args) {
- if (auto *expr{UnwrapArgument<SomeType>(arg)}) {
- *expr = FoldOperation(context, std::move(*expr));
+ if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
+ *expr = Fold(context, std::move(*expr));
}
}
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
} else if (name == "dshiftl" || name == "dshiftr") {
// convert boz
for (int i{0}; i <= 1; ++i) {
- if (auto *x{UnwrapBozArgument(args[i])}) {
+ if (auto *x{UnwrapExpr<BOZLiteralConstant>(args[i])}) {
*args[i] =
AsGenericExpr(Fold(context, ConvertToType<T>(std::move(*x))));
}
// Third argument can be of any kind. However, it must be smaller or equal
// than BIT_SIZE. It can be converted to Int4 to simplify.
using Int4 = Type<TypeCategory::Integer, 4>;
- if (auto *n{UnwrapArgument<SomeInteger>(args[2])}) {
+ if (auto *n{UnwrapExpr<Expr<SomeInteger>>(args[2])}) {
*args[2] =
AsGenericExpr(Fold(context, ConvertToType<Int4>(std::move(*n))));
}
fptr, i, j, static_cast<int>(shift.ToInt64()));
}));
} else if (name == "exponent") {
- if (auto *sx{UnwrapArgument<SomeReal>(args[0])}) {
+ if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
return std::visit(
[&funcRef, &context](const auto &x) -> Expr<T> {
using TR = typename std::decay_t<decltype(x)>::Result;
} else if (name == "iand" || name == "ior" || name == "ieor") {
// convert boz
for (int i{0}; i <= 1; ++i) {
- if (auto *x{UnwrapBozArgument(args[i])}) {
+ if (auto *x{UnwrapExpr<BOZLiteralConstant>(args[i])}) {
*args[i] =
AsGenericExpr(Fold(context, ConvertToType<T>(std::move(*x))));
}
// Second argument can be of any kind. However, it must be smaller or
// equal than BIT_SIZE. It can be converted to Int4 to simplify.
using Int4 = Type<TypeCategory::Integer, 4>;
- if (auto *n{UnwrapArgument<SomeInteger>(args[1])}) {
+ if (auto *n{UnwrapExpr<Expr<SomeInteger>>(args[1])}) {
*args[1] =
AsGenericExpr(Fold(context, ConvertToType<Int4>(std::move(*n))));
}
return std::invoke(fptr, i, static_cast<int>(pos.ToInt64()));
}));
} else if (name == "int") {
- if (auto *expr{args[0].value().GetExpr()}) {
+ if (auto *expr{args[0].value().UnwrapExpr()}) {
return std::visit(
[&](auto &&x) -> Expr<T> {
using From = std::decay_t<decltype(x)>;
}
} else if (name == "leadz" || name == "trailz" || name == "poppar" ||
name == "popcnt") {
- if (auto *sn{UnwrapArgument<SomeInteger>(args[0])}) {
+ if (auto *sn{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
return std::visit(
[&funcRef, &context, &name](const auto &n) -> Expr<T> {
using TI = typename std::decay_t<decltype(n)>::Result;
common::die("leadz argument must be integer");
}
} else if (name == "len") {
- if (auto *charExpr{UnwrapArgument<SomeCharacter>(args[0])}) {
+ if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
return std::visit(
[&](auto &kx) { return Fold(context, ConvertToType<T>(kx.LEN())); },
charExpr->u);
// Argument can be of any kind but value has to be smaller than bit_size.
// It can be safely converted to Int4 to simplify.
using Int4 = Type<TypeCategory::Integer, 4>;
- if (auto *n{UnwrapArgument<SomeInteger>(args[0])}) {
+ if (auto *n{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
*args[0] =
AsGenericExpr(Fold(context, ConvertToType<Int4>(std::move(*n))));
}
} else if (name == "merge_bits") {
// convert boz
for (int i{0}; i <= 2; ++i) {
- if (auto *x{UnwrapBozArgument(args[i])}) {
+ if (auto *x{UnwrapExpr<BOZLiteralConstant>(args[i])}) {
*args[i] =
AsGenericExpr(Fold(context, ConvertToType<T>(std::move(*x))));
}
} else if (name == "rank") {
// TODO assumed-rank dummy argument
return Expr<T>{args[0].value().Rank()};
+ } else if (name == "selected_int_kind") {
+ if (auto p{GetInt64Arg(args[0])}) {
+ return Expr<T>{SelectedIntKind(*p)};
+ }
+ } else if (name == "selected_real_kind") {
+ if (auto p{GetInt64ArgOr(args[0], 0)}) {
+ if (auto r{GetInt64ArgOr(args[1], 0)}) {
+ if (auto radix{GetInt64ArgOr(args[2], 2)}) {
+ return Expr<T>{SelectedRealKind(*p, *r, *radix)};
+ }
+ }
+ }
} else if (name == "shape") {
if (auto shape{GetShape(context, args[0].value())}) {
if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
} else if (name == "size") {
if (auto shape{GetShape(context, args[0].value())}) {
if (auto &dimArg{args[1]}) { // DIM= is present, get one extent
- if (auto *expr{dimArg->GetExpr()}) {
- if (auto dim{ToInt64(*expr)}) {
- std::int64_t rank = shape->size();
- if (*dim >= 1 && *dim <= rank) {
- if (auto &extent{shape->at(*dim - 1)}) {
- return Fold(context, ConvertToType<T>(std::move(*extent)));
- }
- } else {
- context.messages().Say(
- "size(array,dim=%jd) dimension is out of range for rank-%d array"_en_US,
- static_cast<std::intmax_t>(*dim), static_cast<int>(rank));
+ if (auto dim{GetInt64Arg(args[1])}) {
+ int rank = GetRank(*shape);
+ if (*dim >= 1 && *dim <= rank) {
+ if (auto &extent{shape->at(*dim - 1)}) {
+ return Fold(context, ConvertToType<T>(std::move(*extent)));
}
+ } else {
+ context.messages().Say(
+ "size(array,dim=%jd) dimension is out of range for rank-%d array"_en_US,
+ static_cast<std::intmax_t>(*dim), static_cast<int>(rank));
}
}
} else if (auto extents{
// findloc, floor, iachar, iall, iany, iparity, ibits, ichar, image_status,
// index, ishftc, lbound, len_trim, matmul, max, maxloc, maxval, merge, min,
// minloc, minval, mod, modulo, nint, not, pack, product, reduce, reshape,
- // scan, selected_char_kind, selected_int_kind, selected_real_kind,
+ // scan, selected_char_kind,
// sign, spread, sum, transfer, transpose, ubound, unpack, verify
}
return Expr<T>{std::move(funcRef)};
ActualArguments &args{funcRef.arguments()};
for (std::optional<ActualArgument> &arg : args) {
if (arg.has_value()) {
- if (auto *expr{arg->GetExpr()}) {
- *expr = FoldOperation(context, std::move(*expr));
+ if (auto *expr{arg->UnwrapExpr()}) {
+ *expr = Fold(context, std::move(*expr));
}
}
}
if (args.size() == 2) { // elemental
// runtime functions use int arg
using Int4 = Type<TypeCategory::Integer, 4>;
- if (auto *n{UnwrapArgument<SomeInteger>(args[0])}) {
+ if (auto *n{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
*args[0] =
AsGenericExpr(Fold(context, ConvertToType<Int4>(std::move(*n))));
}
}
} else if (name == "abs") {
// Argument can be complex or real
- if (auto *x{UnwrapArgument<SomeReal>(args[0])}) {
+ if (auto *x{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
return FoldElementalIntrinsic<T, T>(
context, std::move(funcRef), &Scalar<T>::ABS);
- } else if (auto *z{UnwrapArgument<SomeComplex>(args[0])}) {
+ } else if (auto *z{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
if (auto callable{
context.hostIntrinsicsLibrary()
.GetHostProcedureWrapper<Scalar, T, ComplexT>("abs")}) {
context, std::move(funcRef), &Scalar<ComplexT>::AIMAG);
} else if (name == "aint") {
// Convert argument to the requested kind before calling aint
- if (auto *x{UnwrapArgument<SomeReal>(args[0])}) {
+ if (auto *x{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
*args[0] =
AsGenericExpr(Fold(context, ConvertToType<T>(std::move(*x))));
}
return y.value;
}));
} else if (name == "dprod") {
- if (auto *x{UnwrapArgument<SomeReal>(args[0])}) {
- if (auto *y{UnwrapArgument<SomeReal>(args[1])}) {
+ if (auto *x{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
+ if (auto *y{UnwrapExpr<Expr<SomeReal>>(args[1])}) {
return Fold(context,
Expr<T>{Multiply<T>{ConvertToType<T>(std::move(*x)),
ConvertToType<T>(std::move(*y))}});
} else if (name == "epsilon") {
return Expr<T>{Constant<T>{Scalar<T>::EPSILON()}};
} else if (name == "real") {
- if (auto *expr{args[0].value().GetExpr()}) {
+ if (auto *expr{args[0].value().UnwrapExpr()}) {
return ToReal<KIND>(context, std::move(*expr));
}
}
ActualArguments &args{funcRef.arguments()};
for (std::optional<ActualArgument> &arg : args) {
if (arg.has_value()) {
- if (auto *expr{arg->GetExpr()}) {
- *expr = FoldOperation(context, std::move(*expr));
+ if (auto *expr{arg->UnwrapExpr()}) {
+ *expr = Fold(context, std::move(*expr));
}
}
}
context, std::move(funcRef), &Scalar<T>::CONJG);
} else if (name == "cmplx") {
if (args.size() == 2) {
- if (auto *x{UnwrapArgument<SomeComplex>(args[0])}) {
+ if (auto *x{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
return Fold(context, ConvertToType<T>(std::move(*x)));
} else {
common::die("x must be complex in cmplx(x[, kind])");
} else {
CHECK(args.size() == 3);
using Part = typename T::Part;
- Expr<SomeType> re{std::move(*args[0].value().GetExpr())};
+ Expr<SomeType> re{std::move(*args[0].value().UnwrapExpr())};
Expr<SomeType> im{args[1].has_value()
- ? std::move(*args[1].value().GetExpr())
+ ? std::move(*args[1].value().UnwrapExpr())
: AsGenericExpr(Constant<Part>{Scalar<Part>{}})};
return Fold(context,
Expr<T>{
ActualArguments &args{funcRef.arguments()};
for (std::optional<ActualArgument> &arg : args) {
if (arg.has_value()) {
- if (auto *expr{arg->GetExpr()}) {
- *expr = FoldOperation(context, std::move(*expr));
+ if (auto *expr{arg->UnwrapExpr()}) {
+ *expr = Fold(context, std::move(*expr));
}
}
}
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
std::string name{intrinsic->name};
- if (name == "bge" || name == "bgt" || name == "ble" || name == "blt") {
+ if (name == "all") {
+ if (!args[1].has_value()) { // TODO: ALL(x,DIM=d)
+ if (const auto *constant{UnwrapConstantValue<T>(args[0])}) {
+ bool result{true};
+ for (const auto &element : constant->values()) {
+ if (!element.IsTrue()) {
+ result = false;
+ break;
+ }
+ }
+ return Expr<T>{result};
+ }
+ }
+ } else if (name == "any") {
+ if (!args[1].has_value()) { // TODO: ANY(x,DIM=d)
+ if (const auto *constant{UnwrapConstantValue<T>(args[0])}) {
+ bool result{false};
+ for (const auto &element : constant->values()) {
+ if (element.IsTrue()) {
+ result = true;
+ break;
+ }
+ }
+ return Expr<T>{result};
+ }
+ }
+ } else if (name == "bge" || name == "bgt" || name == "ble" ||
+ name == "blt") {
using LargestInt = Type<TypeCategory::Integer, 16>;
static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>);
// Arguments do not have to be of the same integer type. Convert all
// arguments to the biggest integer type before comparing them to
// simplify.
for (int i{0}; i <= 1; ++i) {
- if (auto *x{UnwrapArgument<SomeInteger>(args[i])}) {
+ if (auto *x{UnwrapExpr<Expr<SomeInteger>>(args[i])}) {
*args[i] = AsGenericExpr(
Fold(context, ConvertToType<LargestInt>(std::move(*x))));
- } else if (auto *x{UnwrapBozArgument(args[i])}) {
+ } else if (auto *x{UnwrapExpr<BOZLiteralConstant>(args[i])}) {
*args[i] = AsGenericExpr(Constant<LargestInt>{std::move(*x)});
}
}
return Scalar<T>{std::invoke(fptr, i, j)};
}));
}
- // TODO: all, any, btest, cshift, dot_product, eoshift, is_iostat_end,
+ // TODO: btest, cshift, dot_product, eoshift, is_iostat_end,
// is_iostat_eor, lge, lgt, lle, llt, logical, matmul, merge, out_of_range,
// pack, parity, reduce, reshape, spread, transfer, transpose, unpack
}
// Get the value of a PARAMETER
template<typename T>
-static std::optional<Expr<T>> GetParameterValue(
+std::optional<Expr<T>> GetParameterValue(
FoldingContext &context, const Symbol *symbol) {
CHECK(symbol != nullptr);
if (symbol->attrs().test(semantics::Attr::PARAMETER)) {
if (const auto *object{
symbol->detailsIf<semantics::ObjectEntityDetails>()}) {
+ if (object->initWasValidated()) {
+ const auto *constant{UnwrapConstantValue<T>(object->init())};
+ CHECK(constant != nullptr);
+ return Expr<T>{*constant};
+ }
if (const auto &init{object->init()}) {
- if (const auto *constant{UnwrapExpr<Constant<T>>(*init)}) {
- return Expr<T>{*constant};
- }
if (auto dyType{DynamicType::From(*symbol)}) {
- auto converted{ConvertToType(*dyType, common::Clone(*init))};
semantics::ObjectEntityDetails *mutableObject{
const_cast<semantics::ObjectEntityDetails *>(object)};
+ auto converted{
+ ConvertToType(*dyType, std::move(mutableObject->init().value()))};
// Reset expression now to prevent infinite loops if the init
// expression depends on symbol itself.
mutableObject->set_init(std::nullopt);
*converted = Fold(context, std::move(*converted));
auto *unwrapped{UnwrapExpr<Expr<T>>(*converted)};
CHECK(unwrapped != nullptr);
- if (auto constant{GetScalarConstantValue<T>(*unwrapped)}) {
+ if (auto *constant{UnwrapConstantValue<T>(*unwrapped)}) {
+ if (constant->Rank() == 0 && symbol->Rank() > 0) {
+ // scalar expansion
+ if (auto symShape{GetShape(context, *symbol)}) {
+ if (auto extents{AsConstantExtents(*symShape)}) {
+ *constant = constant->Reshape(std::move(*extents));
+ CHECK(constant->Rank() == symbol->Rank());
+ }
+ }
+ }
mutableObject->set_init(AsGenericExpr(Expr<T>{*constant}));
- return std::move(*unwrapped);
+ if (auto constShape{GetShape(context, *constant)}) {
+ if (auto symShape{GetShape(context, *symbol)}) {
+ if (CheckConformance(context.messages(), *constShape,
+ *symShape, "initialization expression",
+ "PARAMETER")) {
+ mutableObject->set_initWasValidated();
+ return std::move(*unwrapped);
+ }
+ } else {
+ context.messages().Say(symbol->name(),
+ "Could not determine the shape of the PARAMETER"_err_en_US);
+ }
+ } else {
+ context.messages().Say(symbol->name(),
+ "Could not determine the shape of the initialization expression"_err_en_US);
+ }
+ mutableObject->set_init(std::nullopt);
} else {
std::stringstream ss;
unwrapped->AsFortran(ss);
// Apply subscripts to a constant array
-std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
- FoldingContext &context, Subscript &ss) {
- ss = FoldOperation(context, std::move(ss));
+static std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
+ FoldingContext &context, Subscript &ss, const Symbol &symbol, int dim) {
+ ss = FoldOperation(context, std::move(ss), symbol, dim);
return std::visit(
common::visitors{
[](IndirectSubscriptIntegerExpr &expr)
const Constant<T> &array,
const std::vector<Constant<SubscriptInteger>> &subscripts) {
const auto &shape{array.shape()};
- std::size_t rank{shape.size()};
- CHECK(rank == subscripts.size());
+ int rank{GetRank(shape)};
+ CHECK(rank == static_cast<int>(subscripts.size()));
std::size_t elements{1};
ConstantSubscripts resultShape;
for (const auto &ss : subscripts) {
std::vector<Scalar<T>> values;
while (elements-- > 0) {
bool increment{true};
- std::size_t k{0};
- for (std::size_t j{0}; j < rank; ++j) {
+ int k{0};
+ for (int j{0}; j < rank; ++j) {
if (subscripts[j].Rank() == 0) {
at[j] = subscripts[j].GetScalarValue().value().ToInt64();
} else {
- CHECK(k < resultShape.size());
+ CHECK(k < GetRank(resultShape));
tmp[0] = ssAt[j] + 1;
at[j] = subscripts[j].At(tmp).ToInt64();
if (increment) {
}
values.emplace_back(array.At(at));
CHECK(!increment || elements == 0);
- CHECK(k == resultShape.size());
+ CHECK(k == GetRank(resultShape));
}
if constexpr (T::category == TypeCategory::Character) {
return Constant<T>{array.LEN(), std::move(values), std::move(resultShape)};
}
template<typename T>
-static std::optional<Constant<T>> ApplyConstantSubscripts(
+std::optional<Constant<T>> ApplyConstantSubscripts(
FoldingContext &context, ArrayRef &aRef) {
+ const Symbol &symbol{aRef.GetLastSymbol()};
std::vector<Constant<SubscriptInteger>> subscripts;
+ int dim{0};
for (Subscript &ss : aRef.subscript()) {
- if (auto constant{GetConstantSubscript(context, ss)}) {
+ if (auto constant{GetConstantSubscript(context, ss, symbol, dim++)}) {
subscripts.emplace_back(std::move(*constant));
} else {
return std::nullopt;
}
}
+ // TODO pmk generalize to component base too
if (const Symbol *const *symbol{std::get_if<const Symbol *>(&aRef.base())}) {
if (auto value{GetParameterValue<T>(context, *symbol)}) {
Expr<T> folded{Fold(context, std::move(*value))};
- if (const auto *array{GetConstantValue<T>(folded)}) {
+ if (const auto *array{UnwrapConstantValue<T>(folded)}) {
if (auto result{
ApplySubscripts(context.messages(), *array, subscripts)}) {
return result;
}
template<typename T>
+std::optional<Constant<T>> GetConstantComponent(
+ FoldingContext &context, Component &component) {
+ // TODO pmk generalize to array ref and component bases too
+ if (const Symbol *const *symbol{
+ std::get_if<const Symbol *>(&component.base().u)}) {
+ if (auto value{GetParameterValue<SomeDerived>(context, *symbol)}) {
+ Expr<SomeDerived> folded{Fold(context, std::move(*value))};
+ if (const auto *structure{UnwrapConstantValue<SomeDerived>(folded)}) {
+ if (auto scalar{structure->GetScalarValue()}) {
+ if (auto *expr{scalar->Find(&component.GetLastSymbol())}) {
+ if (const auto *value{UnwrapConstantValue<T>(*expr)}) {
+ return *value;
+ }
+ }
+ }
+ }
+ }
+ }
+ return std::nullopt;
+}
+
+template<typename T>
Expr<T> FoldOperation(FoldingContext &context, Designator<T> &&designator) {
if constexpr (T::category == TypeCategory::Character) {
if (auto *substring{common::Unwrap<Substring>(designator.u)}) {
}
},
[&](ArrayRef &&aRef) {
+ aRef = FoldOperation(context, std::move(aRef));
if (auto c{ApplyConstantSubscripts<T>(context, aRef)}) {
return Expr<T>{std::move(*c)};
} else {
- return Expr<T>{
- Designator<T>{FoldOperation(context, std::move(aRef))}};
+ return Expr<T>{Designator<T>{std::move(aRef)}};
+ }
+ },
+ [&](Component &&component) {
+ component = FoldOperation(context, std::move(component));
+ if (auto c{GetConstantComponent<T>(context, component)}) {
+ return Expr<T>{std::move(*c)};
+ } else {
+ return Expr<T>{Designator<T>{std::move(component)}};
}
},
[&](auto &&x) {
explicit ArrayConstructorFolder(const FoldingContext &c) : context_{c} {}
Expr<T> FoldArray(ArrayConstructor<T> &&array) {
+ // Calls FoldArray(const ArrayConstructorValues<T> &) below
if (FoldArray(array)) {
auto n{static_cast<std::int64_t>(elements_.size())};
if constexpr (std::is_same_v<T, SomeDerived>) {
private:
bool FoldArray(const common::CopyableIndirection<Expr<T>> &expr) {
Expr<T> folded{Fold(context_, common::Clone(expr.value()))};
- if (const auto *c{GetConstantValue<T>(folded)}) {
+ if (const auto *c{UnwrapConstantValue<T>(folded)}) {
// Copy elements in Fortran array element order
ConstantSubscripts shape{c->shape()};
int rank{c->Rank()};
- ConstantSubscripts index(shape.size(), 1);
+ ConstantSubscripts index(GetRank(shape), 1);
for (std::size_t n{c->size()}; n-- > 0;) {
elements_.emplace_back(c->At(index));
for (int d{0}; d < rank; ++d) {
template<typename T>
Expr<T> FoldOperation(FoldingContext &context, ArrayConstructor<T> &&array) {
- ArrayConstructorFolder<T> folder{context};
- Expr<T> result{folder.FoldArray(std::move(array))};
- return result;
+ return ArrayConstructorFolder<T>{context}.FoldArray(std::move(array));
}
Expr<SomeDerived> FoldOperation(
template<typename T>
std::optional<Expr<T>> AsFlatArrayConstructor(const Expr<T> &expr) {
- if (const auto *c{GetConstantValue<T>(expr)}) {
+ if (const auto *c{UnwrapConstantValue<T>(expr)}) {
ArrayConstructor<T> result{expr};
if (c->size() > 0) {
ConstantSubscripts at{InitialSubscripts(c->shape())};
}
template<TypeCategory CAT>
-std::optional<Expr<SomeKind<CAT>>> AsFlatArrayConstructor(
- const Expr<SomeKind<CAT>> &expr) {
+std::enable_if_t<CAT != TypeCategory::Derived,
+ std::optional<Expr<SomeKind<CAT>>>>
+AsFlatArrayConstructor(const Expr<SomeKind<CAT>> &expr) {
return std::visit(
[&](const auto &kindExpr) -> std::optional<Expr<SomeKind<CAT>>> {
if (auto flattened{AsFlatArrayConstructor(kindExpr)}) {
ArrayConstructor<T> &&values, std::optional<ConstantSubscripts> &&shape) {
Expr<T> result{Fold(context, Expr<T>{std::move(values)})};
if (shape.has_value()) {
- if (auto *constant{GetConstantValue<T>(result)}) {
- constant->shape() = std::move(*shape);
+ if (auto *constant{UnwrapConstantValue<T>(result)}) {
+ return Expr<T>{constant->Reshape(std::move(*shape))};
}
}
return result;
auto &aConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
for (auto &acValue : aConst) {
auto &scalar{std::get<Expr<kindType>>(acValue.u)};
- result.Push(
- FoldOperation(context, f(Expr<OPERAND>{std::move(scalar)})));
+ result.Push(Fold(context, f(Expr<OPERAND>{std::move(scalar)})));
}
},
std::move(values.u));
auto &aConst{std::get<ArrayConstructor<OPERAND>>(values.u)};
for (auto &acValue : aConst) {
auto &scalar{std::get<Expr<OPERAND>>(acValue.u)};
- result.Push(FoldOperation(context, f(std::move(scalar))));
+ result.Push(Fold(context, f(std::move(scalar))));
}
}
return FromArrayConstructor(
CHECK(rightIter != rightArrConst.end());
auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
auto &rightScalar{std::get<Expr<kindType>>(rightIter->u)};
- result.Push(FoldOperation(context,
+ result.Push(Fold(context,
f(std::move(leftScalar), Expr<RIGHT>{std::move(rightScalar)})));
++rightIter;
}
CHECK(rightIter != rightArrConst.end());
auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
auto &rightScalar{std::get<Expr<RIGHT>>(rightIter->u)};
- result.Push(FoldOperation(
- context, f(std::move(leftScalar), std::move(rightScalar))));
+ result.Push(
+ Fold(context, f(std::move(leftScalar), std::move(rightScalar))));
++rightIter;
}
}
auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
for (auto &leftValue : leftArrConst) {
auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
- result.Push(FoldOperation(
- context, f(std::move(leftScalar), Expr<RIGHT>{rightScalar})));
+ result.Push(
+ Fold(context, f(std::move(leftScalar), Expr<RIGHT>{rightScalar})));
}
return FromArrayConstructor(
context, std::move(result), AsConstantExtents(shape));
auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
for (auto &rightValue : rightArrConst) {
auto &rightScalar{std::get<Expr<kindType>>(rightValue.u)};
- result.Push(FoldOperation(context,
+ result.Push(Fold(context,
f(Expr<LEFT>{leftScalar},
Expr<RIGHT>{std::move(rightScalar)})));
}
auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
for (auto &rightValue : rightArrConst) {
auto &rightScalar{std::get<Expr<RIGHT>>(rightValue.u)};
- result.Push(FoldOperation(
- context, f(Expr<LEFT>{leftScalar}, std::move(rightScalar))));
+ result.Push(
+ Fold(context, f(Expr<LEFT>{leftScalar}, std::move(rightScalar))));
}
}
return FromArrayConstructor(
using namespace Fortran::parser::literals;
// Fold() rewrites an expression and returns it. When the rewritten expression
-// is a constant, GetConstantValue() and GetScalarConstantValue() below will
+// is a constant, UnwrapConstantValue() and GetScalarConstantValue() below will
// be able to extract it.
// Note the rvalue reference argument: the rewrites are performed in place
// for efficiency.
}
}
-// GetConstantValue() isolates the known constant value of
-// an expression, if it has one. The value can be parenthesized.
+// UnwrapConstantValue() isolates the known constant value of
+// an expression, if it has one. It returns a pointer, which is
+// const-qualified when the expression is so. The value can be
+// parenthesized.
template<typename T, typename EXPR>
-const Constant<T> *GetConstantValue(const EXPR &expr) {
- if (const auto *c{UnwrapExpr<Constant<T>>(expr)}) {
- return c;
- } else {
- if constexpr (!std::is_same_v<T, SomeDerived>) {
- if (auto *parens{UnwrapExpr<Parentheses<T>>(expr)}) {
- return GetConstantValue<T>(parens->left());
- }
- }
- return nullptr;
- }
-}
-
-template<typename T, typename EXPR> Constant<T> *GetConstantValue(EXPR &expr) {
+auto UnwrapConstantValue(EXPR &expr) -> common::Constify<Constant<T>, EXPR> * {
if (auto *c{UnwrapExpr<Constant<T>>(expr)}) {
return c;
} else {
if constexpr (!std::is_same_v<T, SomeDerived>) {
if (auto *parens{UnwrapExpr<Parentheses<T>>(expr)}) {
- return GetConstantValue<T>(parens->left());
+ return UnwrapConstantValue<T>(parens->left());
}
}
return nullptr;
// an expression, if it has one. The value can be parenthesized.
template<typename T, typename EXPR>
auto GetScalarConstantValue(const EXPR &expr) -> std::optional<Scalar<T>> {
- if (const Constant<T> *constant{GetConstantValue<T>(expr)}) {
+ if (const Constant<T> *constant{UnwrapConstantValue<T>(expr)}) {
return constant->GetScalarValue();
} else {
return std::nullopt;
namespace Fortran::evaluate {
static void ShapeAsFortran(std::ostream &o, const ConstantSubscripts &shape) {
- if (shape.size() > 1) {
+ if (GetRank(shape) > 1) {
o << ",shape=";
char ch{'['};
for (auto dim : shape) {
if (isAlternateReturn) {
o << '*';
}
- if (const auto *expr{GetExpr()}) {
+ if (const auto *expr{UnwrapExpr()}) {
return expr->AsFortran(o);
} else {
return std::get<AssumedType>(u_).AsFortran(o);
{"cshift",
{{"array", SameType, Rank::array}, {"shift", AnyInt, Rank::dimRemoved},
OptionalDIM},
- SameType, Rank::array},
+ SameType, Rank::conformable},
{"dble", {{"a", AnyNumeric, Rank::elementalOrBOZ}}, DoublePrecision},
{"dim", {{"x", SameIntOrReal}, {"y", SameIntOrReal}}, SameIntOrReal},
{"dot_product",
{"boundary", SameIntrinsic, Rank::dimRemoved,
Optionality::optional},
OptionalDIM},
- SameIntrinsic, Rank::array},
+ SameIntrinsic, Rank::conformable},
{"eoshift",
{{"array", SameDerivedType, Rank::array},
{"shift", AnyInt, Rank::dimRemoved},
{"boundary", SameDerivedType, Rank::dimRemoved}, OptionalDIM},
- SameDerivedType, Rank::array},
+ SameDerivedType, Rank::conformable},
{"erf", {{"x", SameReal}}, SameReal},
{"erfc", {{"x", SameReal}}, SameReal},
{"erfc_scaled", {{"x", SameReal}}, SameReal},
{"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical},
{"kind", {{"x", AnyIntrinsic}}, DefaultInt},
{"lbound",
- {{"array", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
- KINDInt, Rank::vector},
- {"lbound",
{{"array", Anything, Rank::anyOrAssumedRank},
{"dim", {IntType, KindCode::dimArg}, Rank::scalar},
SubscriptDefaultKIND},
KINDInt, Rank::scalar},
+ {"lbound",
+ {{"array", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
+ KINDInt, Rank::vector},
{"leadz", {{"i", AnyInt}}, DefaultInt},
{"len", {{"string", AnyChar}, SubscriptDefaultKIND}, KINDInt},
{"len_trim", {{"string", AnyChar}, SubscriptDefaultKIND}, KINDInt},
{"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix},
{"trim", {{"string", SameChar, Rank::scalar}}, SameChar, Rank::scalar},
{"ubound",
- {{"array", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
- KINDInt, Rank::vector},
- {"ubound",
{{"array", Anything, Rank::anyOrAssumedRank},
{"dim", {IntType, KindCode::dimArg}, Rank::scalar},
SubscriptDefaultKIND},
KINDInt, Rank::scalar},
+ {"ubound",
+ {{"array", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
+ KINDInt, Rank::vector},
{"unpack",
{{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array},
{"field", SameType, Rank::conformable}},
std::optional<DynamicType> type{arg->GetType()};
if (!type.has_value()) {
CHECK(arg->Rank() == 0);
- const Expr<SomeType> *expr{arg->GetExpr()};
+ const Expr<SomeType> *expr{arg->UnwrapExpr()};
CHECK(expr != nullptr);
if (std::holds_alternative<BOZLiteralConstant>(expr->u)) {
if (d.typePattern.kindCode == KindCode::typeless ||
CHECK(kindDummyArg != nullptr);
CHECK(result.categorySet == CategorySet{*category});
if (kindArg != nullptr) {
- if (auto *expr{kindArg->GetExpr()}) {
+ if (auto *expr{kindArg->UnwrapExpr()}) {
CHECK(expr->Rank() == 0);
if (auto code{ToInt64(*expr)}) {
if (IsValidKindOfIntrinsicType(*category, *code)) {
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const auto &arg{rearranged[j]}) {
- const Expr<SomeType> *expr{arg->GetExpr()};
+ const Expr<SomeType> *expr{arg->UnwrapExpr()};
CHECK(expr != nullptr);
std::optional<characteristics::TypeAndShape> typeAndShape;
if (auto type{expr->GetType()}) {
context.messages().Say("Unknown argument '%s' to NULL()"_err_en_US,
arguments[0]->keyword->ToString());
} else {
- if (Expr<SomeType> * mold{arguments[0]->GetExpr()}) {
+ if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
if (IsAllocatableOrPointer(*mold)) {
characteristics::DummyArguments args;
std::optional<characteristics::FunctionResult> fResult;
if (call.name == "present") {
bool ok{false};
if (const auto &arg{specificCall->arguments[0]}) {
- if (const auto *expr{arg->GetExpr()}) {
+ if (const auto *expr{arg->UnwrapExpr()}) {
if (const Symbol * symbol{IsWholeSymbolDataRef(*expr)}) {
ok = symbol->attrs().test(semantics::Attr::OPTIONAL);
}
namespace Fortran::evaluate {
+bool IsImpliedShape(const Symbol &symbol) {
+ if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
+ if (symbol.attrs().test(semantics::Attr::PARAMETER) &&
+ details->init().has_value()) {
+ for (const semantics::ShapeSpec &ss : details->shape()) {
+ if (!ss.ubound().isDeferred()) {
+ // ss.isDeferred() can't be used because the lower bounds are
+ // implicitly set to 1 in the symbol table.
+ return false;
+ }
+ }
+ return !details->shape().empty();
+ }
+ }
+ return false;
+}
+
+bool IsExplicitShape(const Symbol &symbol) {
+ if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
+ for (const semantics::ShapeSpec &ss : details->shape()) {
+ if (!ss.isExplicit()) {
+ return false;
+ }
+ }
+ return true; // even if scalar
+ } else {
+ return false;
+ }
+}
+
Shape AsShape(const Constant<ExtentType> &arrayConstant) {
CHECK(arrayConstant.Rank() == 1);
Shape result;
std::size_t dimensions{arrayConstant.size()};
for (std::size_t j{0}; j < dimensions; ++j) {
Scalar<ExtentType> extent{arrayConstant.values().at(j)};
- result.emplace_back(MaybeExtent{ExtentExpr{extent}});
+ result.emplace_back(MaybeExtentExpr{ExtentExpr{extent}});
}
return result;
}
std::optional<Shape> AsShape(FoldingContext &context, ExtentExpr &&arrayExpr) {
// Flatten any array expression into an array constructor if possible.
arrayExpr = Fold(context, std::move(arrayExpr));
- if (const auto *constArray{GetConstantValue<ExtentType>(arrayExpr)}) {
+ if (const auto *constArray{UnwrapConstantValue<ExtentType>(arrayExpr)}) {
return AsShape(*constArray);
}
if (auto *constructor{UnwrapExpr<ArrayConstructor<ExtentType>>(arrayExpr)}) {
if (auto shapeArray{AsExtentArrayExpr(shape)}) {
FoldingContext noFoldingContext;
auto folded{Fold(noFoldingContext, std::move(*shapeArray))};
- if (auto *p{GetConstantValue<ExtentType>(folded)}) {
+ if (auto *p{UnwrapConstantValue<ExtentType>(folded)}) {
return std::move(*p);
}
}
return std::nullopt;
}
+Constant<SubscriptInteger> AsConstantShape(const ConstantSubscripts &shape) {
+ using IntType = Scalar<SubscriptInteger>;
+ std::vector<IntType> result;
+ for (auto dim : shape) {
+ result.emplace_back(dim);
+ }
+ return {std::move(result), ConstantSubscripts{GetRank(shape)}};
+}
+
ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &shape) {
ConstantSubscripts result;
for (const auto &extent : shape.values()) {
common::Clone(lower), common::Clone(upper), common::Clone(stride));
}
-MaybeExtent CountTrips(
- MaybeExtent &&lower, MaybeExtent &&upper, MaybeExtent &&stride) {
+MaybeExtentExpr CountTrips(MaybeExtentExpr &&lower, MaybeExtentExpr &&upper,
+ MaybeExtentExpr &&stride) {
return common::MapOptional(
ComputeTripCount, std::move(lower), std::move(upper), std::move(stride));
}
-MaybeExtent GetSize(Shape &&shape) {
+MaybeExtentExpr GetSize(Shape &&shape) {
ExtentExpr extent{1};
for (auto &&dim : std::move(shape)) {
if (dim.has_value()) {
return Visitor<MyVisitor>{0}.Traverse(expr);
}
-MaybeExtent GetShapeHelper::GetLowerBound(
- const Symbol &symbol, const Component *component, int dimension) {
+MaybeExtentExpr GetLowerBound(FoldingContext &context, const Symbol &symbol,
+ int dimension, const Component *component) {
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
int j{0};
for (const auto &shapeSpec : details->shape()) {
if (j++ == dimension) {
if (const auto &bound{shapeSpec.lbound().GetExplicit()}) {
- return *bound;
+ return Fold(context, common::Clone(*bound));
} else if (component != nullptr) {
return ExtentExpr{DescriptorInquiry{
*component, DescriptorInquiry::Field::LowerBound, dimension}};
return std::nullopt;
}
-static bool IsImpliedShape(const Symbol &symbol) {
+MaybeExtentExpr GetExtent(FoldingContext &context, const Symbol &symbol,
+ int dimension, const Component *component) {
+ CHECK(dimension >= 0);
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
- if (symbol.attrs().test(semantics::Attr::PARAMETER) &&
- details->init().has_value()) {
- for (const semantics::ShapeSpec &ss : details->shape()) {
- if (ss.isExplicit()) {
- return false;
- }
- }
- return true;
+ if (IsImpliedShape(symbol)) {
+ Shape shape{GetShape(context, symbol).value()};
+ return std::move(shape.at(dimension));
}
- }
- return false;
-}
-
-MaybeExtent GetShapeHelper::GetExtent(
- const Symbol &symbol, const Component *component, int dimension) {
- if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
int j{0};
for (const auto &shapeSpec : details->shape()) {
if (j++ == dimension) {
if (shapeSpec.isExplicit()) {
if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) {
- FoldingContext noFoldingContext;
if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) {
- return Fold(noFoldingContext,
+ return Fold(context,
common::Clone(ubound.value()) -
common::Clone(lbound.value()) + ExtentExpr{1});
} else {
- return Fold(noFoldingContext, common::Clone(ubound.value()));
+ return Fold(context, common::Clone(ubound.value()));
}
}
- } else if (IsImpliedShape(symbol)) {
- Shape shape{GetShape(symbol).value()};
- return std::move(shape.at(dimension));
} else if (details->IsAssumedSize() && j == symbol.Rank()) {
return std::nullopt;
} else if (component != nullptr) {
return std::nullopt;
}
-MaybeExtent GetShapeHelper::GetExtent(const Subscript &subscript,
- const Symbol &symbol, const Component *component, int dimension) {
+MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
+ const Symbol &symbol, int dimension, const Component *component) {
return std::visit(
common::visitors{
- [&](const Triplet &triplet) -> MaybeExtent {
- MaybeExtent upper{triplet.upper()};
+ [&](const Triplet &triplet) -> MaybeExtentExpr {
+ MaybeExtentExpr upper{triplet.upper()};
if (!upper.has_value()) {
- upper = GetExtent(symbol, component, dimension);
+ upper = GetExtent(context, symbol, dimension, component);
}
- MaybeExtent lower{triplet.lower()};
+ MaybeExtentExpr lower{triplet.lower()};
if (!lower.has_value()) {
- lower = GetLowerBound(symbol, component, dimension);
+ lower = GetLowerBound(context, symbol, dimension, component);
}
return CountTrips(std::move(lower), std::move(upper),
- MaybeExtent{triplet.stride()});
+ MaybeExtentExpr{triplet.stride()});
},
- [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtent {
- if (auto shape{GetShape(subs.value())}) {
- if (shape->size() > 0) {
- CHECK(shape->size() == 1); // vector-valued subscript
+ [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr {
+ if (auto shape{GetShape(context, subs.value())}) {
+ if (GetRank(*shape) > 0) {
+ CHECK(GetRank(*shape) == 1); // vector-valued subscript
return std::move(shape->at(0));
}
}
subscript.u);
}
+MaybeExtentExpr GetUpperBound(FoldingContext &context, MaybeExtentExpr &&lower,
+ MaybeExtentExpr &&extent) {
+ if (lower.has_value() && extent.has_value()) {
+ return Fold(
+ context, std::move(*extent) - std::move(*lower) + ExtentExpr{1});
+ } else {
+ return std::nullopt;
+ }
+}
+
std::optional<Shape> GetShapeHelper::GetShape(
const Symbol &symbol, const Component *component) {
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
Shape result;
int n{static_cast<int>(details->shape().size())};
for (int dimension{0}; dimension < n; ++dimension) {
- result.emplace_back(GetExtent(symbol, component, dimension++));
+ result.emplace_back(GetExtent(context_, symbol, dimension, component));
}
return result;
}
int dimension{0};
for (const Subscript &ss : arrayRef.subscript()) {
if (ss.Rank() > 0) {
- shape.emplace_back(GetExtent(ss, symbol, component, dimension));
+ shape.emplace_back(GetExtent(context_, ss, symbol, dimension, component));
}
++dimension;
}
int dimension{0};
for (const Subscript &ss : coarrayRef.subscript()) {
if (ss.Rank() > 0) {
- shape.emplace_back(GetExtent(ss, symbol, component, dimension));
+ shape.emplace_back(GetExtent(context_, ss, symbol, dimension, component));
}
++dimension;
}
}
std::optional<Shape> GetShapeHelper::GetShape(const ActualArgument &arg) {
- if (const auto *expr{arg.GetExpr()}) {
+ if (const auto *expr{arg.UnwrapExpr()}) {
return GetShape(*expr);
} else {
const Symbol *aType{arg.GetAssumedTypeDummy()};
std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
intrinsic->name == "ubound") {
- const auto *expr{call.arguments().front().value().GetExpr()};
+ const auto *expr{call.arguments().front().value().UnwrapExpr()};
CHECK(expr != nullptr);
- return Shape{MaybeExtent{ExtentExpr{expr->Rank()}}};
+ return Shape{MaybeExtentExpr{ExtentExpr{expr->Rank()}}};
} else if (intrinsic->name == "reshape") {
if (call.arguments().size() >= 2 && call.arguments().at(1).has_value()) {
// SHAPE(RESHAPE(array,shape)) -> shape
- const auto *shapeExpr{call.arguments().at(1).value().GetExpr()};
+ const auto *shapeExpr{call.arguments().at(1).value().UnwrapExpr()};
CHECK(shapeExpr != nullptr);
Expr<SomeInteger> shape{std::get<Expr<SomeInteger>>(shapeExpr->u)};
return AsShape(context_, ConvertToType<ExtentType>(std::move(shape)));
bool CheckConformance(parser::ContextualMessages &messages, const Shape &left,
const Shape &right, const char *leftDesc, const char *rightDesc) {
if (!left.empty() && !right.empty()) {
- int n{static_cast<int>(left.size())};
- int rn{static_cast<int>(right.size())};
+ int n{GetRank(left)};
+ int rn{GetRank(right)};
if (n != rn) {
messages.Say("Rank of %s is %d, but %s has rank %d"_err_en_US, leftDesc,
n, rightDesc, rn);
using ExtentType = SubscriptInteger;
using ExtentExpr = Expr<ExtentType>;
-using MaybeExtent = std::optional<ExtentExpr>;
-using Shape = std::vector<MaybeExtent>;
+using MaybeExtentExpr = std::optional<ExtentExpr>;
+using Shape = std::vector<MaybeExtentExpr>;
+
+bool IsImpliedShape(const Symbol &);
+bool IsExplicitShape(const Symbol &);
// Conversions between various representations of shapes.
-Shape AsShape(const Constant<ExtentType> &arrayConstant);
-std::optional<Shape> AsShape(FoldingContext &, ExtentExpr &&arrayExpr);
+Shape AsShape(const Constant<ExtentType> &);
+std::optional<Shape> AsShape(FoldingContext &, ExtentExpr &&);
+
std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &);
+
std::optional<Constant<ExtentType>> AsConstantShape(const Shape &);
+Constant<ExtentType> AsConstantShape(const ConstantSubscripts &);
+
ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &);
std::optional<ConstantSubscripts> AsConstantExtents(const Shape &);
+inline int GetRank(const Shape &s) { return static_cast<int>(s.size()); }
+
+// The dimension here is zero-based, unlike DIM= arguments to many intrinsics.
+MaybeExtentExpr GetLowerBound(FoldingContext &, const Symbol &, int dimension,
+ const Component * = nullptr);
+MaybeExtentExpr GetExtent(FoldingContext &, const Symbol &, int dimension,
+ const Component * = nullptr);
+MaybeExtentExpr GetExtent(FoldingContext &, const Subscript &, const Symbol &,
+ int dimension, const Component * = nullptr);
+MaybeExtentExpr GetUpperBound(
+ FoldingContext &, MaybeExtentExpr &&lower, MaybeExtentExpr &&extent);
+
// Compute an element count for a triplet or trip count for a DO.
ExtentExpr CountTrips(
ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride);
ExtentExpr CountTrips(
const ExtentExpr &lower, const ExtentExpr &upper, const ExtentExpr &stride);
-MaybeExtent CountTrips(
- MaybeExtent &&lower, MaybeExtent &&upper, MaybeExtent &&stride);
+MaybeExtentExpr CountTrips(
+ MaybeExtentExpr &&lower, MaybeExtentExpr &&upper, MaybeExtentExpr &&stride);
// Computes SIZE() == PRODUCT(shape)
-MaybeExtent GetSize(Shape &&);
+MaybeExtentExpr GetSize(Shape &&);
// Utility predicate: does an expression reference any implied DO index?
bool ContainsAnyImpliedDoIndex(const ExtentExpr &);
template<typename T>
std::optional<Shape> GetShape(const ArrayConstructor<T> &aconst) {
- return Shape{GetExtent(aconst)};
+ return Shape{GetArrayConstructorExtent(aconst)};
}
template<typename... A>
private:
template<typename T>
- MaybeExtent GetExtent(const ArrayConstructorValue<T> &value) {
+ MaybeExtentExpr GetArrayConstructorValueExtent(
+ const ArrayConstructorValue<T> &value) {
return std::visit(
common::visitors{
- [&](const Expr<T> &x) -> MaybeExtent {
+ [&](const Expr<T> &x) -> MaybeExtentExpr {
if (std::optional<Shape> xShape{GetShape(x)}) {
// Array values in array constructors get linearized.
return GetSize(std::move(*xShape));
return std::nullopt;
}
},
- [&](const ImpliedDo<T> &ido) -> MaybeExtent {
+ [&](const ImpliedDo<T> &ido) -> MaybeExtentExpr {
// Don't be heroic and try to figure out triangular implied DO
// nests.
if (!ContainsAnyImpliedDoIndex(ido.lower()) &&
!ContainsAnyImpliedDoIndex(ido.upper()) &&
!ContainsAnyImpliedDoIndex(ido.stride())) {
- if (auto nValues{GetExtent(ido.values())}) {
+ if (auto nValues{GetArrayConstructorExtent(ido.values())}) {
return std::move(*nValues) *
CountTrips(ido.lower(), ido.upper(), ido.stride());
}
}
template<typename T>
- MaybeExtent GetExtent(const ArrayConstructorValues<T> &values) {
+ MaybeExtentExpr GetArrayConstructorExtent(
+ const ArrayConstructorValues<T> &values) {
ExtentExpr result{0};
for (const auto &value : values) {
- if (MaybeExtent n{GetExtent(value)}) {
+ if (MaybeExtentExpr n{GetArrayConstructorValueExtent(value)}) {
result = std::move(result) + std::move(*n);
} else {
return std::nullopt;
return result;
}
- // The dimension here is zero-based, unlike DIM= intrinsic arguments.
- MaybeExtent GetLowerBound(const Symbol &, const Component *, int dimension);
- MaybeExtent GetExtent(const Symbol &, const Component *, int dimension);
- MaybeExtent GetExtent(
- const Subscript &, const Symbol &, const Component *, int dimension);
-
FoldingContext &context_;
};
}
bool IsAssumedRank(const ActualArgument &arg) {
- if (const auto *expr{arg.GetExpr()}) {
+ if (const auto *expr{arg.UnwrapExpr()}) {
return IsAssumedRank(*expr);
} else {
const semantics::Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
}
// Specializing extractor. If an Expr wraps some type of object, perhaps
-// in several layers, return a pointer to it; otherwise null.
+// in several layers, return a pointer to it; otherwise null. Also works
+// with ActualArgument.
template<typename A, typename B>
auto UnwrapExpr(B &x) -> common::Constify<A, B> * {
using Ty = std::decay_t<B>;
if constexpr (std::is_same_v<A, Ty>) {
return &x;
- } else if constexpr (common::HasMember<Ty, TypelessExpression>) {
- return nullptr;
- } else if constexpr (std::is_same_v<Ty, Expr<ResultType<A>>>) {
- return common::Unwrap<A>(x.u);
- } else if constexpr (std::is_same_v<Ty, Expr<SomeType>> ||
- std::is_same_v<Ty, Expr<SomeKind<ResultType<A>::category>>>) {
+ } else if constexpr (std::is_same_v<Ty, ActualArgument>) {
+ if (auto *expr{x.UnwrapExpr()}) {
+ return UnwrapExpr<A>(*expr);
+ }
+ } else if constexpr (std::is_same_v<Ty, Expr<SomeType>>) {
return std::visit([](auto &x) { return UnwrapExpr<A>(x); }, x.u);
- } else {
- return nullptr;
+ } else if constexpr (!common::HasMember<A, TypelessExpression>) {
+ if constexpr (std::is_same_v<Ty, Expr<ResultType<A>>> ||
+ std::is_same_v<Ty, Expr<SomeKind<ResultType<A>::category>>>) {
+ return std::visit([](auto &x) { return UnwrapExpr<A>(x); }, x.u);
+ }
}
+ return nullptr;
}
template<typename A, typename B>
#include "expression.h"
#include "fold.h"
#include "../common/idioms.h"
+#include "../common/template.h"
#include "../semantics/scope.h"
#include "../semantics/symbol.h"
#include "../semantics/tools.h"
const SomeKind<TypeCategory::Derived> &that) const {
return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);
}
+
+static constexpr double LogBaseTenOfTwo{0.301029995664};
+
+class SelectedIntKindVisitor {
+public:
+ explicit SelectedIntKindVisitor(std::int64_t p) : precision_{p} {}
+ using Result = std::optional<int>;
+ using Types = IntegerTypes;
+ template<typename T> Result Test() const {
+ if ((Scalar<T>::bits - 1) * LogBaseTenOfTwo > precision_) {
+ return T::kind;
+ } else {
+ return std::nullopt;
+ }
+ }
+
+private:
+ std::int64_t precision_;
+};
+
+int SelectedIntKind(std::int64_t precision) {
+ if (auto kind{common::SearchTypes(SelectedIntKindVisitor{precision})}) {
+ return *kind;
+ } else {
+ return -1;
+ }
+}
+
+class SelectedRealKindVisitor {
+public:
+ explicit SelectedRealKindVisitor(std::int64_t p, std::int64_t r)
+ : precision_{p}, range_{r} {}
+ using Result = std::optional<int>;
+ using Types = RealTypes;
+ template<typename T> Result Test() const {
+ if ((Scalar<T>::precision - 1) * LogBaseTenOfTwo > precision_ &&
+ (Scalar<T>::exponentBias - 1) * LogBaseTenOfTwo > range_) {
+ return {T::kind};
+ } else {
+ return std::nullopt;
+ }
+ }
+
+private:
+ std::int64_t precision_, range_;
+};
+
+int SelectedRealKind(
+ std::int64_t precision, std::int64_t range, std::int64_t radix) {
+ if (radix != 2) {
+ return -5;
+ }
+ if (auto kind{
+ common::SearchTypes(SelectedRealKindVisitor{precision, range})}) {
+ return *kind;
+ }
+ // No kind has both sufficient precision and sufficient range.
+ // The negative return value encodes whether any kinds exist that
+ // could satisfy either constraint independently.
+ bool pOK{common::SearchTypes(SelectedRealKindVisitor{precision, 0})};
+ bool rOK{common::SearchTypes(SelectedRealKindVisitor{0, range})};
+ if (pOK) {
+ if (rOK) {
+ return -4;
+ } else {
+ return -2;
+ }
+ } else {
+ if (rOK) {
+ return -1;
+ } else {
+ return -3;
+ }
+ }
+}
}
// A predicate that is true when a kind value is a kind that could possibly
// be supported for an intrinsic type category on some target instruction
// set architecture.
+// TODO: specialize for the actual target architecture
static constexpr bool IsValidKindOfIntrinsicType(
TypeCategory category, std::int64_t kind) {
switch (category) {
template<typename CONST> using TypeOf = typename TypeOfHelper<CONST>::type;
+int SelectedIntKind(std::int64_t precision = 0);
+int SelectedRealKind(
+ std::int64_t precision = 0, std::int64_t range = 0, std::int64_t radix = 2);
+
// For generating "[extern] template class", &c. boilerplate
#define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \
M(P, S, 1) M(P, S, 2) M(P, S, 4) M(P, S, 8) M(P, S, 16)
#include <optional>
#include <set>
-// #define DUMP_ON_FAILURE 1
+#define DUMP_ON_FAILURE 1 // pmk
// #define CRASH_ON_FAILURE
#if DUMP_ON_FAILURE
#include "../parser/dump-parse-tree.h"
if (subscripts != symbolRank) {
Say("Reference to rank-%d object '%s' has %d subscripts"_err_en_US,
symbolRank, symbol.name(), subscripts);
+ return std::nullopt;
} else if (subscripts == 0) {
// nothing to check
} else if (Component * component{std::get_if<Component>(&ref.base())}) {
Say("Subscripts of component '%s' of rank-%d derived type "
"array have rank %d but must all be scalar"_err_en_US,
symbol.name(), baseRank, subscriptRank);
+ return std::nullopt;
}
}
} else if (const auto *details{
Say("Assumed-size array '%s' must have explicit final "
"subscript upper bound value"_err_en_US,
symbol.name());
+ return std::nullopt;
}
}
}
// A bare reference to a derived type parameter (within a parameterized
// derived type definition)
return AsMaybeExpr(MakeBareTypeParamInquiry(&ultimate));
- } else if (MaybeExpr result{Designate(DataRef{ultimate})}) {
- return result;
} else {
return Designate(DataRef{*n.symbol});
}
using namespace parser::literals;
-// The extension used for module files.
-static constexpr auto extension{".mod"};
// The initial characters of a file that identify it as a .mod file.
static constexpr auto magic{"!mod$ v1 sum:"};
static const SourceName *GetSubmoduleParent(const parser::Program &);
-static std::string ModFilePath(
- const std::string &, const SourceName &, const std::string &);
+static std::string ModFilePath(const std::string &dir, const SourceName &,
+ const std::string &ancestor, const std::string &suffix);
static std::vector<const Symbol *> CollectSymbols(const Scope &);
static void PutEntity(std::ostream &, const Symbol &);
static void PutObjectEntity(std::ostream &, const Symbol &);
void ModFileWriter::Write(const Symbol &symbol) {
auto *ancestor{symbol.get<ModuleDetails>().ancestor()};
auto ancestorName{ancestor ? ancestor->name().ToString() : ""s};
- auto path{
- ModFilePath(context_.moduleDirectory(), symbol.name(), ancestorName)};
+ auto path{ModFilePath(context_.moduleDirectory(), symbol.name(), ancestorName,
+ context_.moduleFileSuffix())};
PutSymbols(*symbol.scope());
if (!WriteFile(path, GetAsString(symbol))) {
context_.Say(symbol.name(), "Error writing %s: %s"_err_en_US, path,
const SourceName &name, const std::string &ancestor) {
parser::Messages attachments;
for (auto &dir : context_.searchDirectories()) {
- std::string path{ModFilePath(dir, name, ancestor)};
+ std::string path{
+ ModFilePath(dir, name, ancestor, context_.moduleFileSuffix())};
std::ifstream ifstream{path};
if (!ifstream.good()) {
attachments.Say(name, "%s: %s"_en_US, path, std::strerror(errno));
// Construct the path to a module file. ancestorName not empty means submodule.
static std::string ModFilePath(const std::string &dir, const SourceName &name,
- const std::string &ancestorName) {
+ const std::string &ancestorName, const std::string &suffix) {
std::stringstream path;
if (dir != "."s) {
path << dir << '/';
if (!ancestorName.empty()) {
PutLower(path, ancestorName) << '-';
}
- PutLower(path, name.ToString()) << extension;
+ PutLower(path, name.ToString()) << suffix;
return path.str();
}
}
}
void ScopeHandler::PopScope() {
+ // Entities that are not yet classified as objects or procedures are now
+ // assumed to be objects.
for (auto &pair : currScope()) {
- auto &symbol{*pair.second};
- ConvertToObjectEntity(symbol); // if not a proc by now, it is an object
+ ConvertToObjectEntity(*pair.second);
}
SetScope(currScope_->parent());
}
// If implicit types are allowed, ensure name is in the symbol table.
// Otherwise, report an error if it hasn't been declared.
const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
- if (FindSymbol(name)) {
+ if (Symbol * symbol{FindSymbol(name)}) {
if (CheckUseError(name)) {
return nullptr; // reported an error
}
+ if (symbol->IsDummy()) {
+ ApplyImplicitRules(*symbol);
+ }
return &name;
}
if (isImplicitNoneType()) {
for (auto &child : node.children()) {
ResolveSpecificationParts(child);
}
- PopScope();
+ // Subtlety: PopScope() is not called here because we want to defer
+ // conversions of uncategorized entities into objects until after
+ // we have traversed the executable part of the subprogram.
+ // Function results, however, are converted now so that they can
+ // be used in executable parts.
+ if (Symbol * symbol{currScope().symbol()}) {
+ if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
+ if (details->isFunction()) {
+ Symbol &result{const_cast<Symbol &>(details->result())};
+ ConvertToObjectEntity(result);
+ }
+ }
+ }
+ SetScope(currScope().parent());
}
// Add SubprogramNameDetails symbols for contained subprograms
if (const auto *exec{node.exec()}) {
Walk(*exec);
}
+ PopScope(); // converts unclassified entities into objects
for (const auto &child : node.children()) {
ResolveExecutionParts(child);
}
return searchDirectories_;
}
const std::string &moduleDirectory() const { return moduleDirectory_; }
+ const std::string &moduleFileSuffix() const { return moduleFileSuffix_; }
bool warnOnNonstandardUsage() const { return warnOnNonstandardUsage_; }
bool warningsAreErrors() const { return warningsAreErrors_; }
const evaluate::IntrinsicProcTable &intrinsics() const { return intrinsics_; }
moduleDirectory_ = x;
return *this;
}
+ SemanticsContext &set_moduleFileSuffix(const std::string &x) {
+ moduleFileSuffix_ = x;
+ return *this;
+ }
SemanticsContext &set_warnOnNonstandardUsage(bool x) {
warnOnNonstandardUsage_ = x;
return *this;
const parser::CharBlock *location_{nullptr};
std::vector<std::string> searchDirectories_;
std::string moduleDirectory_{"."s};
+ std::string moduleFileSuffix_{".mod"};
bool warnOnNonstandardUsage_{false};
bool warningsAreErrors_{false};
const evaluate::IntrinsicProcTable intrinsics_;
MaybeExpr &init() { return init_; }
const MaybeExpr &init() const { return init_; }
void set_init(MaybeExpr &&expr) { init_ = std::move(expr); }
+ bool initWasValidated() const { return initWasValidated_; }
+ void set_initWasValidated(bool yes = true) { initWasValidated_ = yes; }
ArraySpec &shape() { return shape_; }
const ArraySpec &shape() const { return shape_; }
ArraySpec &coshape() { return coshape_; }
private:
MaybeExpr init_;
+ bool initWasValidated_{false};
ArraySpec shape_;
ArraySpec coshape_;
const Symbol *commonBlock_{nullptr}; // common block this object is in
[](const SubprogramNameDetails &) { return true; },
[](const ProcEntityDetails &) { return true; },
[](const GenericDetails &) { return true; },
+ [](const ProcBindingDetails &) { return true; },
[](const UseDetails &x) { return IsProcedure(x.symbol()); },
[](const auto &) { return false; },
},
modfile23.f90
modfile24.f90
modfile25.f90
+ modfile26.f90
)
set(LABEL_TESTS
--- /dev/null
+! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! SELECTED_INT_KIND and SELECTED_REAL_KIND
+
+module m1
+ ! INTEGER(KIND=1) handles 0 <= P < 3
+ ! INTEGER(KIND=2) handles 3 <= P < 5
+ ! INTEGER(KIND=4) handles 5 <= P < 10
+ ! INTEGER(KIND=8) handles 10 <= P < 19
+ ! INTEGER(KIND=16) handles 19 <= P < 38
+ integer, parameter :: intpvals(:) = [0, 2, 3, 4, 5, 9, 10, 18, 19, 38, 39]
+ integer, parameter :: intpkinds(:) = &
+ [(selected_int_kind(intpvals(j)),j=1,size(intpvals))]
+ logical, parameter :: ipcheck = &
+ all([1, 1, 2, 2, 4, 4, 8, 8, 16, 16, -1] == intpkinds)
+ ! REAL(KIND=2) handles 0 <= P < 4 (if available)
+ ! REAL(KIND=4) handles 4 <= P < 7
+ ! REAL(KIND=8) handles 7 <= P < 16
+ ! REAL(KIND=10) handles 16 <= P < 19 (if available; ifort is KIND=16)
+ ! REAL(KIND=16) handles 19 <= P < 34 (32 with Power double/double)
+ integer, parameter :: realpvals(:) = [0, 3, 4, 6, 7, 15, 16, 18, 19, 33, 34]
+ integer, parameter :: realpkinds(:) = &
+ [(selected_real_kind(realpvals(j),0),j=1,size(realpvals))]
+ logical, parameter :: realpcheck = &
+ all([2, 2, 4, 4, 8, 8, 10, 10, 16, 16, -1] == realpkinds)
+ ! REAL(KIND=2) handles 0 <= R < 5 (if available)
+ ! REAL(KIND=3) handles 5 <= R < 38 (if available, same range as KIND=4)
+ ! REAL(KIND=4) handles 5 <= R < 38 (if no KIND=3)
+ ! REAL(KIND=8) handles 38 <= R < 308
+ ! REAL(KIND=10) handles 308 <= R < 4932 (if available; ifort is KIND=16)
+ ! REAL(KIND=16) handles 4932 <= R < 9864 (except Power double/double)
+ integer, parameter :: realrvals(:) = &
+ [0, 4, 5, 37, 38, 307, 308, 4931, 4932, 9863, 9864]
+ integer, parameter :: realrkinds(:) = &
+ [(selected_real_kind(0,realrvals(j)),j=1,size(realrvals))]
+ logical, parameter :: realrcheck = &
+ all([2, 2, 3, 3, 8, 8, 10, 10, 16, 16, -2] == realrkinds)
+end module m1
+!Expect: m1.mod
+!module m1
+!integer(4),parameter::intpvals(1_8:)=[Integer(4)::0_4,2_4,3_4,4_4,5_4,9_4,10_4,18_4,19_4,38_4,39_4]
+!integer(4),parameter::intpkinds(1_8:)=[Integer(4)::1_4,1_4,2_4,2_4,4_4,4_4,8_4,8_4,16_4,16_4,-1_4]
+!logical(4),parameter::ipcheck=.true._4
+!integer(4),parameter::realpvals(1_8:)=[Integer(4)::0_4,3_4,4_4,6_4,7_4,15_4,16_4,18_4,19_4,33_4,34_4]
+!integer(4),parameter::realpkinds(1_8:)=[Integer(4)::2_4,2_4,4_4,4_4,8_4,8_4,10_4,10_4,16_4,16_4,-1_4]
+!logical(4),parameter::realpcheck=.true._4
+!integer(4),parameter::realrvals(1_8:)=[Integer(4)::0_4,4_4,5_4,37_4,38_4,307_4,308_4,4931_4,4932_4,9863_4,9864_4]
+!integer(4),parameter::realrkinds(1_8:)=[Integer(4)::2_4,2_4,3_4,3_4,8_4,8_4,10_4,10_4,16_4,16_4,-2_4]
+!logical(4),parameter::realrcheck=.true._4
+!end
std::string outputPath; // -o path
std::vector<std::string> searchDirectories{"."s}; // -I dir
std::string moduleDirectory{"."s}; // -module dir
+ std::string moduleFileSuffix{".mod"}; // -moduleSuffix suff
bool forcedForm{false}; // -Mfixed or -Mfree appeared
bool warnOnNonstandardUsage{false}; // -Mstandard
bool warningsAreErrors{false}; // -Werror
defaultKinds.set_defaultIntegerKind(8);
} else if (arg == "-fno-large-arrays") {
defaultKinds.set_subscriptIntegerKind(4);
+ } else if (arg == "-module") {
+ driver.moduleDirectory = args.front();
+ args.pop_front();
+ } else if (arg == "-module-suffix") {
+ driver.moduleFileSuffix = args.front();
+ args.pop_front();
} else if (arg == "-help" || arg == "--help" || arg == "-?") {
std::cerr
<< "f18 options:\n"
<< " -Werror treat warnings as errors\n"
<< " -ed enable fixed form D lines\n"
<< " -E prescan & preprocess only\n"
+ << " -module dir module output directory (default .)\n"
<< " -fparse-only parse only, no output except messages\n"
<< " -funparse parse & reformat only, no code "
"generation\n"
args.pop_front();
} else if (arg.substr(0, 2) == "-I") {
driver.searchDirectories.push_back(arg.substr(2));
- } else if (arg == "-module") {
- driver.moduleDirectory = args.front();
- driver.pgf90Args.push_back(driver.moduleDirectory);
- args.pop_front();
} else if (arg == "-Mx,125,4") { // PGI "all Kanji" mode
options.encoding = Fortran::parser::Encoding::EUC_JP;
}
Fortran::parser::LanguageFeature::BackslashEscapes)) {
driver.pgf90Args.push_back("-Mbackslash");
}
- if (options.features.IsEnabled(
- Fortran::parser::LanguageFeature::OpenMP)) {
+ if (options.features.IsEnabled(Fortran::parser::LanguageFeature::OpenMP)) {
driver.pgf90Args.push_back("-mp");
}
Fortran::semantics::SemanticsContext semanticsContext{
defaultKinds, options.features};
semanticsContext.set_moduleDirectory(driver.moduleDirectory)
+ .set_moduleFileSuffix(driver.moduleFileSuffix)
.set_searchDirectories(driver.searchDirectories)
.set_warnOnNonstandardUsage(driver.warnOnNonstandardUsage)
.set_warningsAreErrors(driver.warningsAreErrors);
projects / platform / upstream / llvm.git / commitdiff