namespace Fortran::common {
-// Fortran has five kinds of intrinsic data, and the derived types.
+// Fortran has five kinds of intrinsic data types, plus the derived types.
ENUM_CLASS(TypeCategory, Integer, Real, Complex, Character, Logical, Derived)
+constexpr bool IsNumericTypeCategory(TypeCategory category) {
+ return category == TypeCategory::Integer || category == TypeCategory::Real ||
+ category == TypeCategory::Complex;
+}
+
// Kinds of IMPORT statements. Default means IMPORT or IMPORT :: names.
ENUM_CLASS(ImportKind, Default, Only, None, All)
// SearchTypeList<PREDICATE, TYPES...> scans a list of types. The zero-based
// index of the first type T in the list for which PREDICATE<T>::value() is
// true is returned, or -1 if the predicate is false for every type in the list.
-// This is a compile-time operation; see SearchDynamicTypes below for a
-// run-time form.
+// This is a compile-time operation; see SearchTypes below for a run-time form.
template<int N, template<typename> class PREDICATE, typename TUPLE>
struct SearchTypeListHelper {
static constexpr int value() {
// Given a VISITOR class of the general form
// struct VISITOR {
// using Result = ...;
-// static constexpr std::size_t Types{...};
-// template<std::size_t J> static Result Test();
+// using Types = std::tuple<...>;
+// template<typename T> Result Test() { ... }
// };
-// SearchDynamicTypes will traverse the indices 0 .. (Types-1) and
-// invoke VISITOR::Test<J>() until it returns a value that casts
-// to true. If no invocation of Test succeeds, it returns a
-// default-constructed Result.
+// 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{}.
template<std::size_t J, typename VISITOR>
-typename VISITOR::Result SearchDynamicTypesHelper(VISITOR &&visitor) {
- if constexpr (J < VISITOR::Types) {
- if (auto result{visitor.template Test<J>()}) {
+typename VISITOR::Result SearchTypesHelper(VISITOR &&visitor) {
+ 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 SearchDynamicTypesHelper<J + 1, VISITOR>(std::move(visitor));
+ return SearchTypesHelper<J + 1, VISITOR>(std::move(visitor));
} else {
return typename VISITOR::Result{};
}
}
template<typename VISITOR>
-typename VISITOR::Result SearchDynamicTypes(VISITOR &&visitor) {
- return SearchDynamicTypesHelper<0, VISITOR>(std::move(visitor));
+typename VISITOR::Result SearchTypes(VISITOR &&visitor) {
+ return SearchTypesHelper<0, VISITOR>(std::move(visitor));
}
}
#endif // FORTRAN_COMMON_TEMPLATE_H_
#include "../parser/characters.h"
#include "../parser/message.h"
#include <ostream>
+#include <sstream>
#include <string>
#include <type_traits>
std::ostream &Emit(std::ostream &o, const CopyableIndirection<Expr<T>> &expr) {
return expr->AsFortran(o);
}
+
template<typename T>
std::ostream &Emit(std::ostream &, const ArrayConstructorValues<T> &);
-template<typename ITEM, typename INT>
-std::ostream &Emit(std::ostream &o, const ImpliedDo<ITEM, INT> &implDo) {
+template<typename T>
+std::ostream &Emit(std::ostream &o, const ImpliedDo<T> &implDo) {
o << '(';
Emit(o, *implDo.values);
- o << ',' << INT::AsFortran() << "::";
- o << implDo.controlVariableName.ToString();
+ o << ',' << ImpliedDoIndex::Result::AsFortran() << "::";
o << '=';
implDo.lower->AsFortran(o) << ',';
implDo.upper->AsFortran(o) << ',';
template<typename T>
std::ostream &ArrayConstructor<T>::AsFortran(std::ostream &o) const {
- o << '[' << result.AsFortran() << "::";
- Emit(o, *this);
+ o << '[' << GetType().AsFortran() << "::";
+ Emit(o, values);
+ return o << ']';
+}
+
+template<int KIND>
+std::ostream &ArrayConstructor<Type<TypeCategory::Character, KIND>>::AsFortran(
+ std::ostream &o) const {
+ std::stringstream len;
+ length->AsFortran(len);
+ o << '[' << GetType().AsFortran(len.str()) << "::";
+ Emit(o, values);
return o << ']';
}
o << "z'" << x.Hexadecimal() << "'";
},
[&](const CopyableIndirection<Substring> &s) { s->AsFortran(o); },
+ [&](const ImpliedDoIndex &i) { o << i.name.ToString(); },
[&](const auto &x) { x.AsFortran(o); },
},
derived().u);
return o;
}
-template<typename T> Expr<SubscriptInteger> ArrayConstructor<T>::LEN() const {
- // TODO pmk: extract from type spec in array constructor
- return AsExpr(Constant<SubscriptInteger>{0}); // TODO placeholder
-}
-
template<int KIND>
Expr<SubscriptInteger> Expr<Type<TypeCategory::Character, KIND>>::LEN() const {
return std::visit(
Expr<SomeType>::~Expr() {}
-template<typename T> DynamicType ArrayConstructor<T>::GetType() const {
- // TODO: pmk: parameterized derived types, CHARACTER length
- return result.GetType();
-}
-
#if defined(__APPLE__) && defined(__GNUC__)
template<typename A>
typename ExpressionBase<A>::Derived &ExpressionBase<A>::derived() {
derived().u);
}
+template<int KIND>
+ArrayConstructor<Type<TypeCategory::Character, KIND>>::~ArrayConstructor() {}
+
// Equality testing for classes without EVALUATE_UNION_CLASS_BOILERPLATE()
-template<typename V, typename O>
-bool ImpliedDo<V, O>::operator==(const ImpliedDo<V, O> &that) const {
+bool ImpliedDoIndex::operator==(const ImpliedDoIndex &that) const {
+ return name == that.name;
+}
+
+template<typename T>
+bool ImpliedDo<T>::operator==(const ImpliedDo<T> &that) const {
return controlVariableName == that.controlVariableName &&
lower == that.lower && upper == that.upper && stride == that.stride &&
values == that.values;
template<typename R>
bool ArrayConstructor<R>::operator==(const ArrayConstructor<R> &that) const {
- return *static_cast<const ArrayConstructorValues<R> *>(this) == that &&
- result == that.result && typeParameterValues == that.typeParameterValues;
+ return type == that.type && values == that.values;
+}
+
+template<int KIND>
+bool ArrayConstructor<Type<TypeCategory::Character, KIND>>::operator==(
+ const ArrayConstructor<Type<TypeCategory::Character, KIND>> &that) const {
+ return length == that.length && values == that.values;
}
bool GenericExprWrapper::operator==(const GenericExprWrapper &that) const {
#include "../lib/parser/char-block.h"
#include "../lib/parser/message.h"
#include <algorithm>
+#include <list>
#include <ostream>
#include <tuple>
#include <type_traits>
// Everything that can appear in, or as, a valid Fortran expression must be
// represented with an instance of some class containing a Result typedef that
// maps to some instantiation of Type<CATEGORY, KIND>, SomeKind<CATEGORY>,
-// or SomeType.
+// or SomeType. (Exception: BOZ literal constants in generic Expr<SomeType>.)
template<typename A> using ResultType = typename std::decay_t<A>::Result;
// Common Expr<> behaviors: every Expr<T> derives from ExpressionBase<T>.
// dynamic kind.
template<typename TO, TypeCategory FROMCAT>
struct Convert : public Operation<Convert<TO, FROMCAT>, TO, SomeKind<FROMCAT>> {
- // Fortran doesn't have conversions between kinds of CHARACTER.
+ // Fortran doesn't have conversions between kinds of CHARACTER apart from
+ // assignments, and in those the data must be convertible to/from 7-bit ASCII.
// Conversions between kinds of COMPLEX are represented piecewise.
static_assert(((TO::category == TypeCategory::Integer ||
TO::category == TypeCategory::Real) &&
template<typename RESULT> struct ArrayConstructorValues;
-template<typename VALUES, typename OPERAND> struct ImpliedDo {
- using Values = VALUES;
- using Operand = OPERAND;
- using Result = ResultType<Values>;
- static_assert(Operand::category == TypeCategory::Integer);
+struct ImpliedDoIndex {
+ using Result = SubscriptInteger;
+ bool operator==(const ImpliedDoIndex &) const;
+ static constexpr int Rank() { return 0; }
+ parser::CharBlock name; // nested implied DOs must use distinct names
+};
+
+template<typename RESULT> struct ImpliedDo {
+ using Result = RESULT;
bool operator==(const ImpliedDo &) const;
parser::CharBlock controlVariableName;
- CopyableIndirection<Expr<Operand>> lower, upper, stride;
- CopyableIndirection<Values> values;
+ CopyableIndirection<Expr<ResultType<ImpliedDoIndex>>> lower, upper, stride;
+ CopyableIndirection<ArrayConstructorValues<RESULT>> values;
};
template<typename RESULT> struct ArrayConstructorValue {
using Result = RESULT;
EVALUATE_UNION_CLASS_BOILERPLATE(ArrayConstructorValue)
- template<typename INT>
- using ImpliedDo = ImpliedDo<ArrayConstructorValues<Result>, INT>;
- common::CombineVariants<std::variant<CopyableIndirection<Expr<Result>>>,
- common::MapTemplate<ImpliedDo, IntegerTypes>>
- u;
+ std::variant<CopyableIndirection<Expr<Result>>, ImpliedDo<Result>> u;
};
template<typename RESULT> struct ArrayConstructorValues {
using Result = RESULT;
- CLASS_BOILERPLATE(ArrayConstructorValues)
- template<typename A> void Push(A &&x) { values.emplace_back(std::move(x)); }
+ DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ArrayConstructorValues)
+ ArrayConstructorValues() {}
bool operator==(const ArrayConstructorValues &) const;
+ template<typename A> void Push(A &&x) { values.emplace_back(std::move(x)); }
std::vector<ArrayConstructorValue<Result>> values;
};
-template<typename RESULT>
-struct ArrayConstructor : public ArrayConstructorValues<RESULT> {
+template<typename RESULT> struct ArrayConstructor {
using Result = RESULT;
- using ArrayConstructorValues<Result>::ArrayConstructorValues;
- DynamicType GetType() const;
+ CLASS_BOILERPLATE(ArrayConstructor)
+ ArrayConstructor(Result &&t, ArrayConstructorValues<Result> &&v)
+ : type{std::move(t)}, values{std::move(v)} {
+ CHECK(type.category != TypeCategory::Character);
+ }
+ bool operator==(const ArrayConstructor<RESULT> &) const;
+ DynamicType GetType() const { return type.GetType(); }
+ static constexpr int Rank() { return 1; }
+ std::ostream &AsFortran(std::ostream &) const;
+ Result type;
+ ArrayConstructorValues<Result> values;
+};
+
+template<int KIND>
+struct ArrayConstructor<Type<TypeCategory::Character, KIND>> {
+ using Result = Type<TypeCategory::Character, KIND>;
+ CLASS_BOILERPLATE(ArrayConstructor)
+ ArrayConstructor(
+ ArrayConstructorValues<Result> &&v, Expr<SubscriptInteger> &&len)
+ : values{std::move(v)}, length{std::move(len)} {}
+ ~ArrayConstructor();
+ bool operator==(const ArrayConstructor<Result> &) const;
+ static constexpr DynamicType GetType() { return Result::GetType(); }
static constexpr int Rank() { return 1; }
- Expr<SubscriptInteger> LEN() const;
- bool operator==(const ArrayConstructor &) const;
std::ostream &AsFortran(std::ostream &) const;
+ const Expr<SubscriptInteger> &LEN() const { return *length; }
- Result result;
- std::vector<Expr<SubscriptInteger>> typeParameterValues;
+ ArrayConstructorValues<Result> values;
+ CopyableIndirection<Expr<SubscriptInteger>> length;
};
// Expression representations for each type category.
: u{Constant<Result>{n}} {}
private:
- using Conversions = std::variant<Convert<Result, TypeCategory::Integer>,
+ using Conversions = std::tuple<Convert<Result, TypeCategory::Integer>,
Convert<Result, TypeCategory::Real>>;
- using Operations = std::
variant<Parentheses<Result>, Negate<Result>,
+ using Operations = std::
tuple<Parentheses<Result>, Negate<Result>,
Add<Result>, Subtract<Result>, Multiply<Result>, Divide<Result>,
Power<Result>, Extremum<Result>>;
- using Others = std::variant<Constant<Result>, ArrayConstructor<Result>,
+ using Indices = std::conditional_t<KIND == ImpliedDoIndex::Result::kind,
+ std::tuple<ImpliedDoIndex>, std::tuple<>>;
+ using Others = std::tuple<Constant<Result>, ArrayConstructor<Result>,
TypeParamInquiry<KIND>, Designator<Result>, FunctionRef<Result>>;
public:
- common::CombineVariants<Operations, Conversions, Others> u;
+ common::TupleToVariant<
+ common::CombineTuples<Operations, Conversions, Indices, Others>>
+ u;
};
template<int KIND>
explicit Expr(bool x) : u{Constant<Result>{x}} {}
private:
- using Operations = std::variant<Convert<Result, TypeCategory::Logical>,
+ using Operations = std::tuple<Convert<Result, TypeCategory::Logical>,
Parentheses<Result>, Not<KIND>, LogicalOperation<KIND>>;
using Relations = std::conditional_t<KIND == LogicalResult::kind,
- std::variant<Relational<SomeType>>, std::variant<>>;
- using Others = std::variant<Constant<Result>, ArrayConstructor<Result>,
+ std::tuple<Relational<SomeType>>, std::tuple<>>;
+ using Others = std::tuple<Constant<Result>, ArrayConstructor<Result>,
Designator<Result>, FunctionRef<Result>>;
public:
- common::CombineVariants<Operations, Relations, Others> u;
+ common::TupleToVariant<common::CombineTuples<Operations, Relations, Others>>
+ u;
};
FOR_EACH_LOGICAL_KIND(extern template class Expr)
Triplet FoldOperation(FoldingContext &context, Triplet &&triplet) {
return {Fold(context, triplet.lower()), Fold(context, triplet.upper()),
- Fold(context, triplet.stride())};
+ Fold(context, Expr<SubscriptInteger>{triplet.stride()})};
}
Subscript FoldOperation(FoldingContext &context, Subscript &&subscript) {
return symbol->attrs().test(semantics::Attr::PARAMETER);
}
bool IsConstExpr(ConstExprContext &, const CoarrayRef &) { return false; }
+bool IsConstExpr(ConstExprContext &, const ImpliedDoIndex &) {
+ return true; // only tested when bounds are constant
+}
// Prototypes for mutual recursion
template<typename D, typename R, typename O1>
bool IsConstExpr(ConstExprContext &, const Operation<D, R, O1> &);
template<typename D, typename R, typename O1, typename O2>
bool IsConstExpr(ConstExprContext &, const Operation<D, R, O1, O2> &);
-template<typename V, typename O>
-bool IsConstExpr(ConstExprContext &, const ImpliedDo<V, O> &);
+template<typename V> bool IsConstExpr(ConstExprContext &, const ImpliedDo<V> &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const ArrayConstructorValue<A> &);
template<typename A>
return IsConstExpr(context, operation.left()) &&
IsConstExpr(context, operation.right());
}
-template<typename V, typename O>
-bool IsConstExpr(ConstExprContext &context, const ImpliedDo<V, O> &impliedDo) {
+template<typename V>
+bool IsConstExpr(ConstExprContext &context, const ImpliedDo<V> &impliedDo) {
if (!IsConstExpr(context, impliedDo.lower) ||
!IsConstExpr(context, impliedDo.upper) ||
!IsConstExpr(context, impliedDo.stride)) {
}
template<typename A>
bool IsConstExpr(ConstExprContext &context, const ArrayConstructor<A> &array) {
- return IsConstExpr(context, array.values) &&
- IsConstExpr(context, array.typeParameterValues);
+ return IsConstExpr(context, array.values);
}
bool IsConstExpr(ConstExprContext &context, const BaseObject &base) {
return IsConstExpr(context, base.u);
},
AsSameKindExprs(std::move(x), std::move(y)));
}
+
+template<TypeCategory TO>
+std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
+ static_assert(common::IsNumericTypeCategory(TO));
+ return std::visit(
+ [=](auto &&cx) -> std::optional<Expr<SomeType>> {
+ using cxType = std::decay_t<decltype(cx)>;
+ if constexpr (!std::is_same_v<cxType, BOZLiteralConstant>) {
+ if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
+ return std::make_optional(
+ Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))});
+ }
+ }
+ return std::nullopt;
+ },
+ std::move(x.u));
+}
+
+std::optional<Expr<SomeType>> ConvertToType(
+ const DynamicType &type, Expr<SomeType> &&x) {
+ switch (type.category) {
+ case TypeCategory::Integer:
+ return ConvertToNumeric<TypeCategory::Integer>(type.kind, std::move(x));
+ case TypeCategory::Real:
+ return ConvertToNumeric<TypeCategory::Real>(type.kind, std::move(x));
+ case TypeCategory::Complex:
+ return ConvertToNumeric<TypeCategory::Complex>(type.kind, std::move(x));
+ case TypeCategory::Character:
+ if (auto fromType{x.GetType()}) {
+ if (fromType->category == TypeCategory::Character &&
+ fromType->kind == type.kind) {
+ // TODO pmk: adjusting CHARACTER length via conversion
+ return std::move(x);
+ }
+ }
+ break;
+ case TypeCategory::Logical:
+ if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {
+ return Expr<SomeType>{
+ ConvertToKind<TypeCategory::Logical>(type.kind, std::move(*cx))};
+ }
+ break;
+ case TypeCategory::Derived:
+ if (auto fromType{x.GetType()}) {
+ if (type == fromType) {
+ return std::move(x);
+ }
+ }
+ break;
+ default: CRASH_NO_CASE;
+ }
+ return std::nullopt;
+}
+
+std::optional<Expr<SomeType>> ConvertToType(
+ const DynamicType &type, std::optional<Expr<SomeType>> &&x) {
+ if (x.has_value()) {
+ return ConvertToType(type, std::move(*x));
+ } else {
+ return std::nullopt;
+ }
+}
}
Scalar<Part> zero;
return Expr<TO>{ComplexConstructor<TO::kind>{
ConvertToType<Part>(std::move(x)), Expr<Part>{Constant<Part>{zero}}}};
+ } else if constexpr (FROMCAT == TypeCategory::Complex) {
+ // Extract and convert the real component of a complex value
+ return std::visit(
+ [&](auto &&z) {
+ using ZType = ResultType<decltype(z)>;
+ using Part = typename ZType::Part;
+ return ConvertToType<TO, TypeCategory::Real>(Expr<SomeReal>{
+ Expr<Part>{ComplexComponent<Part::kind>{false, std::move(z)}}});
+ },
+ std::move(x.u));
} else {
return Expr<TO>{Convert<TO, FROMCAT>{std::move(x)}};
}
}
}
+template<typename TO, TypeCategory FROMCAT, int FROMKIND>
+Expr<TO> ConvertToType(Expr<Type<FROMCAT, FROMKIND>> &&x) {
+ return ConvertToType<TO, FROMCAT>(Expr<SomeKind<FROMCAT>>{std::move(x)});
+}
+
template<typename TO> Expr<TO> ConvertToType(BOZLiteralConstant &&x) {
static_assert(IsSpecificIntrinsicType<TO>);
using Value = typename Constant<TO>::Value;
}
}
-template<TypeCategory TC, int TK, TypeCategory FC>
-Expr<Type<TC, TK>> ConvertTo(
- const Expr<Type<TC, TK>> &, Expr<SomeKind<FC>> &&x) {
- return ConvertToType<Type<TC, TK>>(std::move(x));
-}
+// Conversions to dynamic types
+std::optional<Expr<SomeType>> ConvertToType(
+ const DynamicType &, Expr<SomeType> &&);
+std::optional<Expr<SomeType>> ConvertToType(
+ const DynamicType &, std::optional<Expr<SomeType>> &&);
-template<TypeCategory TC, int TK, TypeCategory FC, int FK>
-Expr<Type<TC, TK>> ConvertTo(
- const Expr<Type<TC, TK>> &, Expr<Type<FC, FK>> &&x) {
- return AsExpr(ConvertToType<Type<TC, TK>>(AsCategoryExpr(std::move(x))));
+// Conversions to the type of another expression
+template<TypeCategory TC, int TK, typename FROM>
+Expr<Type<TC, TK>> ConvertTo(const Expr<Type<TC, TK>> &, FROM &&x) {
+ return ConvertToType<Type<TC, TK>>(std::move(x));
}
-template<TypeCategory TC, TypeCategory FC>
-Expr<SomeKind<TC>> ConvertTo(
- const Expr<SomeKind<TC>> &to, Expr<SomeKind<FC>> &&from) {
+template<TypeCategory TC, typename FROM>
+Expr<SomeKind<TC>> ConvertTo(const Expr<SomeKind<TC>> &to, FROM &&from) {
return std::visit(
[&](const auto &toKindExpr) {
using KindExpr = std::decay_t<decltype(toKindExpr)>;
to.u);
}
-template<TypeCategory TC, TypeCategory FC, int FK>
-Expr<SomeKind<TC>> ConvertTo(
- const Expr<SomeKind<TC>> &to, Expr<Type<FC, FK>> &&from) {
- return ConvertTo(to, AsCategoryExpr(std::move(from)));
-}
-
-template<typename FT>
-Expr<SomeType> ConvertTo(const Expr<SomeType> &to, Expr<FT> &&from) {
+template<typename FROM>
+Expr<SomeType> ConvertTo(const Expr<SomeType> &to, FROM &&from) {
return std::visit(
[&](const auto &toCatExpr) {
return AsGenericExpr(ConvertTo(toCatExpr, std::move(from)));
to.u);
}
-template<TypeCategory CAT>
-Expr<SomeKind<CAT>> ConvertTo(
- const Expr<SomeKind<CAT>> &to, BOZLiteralConstant &&from) {
- return std::visit(
- [&](const auto &tok) {
- using Ty = ResultType<decltype(tok)>;
- return AsCategoryExpr(ConvertToType<Ty>(std::move(from)));
- },
- to.u);
-}
-
// Convert an expression of some known category to a dynamically chosen
// kind of some category (usually but not necessarily distinct).
template<TypeCategory TOCAT, typename VALUE> struct ConvertToKindHelper {
using Result = std::optional<Expr<SomeKind<TOCAT>>>;
- static constexpr std::size_t Types{std::tuple_size_v<CategoryTypes<TOCAT>>};
+ using Types = CategoryTypes<TOCAT>;
ConvertToKindHelper(int k, VALUE &&x) : kind{k}, value{std::move(x)} {}
- template<std::size_t J> Result Test() {
- using Ty = std::tuple_element_t<J, CategoryTypes<TOCAT>>;
- if (kind == Ty::kind) {
+ template<typename T> Result Test() {
+ if (kind == T::kind) {
return std::make_optional(
- AsCategoryExpr(ConvertToType<Ty>(std::move(value))));
+ AsCategoryExpr(ConvertToType<T>(std::move(value))));
}
return std::nullopt;
}
template<TypeCategory TOCAT, typename VALUE>
Expr<SomeKind<TOCAT>> ConvertToKind(int kind, VALUE &&x) {
- return common::SearchDynamicTypes(
+ return common::SearchTypes(
ConvertToKindHelper<TOCAT, VALUE>{kind, std::move(x)})
.value();
}
return PromoteAndCombine<Divide, CAT>(std::move(x), std::move(y));
}
-// A utility for use with common::SearchDynamicTypes to create generic
-// expressions when an intrinsic type category for (say) a variable is known
+// A utility for use with common::SearchTypes to create generic expressions
+// when an intrinsic type category for (say) a variable is known
// but the kind parameter value is not.
template<TypeCategory CAT, template<typename> class TEMPLATE, typename VALUE>
struct TypeKindVisitor {
using Result = std::optional<Expr<SomeType>>;
- static constexpr std::size_t Types{std::tuple_size_v<CategoryTypes<CAT>>};
+ using Types = CategoryTypes<CAT>;
TypeKindVisitor(int k, VALUE &&x) : kind{k}, value{std::move(x)} {}
TypeKindVisitor(int k, const VALUE &x) : kind{k}, value{x} {}
- template<std::size_t J> Result Test() {
- using Ty = std::tuple_element_t<J, CategoryTypes<CAT>>;
- if (kind == Ty::kind) {
- return AsGenericExpr(TEMPLATE<Ty>{std::move(value)});
+ template<typename T> Result Test() {
+ if (kind == T::kind) {
+ return AsGenericExpr(TEMPLATE<T>{std::move(value)});
}
return std::nullopt;
}
}
std::string DynamicType::AsFortran() const {
- if (category == TypeCategory::Derived) {
- // TODO: derived type parameters
+ if (derived != nullptr) {
+ CHECK(category == TypeCategory::Derived);
return "TYPE("s + derived->typeSymbol().name().ToString() + ')';
} else {
- // TODO: CHARACTER length
return EnumToString(category) + '(' + std::to_string(kind) + ')';
}
}
+std::string DynamicType::AsFortran(std::string &&charLenExpr) const {
+ if (!charLenExpr.empty() && category == TypeCategory::Character) {
+ return "CHARACTER(KIND=" + std::to_string(kind) +
+ ",len=" + std::move(charLenExpr) + ')';
+ } else {
+ return AsFortran();
+ }
+}
+
DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
switch (category) {
case TypeCategory::Integer:
using common::TypeCategory;
+// Specific intrinsic types are represented by specializations of
+// this class template Type<CATEGORY, KIND>.
+template<TypeCategory CATEGORY, int KIND = 0> class Type;
+
+using SubscriptInteger = Type<TypeCategory::Integer, 8>;
+using LogicalResult = Type<TypeCategory::Logical, 1>;
+using LargestReal = Type<TypeCategory::Real, 16>;
+
// DynamicType is suitable for use as the result type for
-// GetType() functions and member functions.
+// GetType() functions and member functions. It does *not*
+// hold CHARACTER length type parameter expressions -- those
+// must be derived via LEN() member functions or packaged
+// elsewhere (e.g. as in ArrayConstructor).
struct DynamicType {
- bool operator==(const DynamicType &that) const;
+ bool operator==(const DynamicType &) const;
std::string AsFortran() const;
+ std::string AsFortran(std::string &&charLenExpr) const;
DynamicType ResultTypeForMultiply(const DynamicType &) const;
TypeCategory category;
int kind{0}; // set only for intrinsic types
- const semantics::DerivedTypeSpec *derived{nullptr};
- const semantics::Symbol *descriptor{nullptr};
+ const semantics::DerivedTypeSpec *derived{nullptr}; // TYPE(T), CLASS(T)
+ const semantics::Symbol *descriptor{nullptr}; // CHARACTER, CLASS(T/*)
};
// Result will be missing when a symbol is absent or
// has an erroneous type, e.g., REAL(KIND=666).
std::optional<DynamicType> GetSymbolType(const semantics::Symbol *);
-// Specific intrinsic types are represented by specializations of
-// this class template Type<CATEGORY, KIND>.
-template<TypeCategory CATEGORY, int KIND = 0> class Type;
-
template<TypeCategory CATEGORY, int KIND = 0> struct TypeBase {
static constexpr TypeCategory category{CATEGORY};
static constexpr int kind{KIND};
template<TypeCategory CATEGORY, typename T>
using SameKind = Type<CATEGORY, std::decay_t<T>::kind>;
-using SubscriptInteger = Type<TypeCategory::Integer, 8>;
-using LogicalResult = Type<TypeCategory::Logical, 1>;
-using LargestReal = Type<TypeCategory::Real, 16>;
-
// Many expressions, including subscripts, CHARACTER lengths, array bounds,
// and effective type parameter values, are of a maximal kind of INTEGER.
using IndirectSubscriptIntegerExpr =
// Constructors, accessors, mutators
+Triplet::Triplet() : stride_{Expr<SubscriptInteger>{1}} {}
+
Triplet::Triplet(std::optional<Expr<SubscriptInteger>> &&l,
std::optional<Expr<SubscriptInteger>> &&u,
- std::optional<Expr<SubscriptInteger>> &&s) {
+ std::optional<Expr<SubscriptInteger>> &&s)
+ : stride_{s.has_value() ? std::move(*s) : Expr<SubscriptInteger>{1}} {
if (l.has_value()) {
- lower_ = IndirectSubscriptIntegerExpr::Make(std::move(*l));
+ lower_.emplace(std::move(*l));
}
if (u.has_value()) {
- upper_ = IndirectSubscriptIntegerExpr::Make(std::move(*u));
- }
- if (s.has_value()) {
- stride_ = IndirectSubscriptIntegerExpr::Make(std::move(*s));
+ upper_.emplace(std::move(*u));
}
}
return std::nullopt;
}
-std::optional<Expr<SubscriptInteger>> Triplet::stride() const {
- if (stride_) {
- return {**stride_};
+const Expr<SubscriptInteger> &Triplet::stride() const { return *stride_; }
+
+bool Triplet::IsStrideOne() const {
+ if (auto stride{ToInt64(*stride_)}) {
+ return stride == 1;
+ } else {
+ return false;
}
- return std::nullopt;
}
CoarrayRef::CoarrayRef(std::vector<const Symbol *> &&c,
CoarrayRef &CoarrayRef::set_stat(Expr<SomeInteger> &&v) {
CHECK(IsVariable(v));
- stat_ = CopyableIndirection<Expr<SomeInteger>>::Make(std::move(v));
+ stat_.emplace(std::move(v));
return *this;
}
CoarrayRef &CoarrayRef::set_team(Expr<SomeInteger> &&v, bool isTeamNumber) {
CHECK(IsVariable(v));
- team_ = CopyableIndirection<Expr<SomeInteger>>::Make(std::move(v));
+ team_.emplace(std::move(v));
teamIsTeamNumber_ = isTeamNumber;
return *this;
}
void Substring::SetBounds(std::optional<Expr<SubscriptInteger>> &lower,
std::optional<Expr<SubscriptInteger>> &upper) {
if (lower.has_value()) {
- lower_ = IndirectSubscriptIntegerExpr::Make(std::move(*lower));
+ lower_.emplace(std::move(*lower));
}
if (upper.has_value()) {
- upper_ = IndirectSubscriptIntegerExpr::Make(std::move(*upper));
+ upper_.emplace(std::move(*upper));
}
}
std::optional<std::int64_t> length;
if (literal != nullptr) {
length = (*literal)->data().size();
- } else {
- // TODO pmk: get max character length from symbol
+ } else if (const Symbol * symbol{GetLastSymbol()}) {
+ if (const semantics::DeclTypeSpec * type{symbol->GetType()}) {
+ if (type->category() == semantics::DeclTypeSpec::Character) {
+ length = ToInt64(type->characterTypeSpec().length().GetExplicit());
+ }
+ }
}
if (*ubi < 1 || (lbi.has_value() && *ubi < *lbi)) {
// Zero-length string: canonicalize
std::ostream &Triplet::AsFortran(std::ostream &o) const {
Emit(o, lower_) << ':';
Emit(o, upper_);
- if (stride_) {
- Emit(o << ':', stride_);
- }
+ Emit(o << ':', *stride_);
return o;
}
}
bool Triplet::operator==(const Triplet &that) const {
return lower_ == that.lower_ && upper_ == that.upper_ &&
- stride_ == that.stride_;
+ *stride_ == *that.stride_;
}
bool ArrayRef::operator==(const ArrayRef &that) const {
return u == that.u && subscript == that.subscript;
// Fortran 2018 language standard (q.v.) and uses strong typing to ensure
// that only admissable combinations can be constructed.
+// TODO pmk: convert remaining structs to classes
+
#include "call.h"
#include "common.h"
#include "static-data.h"
// R921 subscript-triplet
class Triplet {
public:
- Triplet() {}
+ Triplet();
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Triplet)
Triplet(std::optional<Expr<SubscriptInteger>> &&,
std::optional<Expr<SubscriptInteger>> &&,
std::optional<Expr<SubscriptInteger>> &&);
std::optional<Expr<SubscriptInteger>> lower() const;
std::optional<Expr<SubscriptInteger>> upper() const;
- std::optional<Expr<SubscriptInteger>> stride() const;
+ const Expr<SubscriptInteger> &stride() const;
bool operator==(const Triplet &) const;
+ bool IsStrideOne() const;
std::ostream &AsFortran(std::ostream &) const;
private:
- std::optional<IndirectSubscriptIntegerExpr> lower_, upper_, stride_;
+ std::optional<IndirectSubscriptIntegerExpr> lower_, upper_;
+ IndirectSubscriptIntegerExpr stride_;
};
// R919 subscript when rank 0, R923 vector-subscript when rank 1
// here.
namespace Fortran::semantics {
class Symbol;
+class DeclTypeSpec;
}
// Expressions in the parse tree have owning pointers that can be set to
// R702 type-spec -> intrinsic-type-spec | derived-type-spec
struct TypeSpec {
UNION_CLASS_BOILERPLATE(TypeSpec);
+ mutable const semantics::DeclTypeSpec *declTypeSpec{nullptr};
std::variant<IntrinsicTypeSpec, DerivedTypeSpec> u;
};
explicit Expr(Designator &&);
explicit Expr(FunctionReference &&);
- // Filled in later during semantic analysis of the expression.
- // TODO: May be temporary; remove if caching no longer required.
+ // Filled in after successful semantic analysis of the expression.
mutable common::OwningPointer<evaluate::GenericExprWrapper> typedExpr;
+
CharBlock source;
std::variant<common::Indirection<CharLiteralConstantSubstring>,
// limitations under the License.
#include "expression.h"
-#include "dump-parse-tree.h" // TODO pmk temporary
#include "scope.h"
#include "semantics.h"
#include "symbol.h"
#include <functional>
#include <optional>
-#include <iostream> // TODO pmk rm
+// TODO pmk remove when scaffolding is obsolete
+#define PMKDEBUG 1
+#if PMKDEBUG
+#include "dump-parse-tree.h"
+#include <iostream>
+#endif
// Typedef for optional generic expressions (ubiquitous in this file)
using MaybeExpr =
ActualArguments arguments;
};
+struct DynamicTypeWithLength : public DynamicType {
+ std::optional<Expr<SubscriptInteger>> length;
+};
+
+std::optional<DynamicTypeWithLength> AnalyzeTypeSpec(
+ ExpressionAnalysisContext &context,
+ const std::optional<parser::TypeSpec> &spec) {
+ if (spec.has_value()) {
+ if (const semantics::DeclTypeSpec * typeSpec{spec->declTypeSpec}) {
+ // Name resolution sets TypeSpec::declTypeSpec only when it's valid
+ // (viz., an intrinsic type with valid known kind or a non-polymorphic
+ // & non-ABSTRACT derived type).
+ if (const semantics::IntrinsicTypeSpec *
+ intrinsic{typeSpec->AsIntrinsic()}) {
+ TypeCategory category{intrinsic->category()};
+ if (auto kind{ToInt64(intrinsic->kind())}) {
+ DynamicTypeWithLength result{category, static_cast<int>(*kind)};
+ if (category == TypeCategory::Character) {
+ const semantics::CharacterTypeSpec &cts{
+ typeSpec->characterTypeSpec()};
+ const semantics::ParamValue len{cts.length()};
+ // N.B. CHARACTER(LEN=*) is allowed in type-specs in ALLOCATE() &
+ // type guards, but not in array constructors.
+ if (len.GetExplicit().has_value()) {
+ Expr<SomeInteger> copy{*len.GetExplicit()};
+ result.length = ConvertToType<SubscriptInteger>(std::move(copy));
+ }
+ }
+ return result;
+ }
+ } else if (const semantics::DerivedTypeSpec *
+ derived{typeSpec->AsDerived()}) {
+ return DynamicTypeWithLength{TypeCategory::Derived, 0, derived};
+ }
+ }
+ }
+ return std::nullopt;
+}
+
// Forward declarations of additional AnalyzeExpr specializations and overloads
template<typename... As>
MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &, const std::variant<As...> &);
+template<typename A>
+MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &, const std::optional<A> &);
static MaybeExpr AnalyzeExpr(
ExpressionAnalysisContext &, const parser::Designator &);
static MaybeExpr AnalyzeExpr(
// Definitions of AnalyzeExpr() specializations follow.
// Helper subroutines are intermixed.
-// Variants are silently traversed by AnalyzeExpr().
+// Variants and optionals are silently traversed by AnalyzeExpr().
template<typename... As>
MaybeExpr AnalyzeExpr(
ExpressionAnalysisContext &context, const std::variant<As...> &u) {
return std::visit([&](const auto &x) { return AnalyzeExpr(context, x); }, u);
}
+template<typename A>
+MaybeExpr AnalyzeExpr(
+ ExpressionAnalysisContext &context, const std::optional<A> &x) {
+ if (x.has_value()) {
+ return AnalyzeExpr(context, *x);
+ } else {
+ return std::nullopt;
+ }
+}
// Wraps a object in an explicitly typed representation (e.g., Designator<>
// or FunctionRef<>) that has been instantiated on a dynamically chosen type.
template<TypeCategory CATEGORY, template<typename> typename WRAPPER,
typename WRAPPED>
MaybeExpr WrapperHelper(int kind, WRAPPED &&x) {
- return common::SearchDynamicTypes(
+ return common::SearchTypes(
TypeKindVisitor<CATEGORY, WRAPPER, WRAPPED>{kind, std::move(x)});
}
return std::nullopt;
}
+// Catch and resolve the ambiguous parse of a substring reference
+// that looks like a 1-D array element or section.
+static MaybeExpr ResolveAmbiguousSubstring(
+ ExpressionAnalysisContext &context, ArrayRef &&ref) {
+ const Symbol &symbol{ref.GetLastSymbol()};
+ if (std::optional<DynamicType> dyType{GetSymbolType(&symbol)}) {
+ if (dyType->category == TypeCategory::Character &&
+ ref.subscript.size() == 1) {
+ DataRef base{std::visit(
+ [](auto &&y) { return DataRef{std::move(y)}; }, std::move(ref.u))};
+ std::optional<Expr<SubscriptInteger>> lower, upper;
+ if (std::visit(
+ common::visitors{
+ [&](IndirectSubscriptIntegerExpr &&x) {
+ lower = std::move(*x);
+ return true;
+ },
+ [&](Triplet &&triplet) {
+ lower = triplet.lower();
+ upper = triplet.upper();
+ return triplet.IsStrideOne();
+ },
+ },
+ std::move(ref.subscript[0].u))) {
+ return WrapperHelper<TypeCategory::Character, Designator, Substring>(
+ dyType->kind,
+ Substring{std::move(base), std::move(lower), std::move(upper)});
+ }
+ }
+ }
+
+ return std::nullopt;
+}
+
// Some subscript semantic checks must be deferred until all of the
-// subscripts are in hand.
+// subscripts are in hand. This is also where we can catch the
+// ambiguous parse of a substring reference that looks like a 1-D array
+// element or section.
static MaybeExpr CompleteSubscripts(
ExpressionAnalysisContext &context, ArrayRef &&ref) {
const Symbol &symbol{ref.GetLastSymbol()};
}
int subscripts = ref.subscript.size();
if (subscripts != symbolRank) {
- context.Say("reference to rank-%d object '%s' has %d subscripts"_err_en_US,
+ if (MaybeExpr substring{
+ ResolveAmbiguousSubstring(context, std::move(ref))}) {
+ return substring;
+ }
+ context.Say("Reference to rank-%d object '%s' has %d subscripts"_err_en_US,
symbolRank, symbol.name().ToString().data(), subscripts);
} else if (subscripts == 0) {
// nothing to check
if (baseRank > 0) {
int rank{ref.Rank()};
if (rank > 0) {
- context.Say(
- "subscripts of rank-%d component reference have rank %d, but must all be scalar"_err_en_US,
+ context.Say("Subscripts of rank-%d component reference have rank %d, "
+ "but must all be scalar"_err_en_US,
baseRank, rank);
}
}
// C928 & C1002
if (Triplet * last{std::get_if<Triplet>(&ref.subscript.back().u)}) {
if (!last->upper().has_value() && details->IsAssumedSize()) {
- context.Say(
- "assumed-size array '%s' must have explicit final subscript upper bound value"_err_en_US,
+ context.Say("Assumed-size array '%s' must have explicit final "
+ "subscript upper bound value"_err_en_US,
symbol.name().ToString().data());
}
}
AnalyzeKindParam(context, std::get<std::optional<parser::KindParam>>(x.t),
context.GetDefaultKind(TypeCategory::Integer))};
auto value{std::get<0>(x.t)}; // std::(u)int64_t
- auto result{common::SearchDynamicTypes(
+ auto result{common::SearchTypes(
TypeKindVisitor<TypeCategory::Integer, Constant, std::int64_t>{
kind, static_cast<std::int64_t>(value)})};
if (!result.has_value()) {
struct RealTypeVisitor {
using Result = std::optional<Expr<SomeReal>>;
- static constexpr std::size_t Types{std::tuple_size_v<RealTypes>};
+ using Types = RealTypes;
RealTypeVisitor(int k, parser::CharBlock lit, FoldingContext &ctx)
: kind{k}, literal{lit}, context{ctx} {}
- template<std::size_t J> Result Test() {
- using Ty = std::tuple_element_t<J, RealTypes>;
- if (kind == Ty::kind) {
- return {AsCategoryExpr(ReadRealLiteral<Ty>(literal, context))};
+ template<typename T> Result Test() {
+ if (kind == T::kind) {
+ return {AsCategoryExpr(ReadRealLiteral<T>(literal, context))};
}
return std::nullopt;
}
context.Say(
"explicit kind parameter on real constant disagrees with exponent letter"_en_US);
}
- auto result{common::SearchDynamicTypes(
+ auto result{common::SearchTypes(
RealTypeVisitor{kind, x.real.source, context.GetFoldingContext()})};
if (!result.has_value()) {
context.Say("unsupported REAL(KIND=%d)"_err_en_US, kind);
AnalyzeKindParam(context, std::get<std::optional<parser::KindParam>>(x.t),
context.GetDefaultKind(TypeCategory::Logical))};
bool value{std::get<bool>(x.t)};
- auto result{common::SearchDynamicTypes(
+ auto result{common::SearchTypes(
TypeKindVisitor<TypeCategory::Logical, Constant, bool>{
kind, std::move(value)})};
if (!result.has_value()) {
return {AsGenericExpr(std::move(value.value))};
}
-// For use with SearchDynamicTypes to create a TypeParamInquiry with the
+// For use with SearchTypes to create a TypeParamInquiry with the
// right integer kind.
struct TypeParamInquiryVisitor {
using Result = std::optional<Expr<SomeInteger>>;
- static constexpr std::size_t Types{
- std::tuple_size_v<CategoryTypes<TypeCategory::Integer>>};
+ using Types = IntegerTypes;
TypeParamInquiryVisitor(int k, SymbolOrComponent &&b, const Symbol ¶m)
: kind{k}, base{std::move(b)}, parameter{param} {}
- template<std::size_t J> Result Test() {
- using Ty = std::tuple_element_t<J, CategoryTypes<TypeCategory::Integer>>;
- if (kind == Ty::kind) {
+ template<typename T> Result Test() {
+ if (kind == T::kind) {
return Expr<SomeInteger>{
- Expr<Ty>{TypeParamInquiry<Ty::kind>{std::move(base), parameter}}};
+ Expr<T>{TypeParamInquiry<T::kind>{std::move(base), parameter}}};
}
return std::nullopt;
}
const Symbol *symbol) {
if (std::optional<DynamicType> dyType{GetSymbolType(symbol)}) {
if (dyType->category == TypeCategory::Integer) {
- return common::SearchDynamicTypes(TypeParamInquiryVisitor{
+ return common::SearchTypes(TypeParamInquiryVisitor{
dyType->kind, SymbolOrComponent{nullptr}, *symbol});
}
}
// Names and named constants
static MaybeExpr AnalyzeExpr(
ExpressionAnalysisContext &context, const parser::Name &n) {
- if (n.symbol == nullptr) {
+ if (std::optional<int> kind{context.IsAcImpliedDo(n.source)}) {
+ return AsMaybeExpr(ConvertToKind<TypeCategory::Integer>(
+ *kind, AsExpr(ImpliedDoIndex{n.source})));
+ } else if (n.symbol == nullptr) {
context.Say(
n.source, "TODO INTERNAL: name was not resolved to a symbol"_err_en_US);
} else if (n.symbol->attrs().test(semantics::Attr::PARAMETER)) {
CHECK(dyType.has_value());
CHECK(dyType->category == TypeCategory::Integer);
return AsMaybeExpr(
- common::SearchDynamicTypes(TypeParamInquiryVisitor{dyType->kind,
+ common::SearchTypes(TypeParamInquiryVisitor{dyType->kind,
IgnoreAnySubscripts(std::move(*designator)), *sym}));
} else {
context.Say(name,
return std::nullopt;
}
-static MaybeExpr AnalyzeExpr(
- ExpressionAnalysisContext &context, const parser::ArrayConstructor &) {
- context.Say("TODO: ArrayConstructor unimplemented"_en_US);
+static int IntegerTypeSpecKind(
+ ExpressionAnalysisContext &context, const parser::IntegerTypeSpec &spec) {
+ Expr<SubscriptInteger> value{context.Analyze(TypeCategory::Integer, spec.v)};
+ if (auto kind{ToInt64(value)}) {
+ return static_cast<int>(*kind);
+ }
+ context.SayAt(spec, "Constant INTEGER kind value required here"_err_en_US);
+ return context.GetDefaultKind(TypeCategory::Integer);
+}
+
+template<int KIND, typename A>
+std::optional<Expr<Type<TypeCategory::Integer, KIND>>> GetSpecificIntExpr(
+ ExpressionAnalysisContext &context, const A &x) {
+ if (MaybeExpr y{AnalyzeExpr(context, x)}) {
+ Expr<SomeInteger> *intExpr{UnwrapExpr<Expr<SomeInteger>>(*y)};
+ CHECK(intExpr != nullptr);
+ return ConvertToType<Type<TypeCategory::Integer, KIND>>(
+ std::move(*intExpr));
+ }
+ return std::nullopt;
+}
+
+// Array constructors
+
+struct ArrayConstructorContext {
+ void Push(MaybeExpr &&);
+ void Add(const parser::AcValue &);
+ ExpressionAnalysisContext &exprContext;
+ std::optional<DynamicTypeWithLength> &type;
+ bool typesMustMatch{false};
+ ArrayConstructorValues<SomeType> values;
+};
+
+void ArrayConstructorContext::Push(MaybeExpr &&x) {
+ if (x.has_value()) {
+ DynamicTypeWithLength xType;
+ if (auto dyType{x->GetType()}) {
+ *static_cast<DynamicType *>(&xType) = *dyType;
+ }
+ if (Expr<SomeCharacter> * charExpr{UnwrapExpr<Expr<SomeCharacter>>(*x)}) {
+ CHECK(xType.category == TypeCategory::Character);
+ xType.length =
+ std::visit([](const auto &kc) { return kc.LEN(); }, charExpr->u);
+ }
+ if (!type.has_value()) {
+ // If there is no explicit type-spec in an array constructor, the type
+ // of the array is the declared type of all of the elements, which must
+ // be well-defined.
+ // TODO: Possible language extension: use the most general type of
+ // the values as the type of a numeric constructed array, convert all
+ // of the other values to that type. Alternative: let the first value
+ // determine the type, and convert the others to that type.
+ type = std::move(xType);
+ values.Push(std::move(*x));
+ } else if (typesMustMatch) {
+ if (static_cast<const DynamicType &>(*type) ==
+ static_cast<const DynamicType &>(xType)) {
+ values.Push(std::move(*x));
+ } else {
+ exprContext.Say(
+ "Values in array constructor must have the same declared type when no explicit type appears"_err_en_US);
+ }
+ } else {
+ if (auto cast{ConvertToType(*type, std::move(*x))}) {
+ values.Push(std::move(*cast));
+ } else {
+ exprContext.Say(
+ "Value in array constructor could not be converted to the type of the array"_err_en_US);
+ }
+ }
+ }
+}
+
+void ArrayConstructorContext::Add(const parser::AcValue &x) {
+ using IntType = ResultType<ImpliedDoIndex>;
+ std::visit(
+ common::visitors{
+ [&](const parser::AcValue::Triplet &triplet) {
+ // Transform l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_'
+ std::optional<Expr<IntType>> lower{
+ GetSpecificIntExpr<IntType::kind>(
+ exprContext, std::get<0>(triplet.t))};
+ std::optional<Expr<IntType>> upper{
+ GetSpecificIntExpr<IntType::kind>(
+ exprContext, std::get<1>(triplet.t))};
+ std::optional<Expr<IntType>> stride{
+ GetSpecificIntExpr<IntType::kind>(
+ exprContext, std::get<2>(triplet.t))};
+ if (lower.has_value() && upper.has_value()) {
+ if (!stride.has_value()) {
+ stride = Expr<IntType>{1};
+ }
+ if (!type.has_value()) {
+ type = DynamicTypeWithLength{IntType::GetType()};
+ }
+ ArrayConstructorContext nested{exprContext, type, typesMustMatch};
+ parser::CharBlock name;
+ nested.Push(Expr<SomeType>{
+ Expr<SomeInteger>{Expr<IntType>{ImpliedDoIndex{name}}}});
+ values.Push(ImpliedDo<SomeType>{name, std::move(*lower),
+ std::move(*upper), std::move(*stride),
+ std::move(nested.values)});
+ }
+ },
+ [&](const common::Indirection<parser::Expr> &expr) {
+ if (MaybeExpr v{exprContext.Analyze(*expr)}) {
+ Push(std::move(*v));
+ }
+ },
+ [&](const common::Indirection<parser::AcImpliedDo> &impliedDo) {
+ const auto &control{
+ std::get<parser::AcImpliedDoControl>(impliedDo->t)};
+ const auto &bounds{
+ std::get<parser::LoopBounds<parser::ScalarIntExpr>>(control.t)};
+ parser::CharBlock name{bounds.name.thing.thing.source};
+ int kind{IntType::kind};
+ if (auto &its{std::get<std::optional<parser::IntegerTypeSpec>>(
+ control.t)}) {
+ kind = IntegerTypeSpecKind(exprContext, *its);
+ }
+ bool inserted{exprContext.AddAcImpliedDo(name, kind)};
+ if (!inserted) {
+ exprContext.SayAt(name,
+ "Implied DO index is active in surrounding implied DO loop and cannot have the same name"_err_en_US);
+ }
+ std::optional<Expr<IntType>> lower{
+ GetSpecificIntExpr<IntType::kind>(exprContext, bounds.lower)};
+ std::optional<Expr<IntType>> upper{
+ GetSpecificIntExpr<IntType::kind>(exprContext, bounds.upper)};
+ std::optional<Expr<IntType>> stride{
+ GetSpecificIntExpr<IntType::kind>(exprContext, bounds.step)};
+ ArrayConstructorContext nested{exprContext, type, typesMustMatch};
+ for (const auto &value :
+ std::get<std::list<parser::AcValue>>(impliedDo->t)) {
+ nested.Add(value);
+ }
+ if (lower.has_value() && upper.has_value()) {
+ if (!stride.has_value()) {
+ stride = Expr<IntType>{1};
+ }
+ values.Push(ImpliedDo<SomeType>{name, std::move(*lower),
+ std::move(*upper), std::move(*stride),
+ std::move(nested.values)});
+ }
+ if (inserted) {
+ exprContext.RemoveAcImpliedDo(name);
+ }
+ },
+ },
+ x.u);
+}
+
+// Inverts a collection of generic ArrayConstructorValues<SomeType> that
+// all happen to have or be convertible to the same actual type T into
+// one ArrayConstructor<T>.
+template<typename T>
+ArrayConstructorValues<T> MakeSpecific(
+ ArrayConstructorValues<SomeType> &&from) {
+ ArrayConstructorValues<T> to;
+ for (ArrayConstructorValue<SomeType> &x : from.values) {
+ std::visit(
+ common::visitors{
+ [&](CopyableIndirection<Expr<SomeType>> &&expr) {
+ auto *typed{UnwrapExpr<Expr<T>>(*expr)};
+ CHECK(typed != nullptr);
+ to.Push(std::move(*typed));
+ },
+ [&](ImpliedDo<SomeType> &&impliedDo) {
+ to.Push(ImpliedDo<T>{impliedDo.controlVariableName,
+ std::move(*impliedDo.lower), std::move(*impliedDo.upper),
+ std::move(*impliedDo.stride),
+ MakeSpecific<T>(std::move(*impliedDo.values))});
+ },
+ },
+ std::move(x.u));
+ }
+ return to;
+}
+
+struct ArrayConstructorTypeVisitor {
+ using Result = MaybeExpr;
+ using Types = LengthlessIntrinsicTypes;
+ template<typename T> Result Test() {
+ if (type.category == T::category && type.kind == T::kind) {
+ if constexpr (T::category == TypeCategory::Character) {
+ CHECK(type.length.has_value());
+ return AsMaybeExpr(ArrayConstructor<T>{
+ MakeSpecific<T>(std::move(values)), std::move(*type.length)});
+ } else {
+ return AsMaybeExpr(
+ ArrayConstructor<T>{T{}, MakeSpecific<T>(std::move(values))});
+ }
+ } else {
+ return std::nullopt;
+ }
+ }
+ DynamicTypeWithLength type;
+ ArrayConstructorValues<SomeType> values;
+};
+
+static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &exprContext,
+ const parser::ArrayConstructor &array) {
+ const parser::AcSpec &acSpec{array.v};
+ std::optional<DynamicTypeWithLength> type{
+ AnalyzeTypeSpec(exprContext, acSpec.type)};
+ bool typesMustMatch{!type.has_value()};
+ ArrayConstructorContext context{exprContext, type, typesMustMatch};
+ for (const parser::AcValue &value : acSpec.values) {
+ context.Add(value);
+ }
+ if (type.has_value()) {
+ ArrayConstructorTypeVisitor visitor{
+ std::move(*type), std::move(context.values)};
+ return common::SearchTypes(std::move(visitor));
+ }
return std::nullopt;
}
common::TypeCategory category) {
return {category, GetDefaultKind(category)};
}
+
+bool ExpressionAnalysisContext::AddAcImpliedDo(
+ parser::CharBlock name, int kind) {
+ return acImpliedDos_.insert(std::make_pair(name, kind)).second;
+}
+
+void ExpressionAnalysisContext::RemoveAcImpliedDo(parser::CharBlock name) {
+ auto iter{acImpliedDos_.find(name)};
+ if (iter != acImpliedDos_.end()) {
+ acImpliedDos_.erase(iter);
+ }
+}
+
+std::optional<int> ExpressionAnalysisContext::IsAcImpliedDo(
+ parser::CharBlock name) const {
+ auto iter{acImpliedDos_.find(name)};
+ if (iter != acImpliedDos_.cend()) {
+ return {iter->second};
+ } else {
+ return std::nullopt;
+ }
+}
}
namespace Fortran::semantics {
bool Pre(const parser::Expr &expr) {
if (expr.typedExpr.get() == nullptr) {
if (MaybeExpr checked{AnalyzeExpr(context_, expr)}) {
- // checked->AsFortran(std::cout << "pmk: checked expression: ") << '\n';
+#if PMKDEBUG
+// checked->AsFortran(std::cout << "checked expression: ") << '\n';
+#endif
expr.typedExpr.reset(
new evaluate::GenericExprWrapper{std::move(*checked)});
} else {
+#if PMKDEBUG
std::cout << "TODO: expression analysis failed for this expression: ";
DumpTree(std::cout, expr);
+#endif
}
}
return false;
#include "../evaluate/expression.h"
#include "../evaluate/tools.h"
#include "../evaluate/type.h"
+#include "../parser/char-block.h"
#include "../parser/parse-tree-visitor.h"
#include "../parser/parse-tree.h"
+#include <map>
#include <optional>
#include <variant>
int GetDefaultKind(common::TypeCategory);
DynamicType GetDefaultKindOfType(common::TypeCategory);
+ // Manage a set of active array constructor implied DO loops.
+ bool AddAcImpliedDo(parser::CharBlock, int);
+ void RemoveAcImpliedDo(parser::CharBlock);
+ std::optional<int> IsAcImpliedDo(parser::CharBlock) const;
+
private:
semantics::SemanticsContext &context_;
+ std::map<parser::CharBlock, int> acImpliedDos_; // values are INTEGER kinds
};
template<typename PARSED>
void Post(const parser::DeclarationTypeSpec::TypeStar &);
bool Pre(const parser::TypeGuardStmt &);
void Post(const parser::TypeGuardStmt &);
- bool Pre(const parser::AcSpec &);
+ void Post(const parser::TypeSpec &);
protected:
struct State {
protected:
bool BeginDecl();
void EndDecl();
- // Declare a construct or statement entity. If there isn't a type specified
+ // Declare a construct entity. If there isn't a type specified
// it comes from the entity in the containing scope, or implicit rules.
// Return pointer to the new symbol, or nullptr on error.
Symbol *DeclareConstructEntity(const parser::Name &);
+ // Declare a statement entity (e.g., an implied DO loop index).
+ // If there isn't a type specified, implicit rules apply.
+ // Return pointer to the new symbol, or nullptr on error.
+ Symbol *DeclareStatementEntity(const parser::Name &);
bool CheckUseError(const parser::Name &);
void CheckAccessibility(const parser::Name &, bool, const Symbol &);
bool Pre(const parser::LocalitySpec::Local &);
bool Pre(const parser::LocalitySpec::LocalInit &);
bool Pre(const parser::LocalitySpec::Shared &);
+ bool Pre(const parser::AcSpec &);
+ bool Pre(const parser::AcImpliedDo &);
bool Pre(const parser::DataImpliedDo &);
- bool Pre(const parser::DataStmt &);
- void Post(const parser::DataStmt &);
+ bool Pre(const parser::DataStmtSet &);
+ void Post(const parser::DataStmtSet &);
bool Pre(const parser::DoConstruct &);
void Post(const parser::DoConstruct &);
void Post(const parser::ConcurrentControl &);
}
bool CheckDef(const std::optional<parser::Name> &);
void CheckRef(const std::optional<parser::Name> &);
- void CheckIntegerType(const Symbol &);
+ void CheckScalarIntegerType(const Symbol &);
const DeclTypeSpec &ToDeclTypeSpec(evaluate::DynamicType &&);
const DeclTypeSpec &ToDeclTypeSpec(
evaluate::DynamicType &&, SubscriptIntExpr &&length);
EndDeclTypeSpec();
}
-bool DeclTypeSpecVisitor::Pre(const parser::AcSpec &x) {
- // AcSpec can occur within a TypeDeclarationStmt: save and restore state
- auto savedState{SetDeclTypeSpecState({})};
- BeginDeclTypeSpec();
- Walk(x.type);
- Walk(x.values);
- EndDeclTypeSpec();
- SetDeclTypeSpecState(savedState);
- return false;
+void DeclTypeSpecVisitor::Post(const parser::TypeSpec &typeSpec) {
+ // Record the resolved DeclTypeSpec in the parse tree for use by
+ // expression semantics if the DeclTypeSpec is a valid TypeSpec.
+ // The grammar ensures that it's an intrinsic or derived type spec,
+ // not TYPE(*) or CLASS(*) or CLASS(T).
+ if (const DeclTypeSpec * spec{state_.declTypeSpec}) {
+ switch (spec->category()) {
+ case DeclTypeSpec::Numeric:
+ case DeclTypeSpec::Logical:
+ case DeclTypeSpec::Character: typeSpec.declTypeSpec = spec; break;
+ case DeclTypeSpec::TypeDerived:
+ if (const DerivedTypeSpec * derived{spec->AsDerived()}) {
+ if (derived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
+ Say("ABSTRACT derived type may not be used here"_err_en_US);
+ }
+ typeSpec.declTypeSpec = spec;
+ }
+ break;
+ default: CRASH_NO_CASE;
+ }
+ }
}
void DeclTypeSpecVisitor::Post(
return &symbol;
}
+Symbol *DeclarationVisitor::DeclareStatementEntity(const parser::Name &name) {
+ if (auto *prev{FindSymbol(name)}) {
+ if (prev->owner() == currScope()) {
+ SayAlreadyDeclared(name, *prev);
+ return nullptr;
+ }
+ name.symbol = nullptr;
+ }
+ Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, {})};
+ if (symbol.has<ObjectEntityDetails>()) {
+ if (auto *type{GetDeclTypeSpec()}) {
+ SetType(name, *type);
+ } else {
+ ApplyImplicitRules(symbol);
+ }
+ return Resolve(name, &symbol);
+ }
+ return nullptr;
+}
+
// Set the type of an entity or report an error.
void DeclarationVisitor::SetType(
const parser::Name &name, const DeclTypeSpec &type) {
return false;
}
+bool ConstructVisitor::Pre(const parser::AcSpec &x) {
+ // AcSpec can occur within a TypeDeclarationStmt: save and restore state
+ auto savedState{SetDeclTypeSpecState({})};
+ BeginDeclTypeSpec();
+ Walk(x.type);
+ EndDeclTypeSpec();
+ SetDeclTypeSpecState(savedState);
+ PushScope(Scope::Kind::ImpliedDos, nullptr);
+ Walk(x.values);
+ PopScope();
+ return false;
+}
+
+bool ConstructVisitor::Pre(const parser::AcImpliedDo &x) {
+ auto &values{std::get<std::list<parser::AcValue>>(x.t)};
+ auto &control{std::get<parser::AcImpliedDoControl>(x.t)};
+ auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(control.t)};
+ auto &bounds{std::get<parser::LoopBounds<parser::ScalarIntExpr>>(control.t)};
+ if (type) {
+ BeginDeclTypeSpec();
+ DeclarationVisitor::Post(*type);
+ }
+ if (auto *symbol{DeclareStatementEntity(bounds.name.thing.thing)}) {
+ CheckScalarIntegerType(*symbol);
+ }
+ if (type) {
+ EndDeclTypeSpec();
+ }
+ Walk(bounds);
+ Walk(values);
+ return false;
+}
+
bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) {
auto &objects{std::get<std::list<parser::DataIDoObject>>(x.t)};
auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(x.t)};
BeginDeclTypeSpec();
DeclarationVisitor::Post(*type);
}
- if (auto *symbol{DeclareConstructEntity(bounds.name.thing.thing)}) {
- CheckIntegerType(*symbol);
+ if (auto *symbol{DeclareStatementEntity(bounds.name.thing.thing)}) {
+ CheckScalarIntegerType(*symbol);
}
if (type) {
EndDeclTypeSpec();
return false;
}
-bool ConstructVisitor::Pre(const parser::DataStmt &) {
- PushScope(Scope::Kind::Block, nullptr);
+bool ConstructVisitor::Pre(const parser::DataStmtSet &) {
+ PushScope(Scope::Kind::ImpliedDos, nullptr);
return true;
}
-void ConstructVisitor::Post(const parser::DataStmt &) { PopScope(); }
+void ConstructVisitor::Post(const parser::DataStmtSet &) { PopScope(); }
bool ConstructVisitor::Pre(const parser::DoConstruct &x) {
if (x.IsDoConcurrent()) {
void ConstructVisitor::Post(const parser::ConcurrentControl &x) {
auto &name{std::get<parser::Name>(x.t)};
if (auto *symbol{DeclareConstructEntity(name)}) {
- CheckIntegerType(*symbol);
+ CheckScalarIntegerType(*symbol);
}
}
}
}
-void ConstructVisitor::CheckIntegerType(const Symbol &symbol) {
+void ConstructVisitor::CheckScalarIntegerType(const Symbol &symbol) {
+ if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (details->IsArray()) {
+ Say(symbol.name(), "Variable '%s' is not scalar"_err_en_US);
+ return;
+ }
+ }
if (auto *type{symbol.GetType()}) {
if (!type->IsNumeric(TypeCategory::Integer)) {
- Say(symbol.name(), "Variable '%s' is not scalar integer"_err_en_US);
+ Say(symbol.name(), "Variable '%s' is not integer"_err_en_US);
+ return;
}
}
}
public:
ENUM_CLASS(Kind, System, Global, Module, MainProgram, Subprogram, DerivedType,
- Block, Forall)
+ Block, Forall, ImpliedDos)
using ImportKind = common::ImportKind;
// Create the Global scope -- the root of the scope tree
if (AnyFatalError()) {
return false;
}
- if (AnyFatalError()) {
- return false;
- }
CheckDoConcurrentConstraints(context_.messages(), program_);
if (AnyFatalError()) {
return false;
if (AnyFatalError()) {
return false;
}
- if (context_.debugExpressions()) {
- AnalyzeExpressions(program_, context_);
- AnalyzeAssignments(program_, context_);
- }
+ AnalyzeExpressions(program_, context_);
+ AnalyzeAssignments(program_, context_);
return !AnyFatalError();
}
}
const std::string &moduleDirectory() const { return moduleDirectory_; }
const bool warningsAreErrors() const { return warningsAreErrors_; }
- const bool debugExpressions() const { return debugExpressions_; }
const evaluate::IntrinsicProcTable &intrinsics() const { return intrinsics_; }
Scope &globalScope() { return globalScope_; }
parser::Messages &messages() { return messages_; }
warningsAreErrors_ = x;
return *this;
}
- SemanticsContext &set_debugExpressions(bool x) {
- debugExpressions_ = x;
- return *this;
- }
const DeclTypeSpec &MakeNumericType(TypeCategory, int kind = 0);
const DeclTypeSpec &MakeLogicalType(int kind = 0);
std::vector<std::string> searchDirectories_;
std::string moduleDirectory_{"."s};
bool warningsAreErrors_{false};
- bool debugExpressions_{false};
const evaluate::IntrinsicProcTable intrinsics_;
Scope globalScope_;
parser::Messages messages_;
CHECK(category_ == Logical);
return std::get<LogicalTypeSpec>(typeSpec_);
}
-const CharacterTypeSpec &DeclTypeSpec::characterTypeSpec() const {
- CHECK(category_ == Character);
- return std::get<CharacterTypeSpec>(typeSpec_);
-}
const DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() const {
CHECK(category_ == TypeDerived || category_ == ClassDerived);
return std::get<DerivedTypeSpec>(typeSpec_);
CharacterTypeSpec(ParamValue &&length, KindExpr &&kind)
: IntrinsicTypeSpec(TypeCategory::Character, std::move(kind)),
length_{std::move(length)} {}
- const ParamValue length() const { return length_; }
+ const ParamValue &length() const { return length_; }
private:
ParamValue length_;
bool IsNumeric(TypeCategory) const;
const NumericTypeSpec &numericTypeSpec() const;
const LogicalTypeSpec &logicalTypeSpec() const;
- const CharacterTypeSpec &characterTypeSpec() const;
+ const CharacterTypeSpec &characterTypeSpec() const {
+ CHECK(category_ == Character);
+ return std::get<CharacterTypeSpec>(typeSpec_);
+ }
const DerivedTypeSpec &derivedTypeSpec() const;
DerivedTypeSpec &derivedTypeSpec();
y = 1
end block
end
-
-subroutine s3
- integer j
- block
- import, only: j
- type t
- !ERROR: 'i' from host scoping unit is not accessible due to IMPORT
- real :: x(10) = [(i, &
- !ERROR: 'i' from host scoping unit is not accessible due to IMPORT
- i=1,10)]
- end type
- end block
-end subroutine
subroutine s4
real :: a(10), b(10)
complex :: x
- !ERROR: Variable 'x' is not scalar integer
+ integer :: i(2)
+ !ERROR: Variable 'x' is not integer
forall(x=1:10)
a(x) = b(x)
end forall
- !ERROR: Variable 'y' is not scalar integer
+ !ERROR: Variable 'y' is not integer
forall(y=1:10)
a(y) = b(y)
end forall
+ !ERROR: Variable 'i' is not scalar
+ forall(i=1:10)
+ a(i) = b(i)
+ end forall
end
subroutine s5
real, dimension(n) :: x
data(x(i), i=1, n) / n * 0.0 /
!ERROR: Index name 't' conflicts with existing identifier
- data(x(t), t=1, n) / n * 0.0 /
+ forall(t=1:n) x(t) = 0.0
contains
subroutine t
end
bool dumpUnparseWithSymbols{false};
bool dumpParseTree{false};
bool dumpSymbols{false};
- bool debugExpressions{false};
bool debugResolveNames{false};
bool debugSemantics{false};
bool measureTree{false};
}
// TODO: Change this predicate to just "if (!driver.debugNoSemantics)"
if (driver.debugSemantics || driver.debugResolveNames || driver.dumpSymbols ||
- driver.dumpUnparseWithSymbols || driver.debugExpressions) {
+ driver.dumpUnparseWithSymbols) {
Fortran::semantics::Semantics semantics{
semanticsContext, parseTree, parsing.cooked()};
semantics.Perform();
driver.dumpParseTree = true;
} else if (arg == "-fdebug-dump-symbols") {
driver.dumpSymbols = true;
- } else if (arg == "-fdebug-expressions") {
- driver.debugExpressions = true;
} else if (arg == "-fdebug-resolve-names") {
driver.debugResolveNames = true;
} else if (arg == "-fdebug-measure-parse-tree") {
Fortran::semantics::SemanticsContext semanticsContext{defaultKinds};
semanticsContext.set_moduleDirectory(driver.moduleDirectory)
.set_searchDirectories(driver.searchDirectories)
- .set_warningsAreErrors(driver.warningsAreErrors)
- .set_debugExpressions(driver.debugExpressions);
+ .set_warningsAreErrors(driver.warningsAreErrors);
if (!anyFiles) {
driver.measureTree = true;
projects / platform / upstream / llvm.git / commitdiff