-// Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+// Copyright (c) 2018-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.
// Intrinsics are identified by their names and the characteristics
// of their arguments, at least for now.
-using IntrinsicProcedure = const char *; // not an owning pointer
+using IntrinsicProcedure = std::string;
struct SpecificIntrinsic {
explicit SpecificIntrinsic(IntrinsicProcedure n) : name{n} {}
SpecificIntrinsic(IntrinsicProcedure n, std::optional<DynamicType> &&dt,
int r, semantics::Attrs a)
: name{n}, type{std::move(dt)}, rank{r}, attrs{a} {}
+ SpecificIntrinsic(const SpecificIntrinsic &) = default;
+ SpecificIntrinsic(SpecificIntrinsic &&) = default;
+ SpecificIntrinsic &operator=(const SpecificIntrinsic &) = default;
+ SpecificIntrinsic &operator=(SpecificIntrinsic &&) = default;
bool operator==(const SpecificIntrinsic &) const;
std::ostream &AsFortran(std::ostream &) const;
DataRef FoldOperation(FoldingContext &, DataRef &&);
Substring FoldOperation(FoldingContext &, Substring &&);
ComplexPart FoldOperation(FoldingContext &, ComplexPart &&);
-
+template<typename T> Expr<T> FoldOperation(FoldingContext &, FunctionRef<T> &&);
template<typename T> Expr<T> FoldOperation(FoldingContext &, Designator<T> &&);
template<int KIND>
Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(
}
template<typename T>
+Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
+ ActualArguments args{std::move(funcRef.arguments())};
+ for (std::optional<ActualArgument> &arg : args) {
+ if (arg.has_value()) {
+ *arg->value = FoldOperation(context, std::move(*arg->value));
+ }
+ }
+ if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
+ std::string name{intrinsic->name};
+ if (name == "kind") {
+ if constexpr (common::HasMember<T, IntegerTypes>) {
+ return Expr<T>{args[0]->value->GetType()->kind};
+ } else {
+ common::die("kind() result not integral");
+ }
+ } else if (name == "len") {
+ if constexpr (std::is_same_v<T, SubscriptInteger>) {
+ if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(*args[0]->value)}) {
+ return std::visit([](auto &kx) { return kx.LEN(); }, charExpr->u);
+ }
+ } else {
+ common::die("len() result not SubscriptInteger");
+ }
+ } else {
+ // TODO: many more intrinsic functions
+ }
+ }
+ return Expr<T>{FunctionRef<T>{std::move(funcRef.proc()), std::move(args)}};
+}
+
+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)}) {
const semantics::Scope *scope{context.pdtInstance->scope()};
CHECK(scope != nullptr);
auto iter{scope->find(inquiry.parameter->name())};
- CHECK(iter != scope->end());
- const Symbol &symbol{*iter->second};
- const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
- CHECK(details != nullptr);
- CHECK(details->init().has_value());
- Expr<SomeInteger> expr{*details->init()};
- return Fold(context,
- Expr<IntKIND>{
- Convert<IntKIND, TypeCategory::Integer>(std::move(expr))});
+ if (iter != scope->end()) {
+ const Symbol &symbol{*iter->second};
+ const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
+ CHECK(details != nullptr);
+ CHECK(details->init().has_value());
+ Expr<SomeInteger> expr{*details->init()};
+ return Fold(context,
+ Expr<IntKIND>{
+ Convert<IntKIND, TypeCategory::Integer>(std::move(expr))});
+ } else {
+ // Parameter of a parent derived type; these are saved in the spec.
+ const auto *value{
+ context.pdtInstance->FindParameter(inquiry.parameter->name())};
+ CHECK(value != nullptr);
+ CHECK(value->isExplicit());
+ return Fold(context,
+ Expr<IntKIND>{Convert<IntKIND, TypeCategory::Integer>(
+ value->GetExplicit().value())});
+ }
}
return Expr<IntKIND>{std::move(inquiry)};
}
-// TODO: Fold/rewrite intrinsic function references
-
// Unary operations
template<typename TO, TypeCategory FROMCAT>
// the expression may reference derived type kind parameters whose values
// are not yet known.
//
-// The implementation uses an overloaded helper function and template.
+// The implementation uses mutually recursive helper function overloadings and
+// templates.
struct ConstExprContext {
std::set<parser::CharBlock> constantNames;
};
+// Base cases
bool IsConstExpr(ConstExprContext &, const BOZLiteralConstant &) {
return true;
}
template<typename A> bool IsConstExpr(ConstExprContext &, const Constant<A> &) {
return true;
}
+bool IsConstExpr(ConstExprContext &, const StaticDataObject::Pointer) {
+ return true;
+}
template<int KIND>
bool IsConstExpr(ConstExprContext &, const TypeParamInquiry<KIND> &inquiry) {
return inquiry.parameter->template get<semantics::TypeParamDetails>()
.attr() == common::TypeParamAttr::Kind;
}
+bool IsConstExpr(ConstExprContext &, const Symbol *symbol) {
+ return symbol->attrs().test(semantics::Attr::PARAMETER);
+}
+bool IsConstExpr(ConstExprContext &, const CoarrayRef &) { return false; }
+// 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 ArrayConstructorValues<A> &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const ArrayConstructor<A> &);
+bool IsConstExpr(ConstExprContext &, const BaseObject &);
+bool IsConstExpr(ConstExprContext &, const Component &);
+bool IsConstExpr(ConstExprContext &, const Triplet &);
+bool IsConstExpr(ConstExprContext &, const Subscript &);
+bool IsConstExpr(ConstExprContext &, const ArrayRef &);
+bool IsConstExpr(ConstExprContext &, const DataRef &);
+bool IsConstExpr(ConstExprContext &, const Substring &);
+bool IsConstExpr(ConstExprContext &, const ComplexPart &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const Designator<A> &);
+bool IsConstExpr(ConstExprContext &, const ActualArgument &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const FunctionRef<A> &);
template<typename A> bool IsConstExpr(ConstExprContext &, const Expr<A> &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const CopyableIndirection<A> &);
template<typename A>
+bool IsConstExpr(ConstExprContext &, const std::optional<A> &);
+template<typename A>
bool IsConstExpr(ConstExprContext &, const std::vector<A> &);
template<typename... As>
bool IsConstExpr(ConstExprContext &, const std::variant<As...> &);
return IsConstExpr(context, array.values) &&
IsConstExpr(context, array.typeParameterValues);
}
+bool IsConstExpr(ConstExprContext &context, const BaseObject &base) {
+ return IsConstExpr(context, base.u);
+}
+bool IsConstExpr(ConstExprContext &context, const Component &component) {
+ return IsConstExpr(context, component.base());
+}
+bool IsConstExpr(ConstExprContext &context, const Triplet &triplet) {
+ return IsConstExpr(context, triplet.lower()) &&
+ IsConstExpr(context, triplet.upper()) &&
+ IsConstExpr(context, triplet.stride());
+}
+bool IsConstExpr(ConstExprContext &context, const Subscript &subscript) {
+ return IsConstExpr(context, subscript.u);
+}
+bool IsConstExpr(ConstExprContext &context, const ArrayRef &arrayRef) {
+ return IsConstExpr(context, arrayRef.u) &&
+ IsConstExpr(context, arrayRef.subscript);
+}
+bool IsConstExpr(ConstExprContext &context, const DataRef &dataRef) {
+ return IsConstExpr(context, dataRef.u);
+}
+bool IsConstExpr(ConstExprContext &context, const Substring &substring) {
+ if (const auto *dataRef{substring.GetParentIf<DataRef>()}) {
+ if (!IsConstExpr(context, *dataRef)) {
+ return false;
+ }
+ }
+ return IsConstExpr(context, substring.lower()) &&
+ IsConstExpr(context, substring.upper());
+}
+bool IsConstExpr(ConstExprContext &context, const ComplexPart &complexPart) {
+ return IsConstExpr(context, complexPart.complex());
+}
template<typename A>
bool IsConstExpr(ConstExprContext &context, const Designator<A> &designator) {
- // TODO: true for PARAMETER and for kind type parameters
- return false;
+ return IsConstExpr(context, designator.u);
+}
+bool IsConstExpr(ConstExprContext &context, const ActualArgument &arg) {
+ return IsConstExpr(context, *arg.value);
}
template<typename A>
bool IsConstExpr(ConstExprContext &context, const FunctionRef<A> &funcRef) {
- // TODO: calls to intrinsics with constant arguments
+ if (const auto *intrinsic{
+ std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
+ if (intrinsic->name == "kind") {
+ return true;
+ }
+ // TODO: This is a placeholder with obvious false positives
+ return IsConstExpr(context, funcRef.arguments());
+ }
return false;
}
template<typename A>
return IsConstExpr(context, *x);
}
template<typename A>
+bool IsConstExpr(ConstExprContext &context, const std::optional<A> &maybe) {
+ return !maybe.has_value() || IsConstExpr(context, *maybe);
+}
+template<typename A>
bool IsConstExpr(ConstExprContext &context, const std::vector<A> &v) {
for (const auto &x : v) {
if (!IsConstExpr(context, x)) {
bool IsConstantExpr(const Expr<SomeType> &);
// When an expression is a constant integer, ToInt64() extracts its value.
-// Ensure that the expression has been folded beforehand if folding might
+// Ensure that the expression has been folded beforehand when folding might
// be required.
template<int KIND>
std::optional<std::int64_t> ToInt64(
static constexpr TypePattern AnyChar{CharType, KindCode::any};
static constexpr TypePattern AnyLogical{LogicalType, KindCode::any};
static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any};
+static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any};
static constexpr TypePattern Anything{AnyType, KindCode::any};
// Match some kind of some intrinsic type(s); all "Same" values must match,
SameInt},
{"is_iostat_end", {{"i", AnyInt}}, DefaultLogical},
{"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical},
+ {"kind", {{"x", AnyIntrinsic}}, DefaultInt},
{"lbound",
{{"array", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
KINDInt, Rank::vector},
// limitations under the License.
#include "type.h"
+#include "fold.h"
#include "../common/idioms.h"
#include "../semantics/symbol.h"
#include "../semantics/type.h"
if (symbol != nullptr) {
if (const auto *type{symbol->GetType()}) {
if (const auto *intrinsic{type->AsIntrinsic()}) {
- TypeCategory category{intrinsic->category()};
- int kind{intrinsic->kind()};
- if (IsValidKindOfIntrinsicType(category, kind)) {
- DynamicType dyType{category, kind};
- if (symbol->IsDescriptor()) {
- dyType.descriptor = symbol;
+ if (auto kind{ToInt64(intrinsic->kind())}) {
+ TypeCategory category{intrinsic->category()};
+ if (IsValidKindOfIntrinsicType(category, *kind)) {
+ DynamicType dyType{category, static_cast<int>(*kind)};
+ if (symbol->IsDescriptor()) {
+ dyType.descriptor = symbol;
+ }
+ return std::make_optional(std::move(dyType));
}
- return std::make_optional(std::move(dyType));
}
} else if (const auto *derived{type->AsDerived()}) {
DynamicType dyType{TypeCategory::Derived, 0, derived};
-// Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+// Copyright (c) 2018-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.
return o << symbol.name().ToString();
}
-std::ostream &Emit(std::ostream &o, const IntrinsicProcedure &p) {
- return o << p;
-}
-
std::ostream &Emit(std::ostream &o, const std::string &lit) {
return o << parser::QuoteCharacterLiteral(lit);
}
-// Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+// Copyright (c) 2018-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.
// x%KIND for intrinsic types is similarly rewritten in semantics to
// KIND(x), which is then folded to a constant value.
// "Bare" type parameter references within a derived type definition do
-// not have base objects here.
+// not have base objects here, only symbols.
template<int KIND> struct TypeParamInquiry {
using Result = Type<TypeCategory::Integer, KIND>;
CLASS_BOILERPLATE(TypeParamInquiry)
static constexpr int Rank() { return 0; } // always scalar
bool operator==(const TypeParamInquiry &) const;
std::ostream &AsFortran(std::ostream &) const;
+
SymbolOrComponent u{nullptr};
const Symbol *parameter;
};
ProcedureRef(ProcedureDesignator &&p, ActualArguments &&a)
: proc_{std::move(p)}, arguments_(std::move(a)) {}
+ ProcedureDesignator &proc() { return proc_; }
const ProcedureDesignator &proc() const { return proc_; }
+ ActualArguments &arguments() { return arguments_; }
const ActualArguments &arguments() const { return arguments_; }
Expr<SubscriptInteger> LEN() const;
// Walk a class with a single field 'thing'.
template<typename T, typename V> void Walk(const Scalar<T> &x, V &visitor) {
- Walk(x.thing, visitor);
+ if (visitor.Pre(x)) {
+ Walk(x.thing, visitor);
+ visitor.Post(x);
+ }
}
template<typename T, typename M> void Walk(Scalar<T> &x, M &mutator) {
- Walk(x.thing, mutator);
+ if (mutator.Pre(x)) {
+ Walk(x.thing, mutator);
+ mutator.Post(x);
+ }
}
template<typename T, typename V> void Walk(const Constant<T> &x, V &visitor) {
- Walk(x.thing, visitor);
+ if (visitor.Pre(x)) {
+ Walk(x.thing, visitor);
+ visitor.Post(x);
+ }
}
template<typename T, typename M> void Walk(Constant<T> &x, M &mutator) {
- Walk(x.thing, mutator);
+ if (mutator.Pre(x)) {
+ Walk(x.thing, mutator);
+ mutator.Post(x);
+ }
}
template<typename T, typename V> void Walk(const Integer<T> &x, V &visitor) {
- Walk(x.thing, visitor);
+ if (visitor.Pre(x)) {
+ Walk(x.thing, visitor);
+ visitor.Post(x);
+ }
}
template<typename T, typename M> void Walk(Integer<T> &x, M &mutator) {
- Walk(x.thing, mutator);
+ if (mutator.Pre(x)) {
+ Walk(x.thing, mutator);
+ mutator.Post(x);
+ }
}
template<typename T, typename V> void Walk(const Logical<T> &x, V &visitor) {
- Walk(x.thing, visitor);
+ if (visitor.Pre(x)) {
+ Walk(x.thing, visitor);
+ visitor.Post(x);
+ }
}
template<typename T, typename M> void Walk(Logical<T> &x, M &mutator) {
- Walk(x.thing, mutator);
+ if (mutator.Pre(x)) {
+ Walk(x.thing, mutator);
+ mutator.Post(x);
+ }
}
template<typename T, typename V>
void Walk(const DefaultChar<T> &x, V &visitor) {
- Walk(x.thing, visitor);
+ if (visitor.Pre(x)) {
+ Walk(x.thing, visitor);
+ visitor.Post(x);
+ }
}
template<typename T, typename M> void Walk(DefaultChar<T> &x, M &mutator) {
- Walk(x.thing, mutator);
+ if (mutator.Pre(x)) {
+ Walk(x.thing, mutator);
+ mutator.Post(x);
+ }
}
template<typename T, typename V> void Walk(const Statement<T> &x, V &visitor) {
-// Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+// Copyright (c) 2018-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.
#include "symbol.h"
#include "../common/idioms.h"
#include "../evaluate/expression.h"
+#include "../evaluate/fold.h"
+#include "../evaluate/tools.h"
+#include "../parser/message.h"
#include "../parser/parse-tree-visitor.h"
#include "../parser/parse-tree.h"
+#include <optional>
+#include <set>
using namespace Fortran::parser::literals;
namespace Fortran::semantics {
-template<typename A>
-void AnalyzeExecutableStmt(SemanticsContext &, const parser::Statement<A> &) {}
-template<>
-void AnalyzeExecutableStmt(SemanticsContext &context,
- const parser::Statement<parser::AssignmentStmt> &stmt) {}
-template<>
-void AnalyzeExecutableStmt(SemanticsContext &context,
- const parser::Statement<parser::PointerAssignmentStmt> &stmt) {}
-template<>
-void AnalyzeExecutableStmt(SemanticsContext &context,
- const parser::Statement<parser::WhereStmt> &stmt) {}
-template<>
-void AnalyzeExecutableStmt(SemanticsContext &context,
- const parser::Statement<parser::ForallStmt> &stmt) {}
-
-void AnalyzeAssignment(SemanticsContext &context,
- const parser::Statement<parser::AssignmentStmt> &stmt) {
- AnalyzeExecutableStmt(context, stmt);
+using ControlExpr = evaluate::Expr<evaluate::SubscriptInteger>;
+using MaskExpr = evaluate::Expr<evaluate::LogicalResult>;
+
+// The context tracks some number of active FORALL statements/constructs
+// and some number of active WHERE statements/constructs. WHERE can nest
+// in FORALL but not vice versa. Pointer assignments are allowed in
+// FORALL but not in WHERE. These constraints are manifest in the grammar
+// and don't need to be rechecked here, since they cannot appear in the
+// parse tree.
+struct Control {
+ Symbol *name;
+ ControlExpr lower, upper, step;
+};
+
+struct ForallContext {
+ explicit ForallContext(const ForallContext *that) : outer{that} {}
+
+ // TODO pmk: Is this needed? Does semantics already track these kinds?
+ std::optional<int> GetActiveIntKind(const parser::CharBlock &name) const {
+ const auto iter{activeNames.find(name)};
+ if (iter != activeNames.cend()) {
+ return {integerKind};
+ } else if (outer != nullptr) {
+ return outer->GetActiveIntKind(name);
+ } else {
+ return std::nullopt;
+ }
+ }
+
+ const ForallContext *outer{nullptr};
+ std::optional<parser::CharBlock> constructName;
+ int integerKind;
+ std::vector<Control> control;
+ std::optional<MaskExpr> maskExpr;
+ std::set<parser::CharBlock> activeNames;
+};
+
+struct WhereContext {
+ explicit WhereContext(MaskExpr &&x) : thisMaskExpr{std::move(x)} {}
+
+ const WhereContext *outer{nullptr};
+ const ForallContext *forall{nullptr}; // innermost FORALL
+ std::optional<parser::CharBlock> constructName;
+ MaskExpr thisMaskExpr; // independent of outer WHERE, if any
+ MaskExpr cumulativeMaskExpr{thisMaskExpr};
+};
+
+class AssignmentContext {
+public:
+ explicit AssignmentContext(
+ SemanticsContext &c, parser::CharBlock at = parser::CharBlock{})
+ : context_{c}, messages_{at, &c.messages()} {}
+ AssignmentContext(const AssignmentContext &that, parser::CharBlock at)
+ : context_{that.context_}, messages_{at, that.messages_.messages()},
+ where_{that.where_}, forall_{that.forall_} {}
+ AssignmentContext(const AssignmentContext &c, WhereContext &w)
+ : context_{c.context_}, messages_{c.messages_}, where_{&w} {}
+ AssignmentContext(const AssignmentContext &c, ForallContext &f)
+ : context_{c.context_}, messages_{c.messages_}, forall_{&f} {}
+
+ void Analyze(const parser::AssignmentStmt &);
+ void Analyze(const parser::PointerAssignmentStmt &);
+ void Analyze(const parser::WhereStmt &);
+ void Analyze(const parser::WhereConstruct &);
+ void Analyze(const parser::ForallStmt &);
+ void Analyze(const parser::ForallConstruct &);
+ void Analyze(const parser::ConcurrentHeader &);
+
+ template<typename A> void Analyze(const parser::Statement<A> &stmt) {
+ AssignmentContext nested{*this, stmt.source};
+ nested.Analyze(stmt.statement);
+ }
+ template<typename A> void Analyze(const common::Indirection<A> &x) {
+ Analyze(*x);
+ }
+ template<typename... As> void Analyze(const std::variant<As...> &u) {
+ std::visit([&](const auto &x) { Analyze(x); }, u);
+ }
+
+private:
+ void Analyze(const parser::WhereBodyConstruct &constr) { Analyze(constr.u); }
+ void Analyze(const parser::WhereConstruct::MaskedElsewhere &);
+ void Analyze(const parser::WhereConstruct::Elsewhere &);
+ void Analyze(const parser::ForallAssignmentStmt &stmt) { Analyze(stmt.u); }
+
+ int GetIntegerKind(const std::optional<parser::IntegerTypeSpec> &);
+
+ MaskExpr GetMask(const parser::LogicalExpr &, bool defaultValue = true) const;
+
+ template<typename... A> parser::Message *Say(A... args) {
+ return messages_.Say(std::forward<A>(args)...);
+ }
+
+ SemanticsContext &context_;
+ parser::ContextualMessages messages_;
+ WhereContext *where_{nullptr};
+ ForallContext *forall_{nullptr};
+};
+
+void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
+ if (forall_ != nullptr) {
+ // TODO: Warn if some name in forall_->activeNames or its outer
+ // contexts does not appear on LHS
+ }
+ // TODO: Fortran 2003 ALLOCATABLE assignment semantics (automatic
+ // (re)allocation of LHS array when unallocated or nonconformable)
}
-void AnalyzeAssignment(SemanticsContext &context,
- const parser::Statement<parser::PointerAssignmentStmt> &stmt) {
- AnalyzeExecutableStmt(context, stmt);
+
+void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
+ CHECK(!where_);
+ if (forall_ != nullptr) {
+ // TODO: Warn if some name in forall_->activeNames or its outer
+ // contexts does not appear on LHS
+ }
}
-void AnalyzeAssignment(SemanticsContext &context,
- const parser::Statement<parser::WhereStmt> &stmt) {
- AnalyzeExecutableStmt(context, stmt);
+
+void AssignmentContext::Analyze(const parser::WhereStmt &stmt) {
+ WhereContext where{GetMask(std::get<parser::LogicalExpr>(stmt.t))};
+ AssignmentContext nested{*this, where};
+ nested.Analyze(std::get<parser::AssignmentStmt>(stmt.t));
}
-void AnalyzeAssignment(SemanticsContext &context,
- const parser::Statement<parser::ForallStmt> &stmt) {
- AnalyzeExecutableStmt(context, stmt);
+
+// N.B. Construct name matching is checked during label resolution.
+void AssignmentContext::Analyze(const parser::WhereConstruct &construct) {
+ const auto &whereStmt{
+ std::get<parser::Statement<parser::WhereConstructStmt>>(construct.t)};
+ WhereContext where{
+ GetMask(std::get<parser::LogicalExpr>(whereStmt.statement.t))};
+ if (const auto &name{
+ std::get<std::optional<parser::Name>>(whereStmt.statement.t)}) {
+ where.constructName = name->source;
+ }
+ AssignmentContext nested{*this, where};
+ for (const auto &x :
+ std::get<std::list<parser::WhereBodyConstruct>>(construct.t)) {
+ nested.Analyze(x);
+ }
+ for (const auto &x :
+ std::get<std::list<parser::WhereConstruct::MaskedElsewhere>>(
+ construct.t)) {
+ nested.Analyze(x);
+ }
+ if (const auto &x{std::get<std::optional<parser::WhereConstruct::Elsewhere>>(
+ construct.t)}) {
+ nested.Analyze(*x);
+ }
}
-class Mutator {
+void AssignmentContext::Analyze(const parser::ForallStmt &stmt) {
+ CHECK(!where_);
+ ForallContext forall{forall_};
+ AssignmentContext nested{*this, forall};
+ nested.Analyze(
+ std::get<common::Indirection<parser::ConcurrentHeader>>(stmt.t));
+ nested.Analyze(std::get<parser::ForallAssignmentStmt>(stmt.t));
+}
+
+// N.B. Construct name matching is checked during label resolution;
+// index name distinction is checked during name resolution.
+void AssignmentContext::Analyze(const parser::ForallConstruct &construct) {
+ CHECK(!where_);
+ ForallContext forall{forall_};
+ AssignmentContext nested{*this, forall};
+ const auto &forallStmt{
+ std::get<parser::Statement<parser::ForallConstructStmt>>(construct.t)
+ .statement};
+ nested.Analyze(
+ std::get<common::Indirection<parser::ConcurrentHeader>>(forallStmt.t));
+ for (const auto &body :
+ std::get<std::list<parser::ForallBodyConstruct>>(construct.t)) {
+ nested.Analyze(body.u);
+ }
+}
+
+void AssignmentContext::Analyze(
+ const parser::WhereConstruct::MaskedElsewhere &elsewhere) {
+ CHECK(where_ != nullptr);
+ const auto &elsewhereStmt{
+ std::get<parser::Statement<parser::MaskedElsewhereStmt>>(elsewhere.t)};
+ MaskExpr mask{
+ GetMask(std::get<parser::LogicalExpr>(elsewhereStmt.statement.t))};
+ MaskExpr copyCumulative{where_->cumulativeMaskExpr};
+ MaskExpr notOldMask{evaluate::LogicalNegation(std::move(copyCumulative))};
+ if (!evaluate::AreConformable(notOldMask, mask)) {
+ Say(elsewhereStmt.source,
+ "mask of ELSEWHERE statement is not conformable with "
+ "the prior mask(s) in its WHERE construct"_err_en_US);
+ }
+ MaskExpr copyMask{mask};
+ where_->cumulativeMaskExpr =
+ evaluate::BinaryLogicalOperation(evaluate::LogicalOperator::Or,
+ std::move(where_->cumulativeMaskExpr), std::move(copyMask));
+ where_->thisMaskExpr = evaluate::BinaryLogicalOperation(
+ evaluate::LogicalOperator::And, std::move(notOldMask), std::move(mask));
+ if (where_->outer != nullptr &&
+ !evaluate::AreConformable(
+ where_->outer->thisMaskExpr, where_->thisMaskExpr)) {
+ Say(elsewhereStmt.source,
+ "effective mask of ELSEWHERE statement is not conformable "
+ "with the mask of the surrounding WHERE construct"_err_en_US);
+ }
+ for (const auto &x :
+ std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t)) {
+ Analyze(x);
+ }
+}
+
+void AssignmentContext::Analyze(
+ const parser::WhereConstruct::Elsewhere &elsewhere) {
+ CHECK(where_ != nullptr);
+ MaskExpr copyCumulative{where_->cumulativeMaskExpr};
+ where_->thisMaskExpr = evaluate::LogicalNegation(std::move(copyCumulative));
+ for (const auto &x :
+ std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t)) {
+ Analyze(x);
+ }
+}
+
+void AssignmentContext::Analyze(const parser::ConcurrentHeader &header) {
+ CHECK(forall_ != nullptr);
+ forall_->integerKind = GetIntegerKind(
+ std::get<std::optional<parser::IntegerTypeSpec>>(header.t));
+ for (const auto &control :
+ std::get<std::list<parser::ConcurrentControl>>(header.t)) {
+ const parser::CharBlock &name{std::get<parser::Name>(control.t).source};
+ bool inserted{forall_->activeNames.insert(name).second};
+ CHECK(inserted);
+ }
+}
+
+int AssignmentContext::GetIntegerKind(
+ const std::optional<parser::IntegerTypeSpec> &spec) {
+ std::optional<parser::KindSelector> empty;
+ evaluate::Expr<evaluate::SubscriptInteger> kind{AnalyzeKindSelector(
+ context_, messages_.at(), TypeCategory::Integer, spec ? spec->v : empty)};
+ if (auto value{evaluate::ToInt64(kind)}) {
+ return static_cast<int>(*value);
+ } else {
+ Say("Kind of INTEGER type must be a constant value"_err_en_US);
+ return context_.defaultKinds().GetDefaultKind(TypeCategory::Integer);
+ }
+}
+
+MaskExpr AssignmentContext::GetMask(
+ const parser::LogicalExpr &expr, bool defaultValue) const {
+ MaskExpr mask{defaultValue};
+ if (auto maybeExpr{AnalyzeExpr(context_, expr)}) {
+ auto *logical{
+ std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&maybeExpr->u)};
+ CHECK(logical != nullptr);
+ mask = evaluate::ConvertTo(mask, std::move(*logical));
+ }
+ return mask;
+}
+
+void AnalyzeConcurrentHeader(
+ SemanticsContext &context, const parser::ConcurrentHeader &header) {
+ AssignmentContext{context}.Analyze(header);
+}
+
+namespace {
+class Visitor {
public:
- Mutator(SemanticsContext &context) : context_{context} {}
+ Visitor(SemanticsContext &context) : context_{context} {}
- template<typename A> bool Pre(A &) { return true /* visit children */; }
- template<typename A> void Post(A &) {}
+ template<typename A> bool Pre(const A &) { return true /* visit children */; }
+ template<typename A> void Post(const A &) {}
- bool Pre(parser::Statement<parser::AssignmentStmt> &stmt) {
- AnalyzeAssignment(context_, stmt);
+ bool Pre(const parser::Statement<parser::AssignmentStmt> &stmt) {
+ AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
+ return false;
+ }
+ bool Pre(const parser::Statement<parser::PointerAssignmentStmt> &stmt) {
+ AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
+ return false;
+ }
+ bool Pre(const parser::Statement<parser::WhereStmt> &stmt) {
+ AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
+ return false;
+ }
+ bool Pre(const parser::WhereConstruct &construct) {
+ AssignmentContext{context_}.Analyze(construct);
+ return false;
+ }
+ bool Pre(const parser::Statement<parser::ForallStmt> &stmt) {
+ AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
+ return false;
+ }
+ bool Pre(const parser::ForallConstruct &construct) {
+ AssignmentContext{context_}.Analyze(construct);
return false;
}
private:
SemanticsContext &context_;
};
+}
void AnalyzeAssignments(parser::Program &program, SemanticsContext &context) {
- Mutator mutator{context};
- parser::Walk(program, mutator);
+ Visitor visitor{context};
+ parser::Walk(program, visitor);
}
}
-// Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+// Copyright (c) 2018-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.
namespace Fortran::parser {
template<typename> struct Statement;
struct AssignmentStmt;
+struct ConcurrentHeader;
struct ForallStmt;
struct PointerAssignmentStmt;
struct Program;
void AnalyzeAssignment(
SemanticsContext &, const parser::Statement<parser::ForallStmt> &);
+// R1125 concurrent-header is used in FORALL statements & constructs as
+// well as in DO CONCURRENT loops.
+void AnalyzeConcurrentHeader(
+ SemanticsContext &, const parser::ConcurrentHeader &);
+
// Semantic analysis of all assignment statements and related constructs.
void AnalyzeAssignments(parser::Program &, SemanticsContext &);
}
#undef NODE_NAME
template<typename T> bool Pre(const T &x) {
- IndentEmptyLine();
if (UnionTrait<T> || WrapperTrait<T>) {
- out_ << GetNodeName(x) << " -> ";
- emptyline_ = false;
+ Prefix(GetNodeName(x));
} else {
+ IndentEmptyLine();
out_ << GetNodeName(x);
EndLine();
++indent_;
template<typename T> bool Pre(const common::Indirection<T> &) { return true; }
template<typename T> void Post(const common::Indirection<T> &) {}
+ template<typename A> bool Pre(const parser::Scalar<A> &) {
+ Prefix("Scalar");
+ return true;
+ }
+ template<typename A> void Post(const parser::Scalar<A> &) {
+ EndLineIfNonempty();
+ }
+
template<typename A> bool Pre(const parser::Constant<A> &) {
- IndentEmptyLine();
- out_ << "Constant ->";
- emptyline_ = false;
+ Prefix("Constant");
return true;
}
template<typename A> void Post(const parser::Constant<A> &) {
}
template<typename A> bool Pre(const parser::Integer<A> &) {
- IndentEmptyLine();
- out_ << "Integer ->";
- emptyline_ = false;
+ Prefix("Integer");
return true;
}
- template<typename A> void Post(const parser::Integer<A> &) {}
+ template<typename A> void Post(const parser::Integer<A> &) {
+ EndLineIfNonempty();
+ }
- template<typename A> bool Pre(const parser::Scalar<A> &) {
- IndentEmptyLine();
- out_ << "Scalar ->";
- emptyline_ = false;
+ template<typename A> bool Pre(const parser::Logical<A> &) {
+ Prefix("Logical");
return true;
}
- template<typename A> void Post(const parser::Scalar<A> &) {
+ template<typename A> void Post(const parser::Logical<A> &) {
+ EndLineIfNonempty();
+ }
+
+ template<typename A> bool Pre(const parser::DefaultChar<A> &) {
+ Prefix("DefaultChar");
+ return true;
+ }
+ template<typename A> void Post(const parser::DefaultChar<A> &) {
EndLineIfNonempty();
}
}
}
+ void Prefix(const char *str) {
+ IndentEmptyLine();
+ out_ << str << " -> ";
+ emptyline_ = false;
+ }
+
+ void Prefix(const std::string &str) {
+ IndentEmptyLine();
+ out_ << str << " -> ";
+ emptyline_ = false;
+ }
+
void EndLine() {
out_ << '\n';
emptyline_ = true;
// limitations under the License.
#include "expression.h"
-#include "dump-parse-tree.h" // TODO temporary
+#include "dump-parse-tree.h" // TODO pmk temporary
+#include "scope.h"
#include "semantics.h"
#include "symbol.h"
#include "../common/idioms.h"
#include "../parser/parse-tree-visitor.h"
#include "../parser/parse-tree.h"
#include <functional>
-#include <iostream> // TODO pmk rm
#include <optional>
+#include <iostream> // TODO pmk rm
+
// Typedef for optional generic expressions (ubiquitous in this file)
using MaybeExpr =
std::optional<Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>;
const Symbol ¶meter;
};
+static std::optional<Expr<SomeInteger>> MakeTypeParamInquiry(
+ const Symbol *symbol) {
+ if (std::optional<DynamicType> dyType{GetSymbolType(symbol)}) {
+ if (dyType->category == TypeCategory::Integer) {
+ return common::SearchDynamicTypes(TypeParamInquiryVisitor{
+ dyType->kind, SymbolOrComponent{nullptr}, *symbol});
+ }
+ }
+ return std::nullopt;
+}
+
// Names and named constants
static MaybeExpr AnalyzeExpr(
ExpressionAnalysisContext &context, const parser::Name &n) {
context.Say(n.source, "parameter does not have a value"_err_en_US);
// TODO: enumerators, do they have the PARAMETER attribute?
} else if (n.symbol->detailsIf<semantics::TypeParamDetails>()) {
- // A bare reference to a derived type parameter (within the type definition)
- if (std::optional<DynamicType> dyType{GetSymbolType(n.symbol)}) {
- if (dyType->category == TypeCategory::Integer) {
- return AsMaybeExpr(common::SearchDynamicTypes(TypeParamInquiryVisitor{
- dyType->kind, SymbolOrComponent{nullptr}, *n.symbol}));
- }
- }
+ // A bare reference to a derived type parameter (within a parameterized
+ // derived type definition)
+ return AsMaybeExpr(MakeTypeParamInquiry(n.symbol));
} else if (MaybeExpr result{Designate(DataRef{*n.symbol})}) {
return result;
} else {
std::move(designator.u));
}
+// Components of parent derived types are explicitly represented as such.
+static std::optional<Component> CreateComponent(
+ DataRef &&base, const Symbol &component, const semantics::Scope &scope) {
+ if (&component.owner() == &scope) {
+ return {Component{std::move(base), component}};
+ }
+ if (const semantics::Scope * parentScope{scope.GetDerivedTypeParent()}) {
+ if (const Symbol * parentComponent{parentScope->GetSymbol()}) {
+ return CreateComponent(
+ DataRef{Component{std::move(base), *parentComponent}}, component,
+ *parentScope);
+ }
+ }
+ return std::nullopt;
+}
+
// Derived type component references and type parameter inquiries
static MaybeExpr AnalyzeExpr(
ExpressionAnalysisContext &context, const parser::StructureComponent &sc) {
if (sym->detailsIf<semantics::TypeParamDetails>()) {
if (auto *designator{UnwrapExpr<Designator<SomeDerived>>(*dtExpr)}) {
std::optional<DynamicType> dyType{GetSymbolType(sym)};
- if (dyType.has_value() && dyType->category == TypeCategory::Integer) {
- return AsMaybeExpr(
- common::SearchDynamicTypes(TypeParamInquiryVisitor{dyType->kind,
- IgnoreAnySubscripts(std::move(*designator)), *sym}));
- }
+ CHECK(dyType.has_value());
+ CHECK(dyType->category == TypeCategory::Integer);
+ return AsMaybeExpr(
+ common::SearchDynamicTypes(TypeParamInquiryVisitor{dyType->kind,
+ IgnoreAnySubscripts(std::move(*designator)), *sym}));
} else {
context.Say(name,
"type parameter inquiry must be applied to a designator"_err_en_US);
}
- } else if (dtSpec == nullptr) {
+ } else if (dtSpec == nullptr || dtSpec->scope() == nullptr) {
context.Say(name,
"TODO: base of component reference lacks a derived type"_err_en_US);
- } else if (&sym->owner() != dtSpec->scope()) {
- // TODO: extended derived types - insert explicit reference to base?
- context.Say(name,
- "component is not in scope of derived TYPE(%s)"_err_en_US,
- dtSpec->typeSymbol().name().ToString().data());
} else if (std::optional<DataRef> dataRef{
ExtractDataRef(std::move(*dtExpr))}) {
- Component component{std::move(*dataRef), *sym};
- return Designate(DataRef{std::move(component)});
+ if (auto component{
+ CreateComponent(std::move(*dataRef), *sym, *dtSpec->scope())}) {
+ return Designate(DataRef{std::move(*component)});
+ } else {
+ context.Say(name,
+ "component is not in scope of derived TYPE(%s)"_err_en_US,
+ dtSpec->typeSymbol().name().ToString().data());
+ }
} else {
context.Say(name,
"base of component reference must be a data reference"_err_en_US);
} else if (kind == MiscKind::KindParamInquiry ||
kind == MiscKind::LenParamInquiry) {
// Convert x%KIND -> intrinsic KIND(x), x%LEN -> intrinsic LEN(x)
- SpecificIntrinsic func{name.ToString().data()};
+ SpecificIntrinsic func{name.ToString()};
func.type = context.GetDefaultKindOfType(TypeCategory::Integer);
return TypedWrapper<FunctionRef, ProcedureRef>(*func.type,
ProcedureRef{ProcedureDesignator{std::move(func)},
std::visit(
common::visitors{
[&](const common::Indirection<parser::Variable> &v) {
- actualArgExpr = AnalyzeExpr(context, v);
+ actualArgExpr = AnalyzeExpr(context, *v);
},
[&](const common::Indirection<parser::Expr> &x) {
actualArgExpr = AnalyzeExpr(context, *x);
}
// TODO: map user generic to specific procedure
- // TODO: validate arguments against user interface
if (std::optional<CallAndArguments> proc{Procedure(context,
std::get<parser::ProcedureDesignator>(funcRef.v.t), arguments)}) {
if (std::optional<DynamicType> dyType{
return AnalyzeExpr(*this, variable.u);
}
-int ExpressionAnalysisContext::Analyze(TypeCategory category,
+Expr<SubscriptInteger> ExpressionAnalysisContext::Analyze(TypeCategory category,
const std::optional<parser::KindSelector> &selector) {
int defaultKind{GetDefaultKind(category)};
if (!selector.has_value()) {
- return defaultKind;
+ return Expr<SubscriptInteger>{defaultKind};
}
return std::visit(
common::visitors{
- [&](const parser::ScalarIntConstantExpr &x) -> int {
+ [&](const parser::ScalarIntConstantExpr &x)
+ -> Expr<SubscriptInteger> {
if (MaybeExpr kind{AnalyzeExpr(*this, x)}) {
- MaybeExpr folded{Fold(GetFoldingContext(), std::move(kind))};
- if (std::optional<std::int64_t> code{ToInt64(*folded)}) {
+ Expr<SomeType> folded{
+ Fold(GetFoldingContext(), std::move(*kind))};
+ if (std::optional<std::int64_t> code{ToInt64(folded)}) {
if (IsValidKindOfIntrinsicType(category, *code)) {
- return *code;
+ return Expr<SubscriptInteger>{*code};
}
- SayAt(x, "%s(kind=%jd) is not a supported type"_err_en_US,
- EnumToString(category).data(), *code);
+ SayAt(x, "%s(KIND=%jd) is not a supported type"_err_en_US,
+ parser::ToUpperCaseLetters(EnumToString(category)).data(),
+ *code);
+ } else if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(folded)}) {
+ return ConvertToType<SubscriptInteger>(std::move(*intExpr));
}
}
- return defaultKind;
+ return Expr<SubscriptInteger>{defaultKind};
},
- [&](const parser::KindSelector::StarSize &x) -> int {
+ [&](const parser::KindSelector::StarSize &x)
+ -> Expr<SubscriptInteger> {
std::intmax_t size = x.v;
if (category == TypeCategory::Complex) {
// COMPLEX*16 == COMPLEX(KIND=8)
- if ((size % 2) != 0 ||
- !evaluate::IsValidKindOfIntrinsicType(category, size / 2)) {
- Say("Complex*%jd is not a supported type"_err_en_US, size);
- return defaultKind;
+ if ((size % 2) == 0 &&
+ evaluate::IsValidKindOfIntrinsicType(category, size / 2)) {
+ size /= 2;
+ } else {
+ Say("COMPLEX*%jd is not a supported type"_err_en_US, size);
+ size = defaultKind;
}
- return size / 2;
} else if (!evaluate::IsValidKindOfIntrinsicType(category, size)) {
Say("%s*%jd is not a supported type"_err_en_US,
- EnumToString(category).data(), size);
- return defaultKind;
- } else {
- return size;
+ parser::ToUpperCaseLetters(EnumToString(category)).data(),
+ size);
+ size = defaultKind;
}
+ return Expr<SubscriptInteger>{size};
},
},
selector->u);
parser::Walk(program, visitor);
}
-int AnalyzeKindSelector(SemanticsContext &context, parser::CharBlock source,
+evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
+ SemanticsContext &context, parser::CharBlock source,
common::TypeCategory category,
const std::optional<parser::KindSelector> &selector) {
evaluate::ExpressionAnalysisContext exprContext{context};
std::optional<Expr<SomeType>> Analyze(const parser::Expr &);
std::optional<Expr<SomeType>> Analyze(const parser::Variable &);
- int Analyze(common::TypeCategory category,
+ Expr<SubscriptInteger> Analyze(common::TypeCategory category,
const std::optional<parser::KindSelector> &);
int GetDefaultKind(common::TypeCategory);
void AnalyzeExpressions(parser::Program &, SemanticsContext &);
// Semantic analysis of an intrinsic type's KIND parameter expression.
-// Always returns a valid kind value for the type category.
-int AnalyzeKindSelector(SemanticsContext &, parser::CharBlock,
- co
mmon::TypeCategory, const std::optional<parser::KindSelector> &);
+evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
+ SemanticsContext &, parser::CharBlock, common::TypeCategory,
+ const std::optional<parser::KindSelector> &);
}
#endif // FORTRAN_SEMANTICS_EXPRESSION_H_
#include "../evaluate/common.h"
#include "../evaluate/fold.h"
#include "../evaluate/tools.h"
+#include "../evaluate/type.h"
#include "../parser/parse-tree-visitor.h"
#include "../parser/parse-tree.h"
#include <list>
// Track statement source locations and save messages.
class MessageHandler {
public:
+ Messages &messages() { return *messages_; };
void set_messages(Messages &messages) { messages_ = &messages; }
const SourceName *currStmtSource() { return currStmtSource_; }
void set_currStmtSource(const SourceName *);
const SourceName *currStmtSource_{nullptr};
};
+// Inheritance graph for the parse tree visitation classes that follow:
+// BaseVisitor
+// + AttrsVisitor
+// | + DeclTypeSpecVisitor
+// | + ImplicitRulesVisitor
+// | + ScopeHandler -----------+--+
+// | + ModuleVisitor ========|==+
+// | + InterfaceVisitor | |
+// | +-+ SubprogramVisitor ==|==+
+// + ArraySpecVisitor | |
+// + DeclarationVisitor <--------+ |
+// + ConstructVisitor |
+// + ResolveNamesVisitor <------+
+
class BaseVisitor {
public:
template<typename T> void Walk(const T &);
const SourceName *currStmtSource();
SemanticsContext &context() const { return *context_; }
void set_context(SemanticsContext &);
+ evaluate::FoldingContext &GetFoldingContext() const {
+ return context_->foldingContext();
+ }
// Make a placeholder symbol for a Name that otherwise wouldn't have one.
// It is not in any scope and always has MiscDetails.
void MakePlaceholder(const parser::Name &, MiscDetails::Kind);
template<typename T> MaybeExpr EvaluateExpr(const T &expr) {
- if (auto maybeExpr{AnalyzeExpr(*context_, expr)}) {
- return evaluate::Fold(context_->foldingContext(), std::move(*maybeExpr));
- } else {
- return std::nullopt;
- }
+ auto maybeExpr{AnalyzeExpr(*context_, expr)};
+ return evaluate::Fold(GetFoldingContext(), std::move(maybeExpr));
}
template<typename T> MaybeIntExpr EvaluateIntExpr(const T &expr) {
template<typename T>
MaybeSubscriptIntExpr EvaluateSubscriptIntExpr(const T &expr) {
if (MaybeIntExpr maybeIntExpr{EvaluateIntExpr(expr)}) {
- return evaluate::Fold(context_->foldingContext(),
+ return evaluate::Fold(GetFoldingContext(),
evaluate::ConvertToType<evaluate::SubscriptInteger>(
std::move(*maybeIntExpr)));
} else {
explicit DeclTypeSpecVisitor() {}
using AttrsVisitor::Post;
using AttrsVisitor::Pre;
- void Post(const parser::IntegerTypeSpec &);
- void Post(const parser::IntrinsicTypeSpec::Logical &);
- void Post(const parser::IntrinsicTypeSpec::Real &);
- void Post(const parser::IntrinsicTypeSpec::Complex &);
void Post(const parser::IntrinsicTypeSpec::DoublePrecision &);
void Post(const parser::IntrinsicTypeSpec::DoubleComplex &);
bool Pre(const parser::DeclarationTypeSpec::Class &);
void Post(const parser::DeclarationTypeSpec::ClassStar &);
void Post(const parser::DeclarationTypeSpec::TypeStar &);
- void Post(const parser::TypeParamSpec &);
bool Pre(const parser::TypeGuardStmt &);
void Post(const parser::TypeGuardStmt &);
bool Pre(const parser::AcSpec &);
protected:
struct State {
- bool expectDeclTypeSpec{false}; // should only see decl-type-spec when true
+ bool expectDeclTypeSpec{false}; // should see decl-type-spec only when true
const DeclTypeSpec *declTypeSpec{nullptr};
struct {
DerivedTypeSpec *type{nullptr};
void EndDeclTypeSpec();
State SetDeclTypeSpecState(State);
void SetDeclTypeSpec(const DeclTypeSpec &);
- DerivedTypeSpec &SetDerivedTypeSpec(Scope &, const parser::Name &);
- ParamValue GetParamValue(const parser::TypeParamValue &);
+ void SetDeclTypeSpecCategory(DeclTypeSpec::Category);
+ DeclTypeSpec::Category GetDeclTypeSpecCategory() const {
+ return state_.derived.category;
+ }
+ KindExpr GetKindParamExpr(
+ TypeCategory, const std::optional<parser::KindSelector> &);
private:
State state_;
- void MakeNumericType(
- TypeCategory, const std::optional<parser::KindSelector> &);
void MakeNumericType(TypeCategory, int kind);
- int GetKindParamValue(
- TypeCategory, const std::optional<parser::KindSelector> &);
};
// Visit ImplicitStmt and related parse tree nodes and updates implicit rules.
// Search for name only in scope, not in enclosing scopes.
Symbol *FindInScope(const Scope &, const parser::Name &);
Symbol *FindInScope(const Scope &, const SourceName &);
+ // Search for name in a derived type scope and its parents.
+ Symbol *FindInTypeOrParents(SourceName);
+ Symbol *FindInTypeOrParents(const Scope &, SourceName);
void EraseSymbol(const parser::Name &);
// Record that name resolved to symbol
Symbol *Resolve(const parser::Name &, Symbol *);
Symbol &MakeSymbol(
const parser::Name &name, const Attrs &attrs, D &&details) {
// Note: don't use FindSymbol here. If this is a derived type scope,
- // we want to detect if the name is already declared as a component.
+ // we want to detect whether the name is already declared as a component.
auto *symbol{FindInScope(currScope(), name)};
if (!symbol) {
symbol = &MakeSymbol(name, attrs);
bool ConvertToObjectEntity(Symbol &);
bool ConvertToProcEntity(Symbol &);
+ DeclTypeSpec &MakeNumericType(
+ TypeCategory, const std::optional<parser::KindSelector> &);
+ DeclTypeSpec &MakeLogicalType(const std::optional<parser::KindSelector> &);
+
// Walk the ModuleSubprogramPart or InternalSubprogramPart collecting names.
template<typename T>
void WalkSubprogramPart(const std::optional<T> &subpPart) {
void Post(const parser::DimensionStmt::Declaration &);
bool Pre(const parser::TypeDeclarationStmt &) { return BeginDecl(); }
void Post(const parser::TypeDeclarationStmt &) { EndDecl(); }
+ void Post(const parser::IntegerTypeSpec &);
+ void Post(const parser::IntrinsicTypeSpec::Real &);
+ void Post(const parser::IntrinsicTypeSpec::Complex &);
+ void Post(const parser::IntrinsicTypeSpec::Logical &);
void Post(const parser::IntrinsicTypeSpec::Character &);
void Post(const parser::CharSelector::LengthAndKind &);
void Post(const parser::CharLength &);
void Post(const parser::LengthSelector &);
+ bool Pre(const parser::DeclarationTypeSpec::Type &);
+ bool Pre(const parser::DeclarationTypeSpec::Class &);
bool Pre(const parser::DeclarationTypeSpec::Record &);
- bool Pre(const parser::DerivedTypeSpec &);
+ void Post(const parser::DerivedTypeSpec &);
void Post(const parser::DerivedTypeDef &x);
bool Pre(const parser::DerivedTypeStmt &x);
void Post(const parser::DerivedTypeStmt &x);
// Info about current character type while walking DeclTypeSpec
struct {
std::optional<ParamValue> length;
- int kind{0};
+ std::optional<KindExpr> kind;
} charInfo_;
// Info about current derived type while walking DerivedTypeStmt
struct {
const Symbol *ResolveDerivedType(const parser::Name &);
bool CanBeTypeBoundProc(const Symbol &);
Symbol *FindExplicitInterface(const parser::Name &);
- const Symbol *FindTypeSymbol(const parser::Name &);
Symbol *MakeTypeSymbol(const parser::Name &, Details &&);
bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr);
+ ParamValue GetParamValue(const parser::TypeParamValue &);
// Declare an object or procedure entity.
// T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails
const parser::Name *ResolveName(const parser::Name &);
const parser::Name *FindComponent(const parser::Name *, const parser::Name &);
- Symbol *FindComponent(const Scope &, const parser::Name &);
bool CheckAccessibleComponent(const parser::Name &);
void CheckImports();
void CheckImport(const SourceName &, const SourceName &);
CHECK(state_.expectDeclTypeSpec);
state_ = {};
}
-DeclTypeSpecVisitor::State DeclTypeSpecVisitor::SetDeclTypeSpecState(State x) {
+DeclTypeSpecVisitor::State DeclTypeSpecVisitor::SetDeclTypeSpecState(
+ const State &x) {
auto result{state_};
state_ = x;
return result;
}
-void DeclTypeSpecVisitor::Post(const parser::TypeParamSpec &x) {
- CHECK(state_.derived.type);
- DerivedTypeSpec &derivedTypeSpec{*state_.derived.type};
- const auto &value{std::get<parser::TypeParamValue>(x.t)};
- if (const auto &keyword{std::get<std::optional<parser::Keyword>>(x.t)}) {
- derivedTypeSpec.AddParamValue(keyword->v.source, GetParamValue(value));
- } else {
- derivedTypeSpec.AddParamValue(GetParamValue(value));
- }
-}
-
-ParamValue DeclTypeSpecVisitor::GetParamValue(const parser::TypeParamValue &x) {
- return std::visit(
- common::visitors{
- [=](const parser::ScalarIntExpr &x) {
- return ParamValue{EvaluateIntExpr(x)};
- },
- [](const parser::Star &) { return ParamValue::Assumed(); },
- [](const parser::TypeParamValue::Deferred &) {
- return ParamValue::Deferred();
- },
- },
- x.u);
+void DeclTypeSpecVisitor::SetDeclTypeSpecCategory(
+ DeclTypeSpec::Category category) {
+ CHECK(state_.expectDeclTypeSpec);
+ state_.derived.category = category;
}
bool DeclTypeSpecVisitor::Pre(const parser::TypeGuardStmt &) {
return false;
}
-void DeclTypeSpecVisitor::Post(const parser::IntrinsicTypeSpec::Logical &x) {
- SetDeclTypeSpec(context().MakeLogicalType(
- GetKindParamValue(TypeCategory::Logical, x.kind)));
-}
-void DeclTypeSpecVisitor::Post(const parser::IntegerTypeSpec &x) {
- MakeNumericType(TypeCategory::Integer, x.v);
-}
-void DeclTypeSpecVisitor::Post(const parser::IntrinsicTypeSpec::Real &x) {
- MakeNumericType(TypeCategory::Real, x.kind);
-}
-void DeclTypeSpecVisitor::Post(const parser::IntrinsicTypeSpec::Complex &x) {
- MakeNumericType(TypeCategory::Complex, x.kind);
-}
void DeclTypeSpecVisitor::Post(
const parser::IntrinsicTypeSpec::DoublePrecision &) {
MakeNumericType(
MakeNumericType(
TypeCategory::Complex, context().defaultKinds().doublePrecisionKind());
}
-void DeclTypeSpecVisitor::MakeNumericType(
- TypeCategory category, const std::optional<parser::KindSelector> &kind) {
- MakeNumericType(category, GetKindParamValue(category, kind));
-}
void DeclTypeSpecVisitor::MakeNumericType(TypeCategory category, int kind) {
SetDeclTypeSpec(context().MakeNumericType(category, kind));
}
state_.declTypeSpec = &declTypeSpec;
}
-// Set the current DeclTypeSpec to a derived type created from this name.
-DerivedTypeSpec &DeclTypeSpecVisitor::SetDerivedTypeSpec(
- Scope &scope, const parser::Name &typeName) {
- DerivedTypeSpec &derived{scope.MakeDerivedType(*typeName.symbol)};
- SetDeclTypeSpec(scope.MakeDerivedType(state_.derived.category, derived));
- state_.derived.type = &derived;
- return derived;
-}
-
-int DeclTypeSpecVisitor::GetKindParamValue(
+KindExpr DeclTypeSpecVisitor::GetKindParamExpr(
TypeCategory category, const std::optional<parser::KindSelector> &kind) {
- if (!kind) {
- return 0;
- }
- // TODO: check that we get a valid kind
- return std::visit(
- common::visitors{
- [&](const parser::ScalarIntConstantExpr &x) -> int {
- if (auto maybeExpr{EvaluateExpr(x)}) {
- if (auto intConst{evaluate::ToInt64(*maybeExpr)}) {
- return *intConst;
- }
- }
- return 0;
- },
- [&](const parser::KindSelector::StarSize &x) -> int {
- std::uint64_t size{x.v};
- if (category == TypeCategory::Complex) {
- size /= 2;
- }
- return size;
- },
- },
- kind->u);
+ return AnalyzeKindSelector(context(), *currStmtSource(), category, kind);
}
// MessageHandler implementation
}
void ScopeHandler::SayDerivedType(
const SourceName &name, MessageFixedText &&msg, const Scope &type) {
- Say(name, std::move(msg), name, type.name())
- .Attach(type.name(), "Declaration of derived type '%s'"_en_US,
- type.name().ToString().c_str());
+ const Symbol *typeSymbol{type.GetSymbol()};
+ CHECK(typeSymbol != nullptr);
+ Say(name, std::move(msg), name, typeSymbol->name())
+ .Attach(typeSymbol->name(), "Declaration of derived type '%s'"_en_US,
+ typeSymbol->name().ToString().c_str());
}
void ScopeHandler::Say2(const parser::Name &name, MessageFixedText &&msg1,
const Symbol &symbol, MessageFixedText &&msg2) {
return FindSymbol(currScope(), name);
}
Symbol *ScopeHandler::FindSymbol(const Scope &scope, const parser::Name &name) {
+ // Scope::FindSymbol() skips over innermost derived type scopes.
+ // Ensure that "bare" type parameter names are not overlooked.
+ if (Symbol * symbol{FindInTypeOrParents(scope, name.source)}) {
+ if (symbol->has<TypeParamDetails>()) {
+ return Resolve(name, symbol);
+ }
+ }
return Resolve(name, scope.FindSymbol(name.source));
}
}
}
+// Find a component or type parameter by name in a derived type or its parents.
+Symbol *ScopeHandler::FindInTypeOrParents(SourceName name) {
+ return FindInTypeOrParents(currScope(), name);
+}
+Symbol *ScopeHandler::FindInTypeOrParents(const Scope &scope, SourceName name) {
+ if (scope.kind() == Scope::Kind::DerivedType) {
+ if (Symbol * symbol{FindInScope(scope, name)}) {
+ return symbol;
+ }
+ if (const Scope * parent{scope.GetDerivedTypeParent()}) {
+ return FindInTypeOrParents(*parent, name);
+ }
+ }
+ return nullptr;
+}
+
void ScopeHandler::EraseSymbol(const parser::Name &name) {
currScope().erase(name.source);
name.symbol = nullptr;
return true;
}
+DeclTypeSpec &ScopeHandler::MakeNumericType(
+ TypeCategory category, const std::optional<parser::KindSelector> &kind) {
+ KindExpr value{GetKindParamExpr(category, kind)};
+ if (auto known{evaluate::ToInt64(value)}) {
+ return context().MakeNumericType(category, static_cast<int>(*known));
+ } else {
+ return currScope_->MakeNumericType(category, std::move(value));
+ }
+}
+
+DeclTypeSpec &ScopeHandler::MakeLogicalType(
+ const std::optional<parser::KindSelector> &kind) {
+ KindExpr value{GetKindParamExpr(TypeCategory::Logical, kind)};
+ if (auto known{evaluate::ToInt64(value)}) {
+ return context().MakeLogicalType(static_cast<int>(*known));
+ } else {
+ return currScope_->MakeLogicalType(std::move(value));
+ }
+}
+
// ModuleVisitor implementation
bool ModuleVisitor::Pre(const parser::Only &x) {
return symbol;
}
+void DeclarationVisitor::Post(const parser::IntegerTypeSpec &x) {
+ SetDeclTypeSpec(MakeNumericType(TypeCategory::Integer, x.v));
+}
+void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Real &x) {
+ SetDeclTypeSpec(MakeNumericType(TypeCategory::Real, x.kind));
+}
+void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Complex &x) {
+ SetDeclTypeSpec(MakeNumericType(TypeCategory::Complex, x.kind));
+}
+void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Logical &x) {
+ SetDeclTypeSpec(MakeLogicalType(x.kind));
+}
void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Character &x) {
if (!charInfo_.length) {
charInfo_.length = ParamValue{1};
}
- if (charInfo_.kind == 0) {
- charInfo_.kind =
- context().defaultKinds().GetDefaultKind(TypeCategory::Character);
+ if (!charInfo_.kind.has_value()) {
+ charInfo_.kind = KindExpr{
+ context().defaultKinds().GetDefaultKind(TypeCategory::Character)};
}
SetDeclTypeSpec(currScope().MakeCharacterType(
- std::move(*charInfo_.length), charInfo_.kind));
+ std::move(*charInfo_.length), std::move(*charInfo_.kind)));
charInfo_ = {};
}
void DeclarationVisitor::Post(const parser::CharSelector::LengthAndKind &x) {
- if (auto maybeExpr{EvaluateExpr(x.kind)}) {
- if (std::optional<std::int64_t> kind{evaluate::ToInt64(*maybeExpr)}) {
- charInfo_.kind = *kind;
- } else {
- common::die("TODO: kind did not evaluate to a constant integer");
- }
- }
+ charInfo_.kind = EvaluateSubscriptIntExpr(x.kind);
if (x.length) {
charInfo_.length = GetParamValue(*x.length);
}
}
}
+bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Type &x) {
+ CHECK(GetDeclTypeSpecCategory() == DeclTypeSpec::Category::TypeDerived);
+ return true;
+}
+
+bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Class &x) {
+ SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived);
+ return true;
+}
+
bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) {
- return true; // TODO
+ // TODO
+ return true;
}
-bool DeclarationVisitor::Pre(const parser::DerivedTypeSpec &x) {
+void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) {
const auto &typeName{std::get<parser::Name>(x.t)};
- if (const auto *symbol{ResolveDerivedType(typeName)}) {
- SetDerivedTypeSpec(currScope(), typeName).set_scope(*symbol->scope());
+ const Symbol *typeSymbol{ResolveDerivedType(&typeName)};
+ if (typeSymbol == nullptr) {
+ return;
+ }
+
+ // This DerivedTypeSpec is created initially as a search key.
+ // If it turns out to have the same name and actual parameter
+ // value expressions as some other DerivedTypeSpec in the current
+ // scope, then we'll use that extant spec; otherwise, when this
+ // spec is distinct from all derived types previously instantiated
+ // in the current scope, this spec will be moved to that collection.
+ DerivedTypeSpec spec{*typeSymbol};
+
+ // The expressions in a derived type specifier whose values define
+ // non-defaulted type parameters are evaluated in the enclosing scope.
+ // Default initialization expressions for the derived type's parameters
+ // may reference other parameters so long as the declaration precedes the
+ // use in the expression (10.1.12). This is not necessarily the same
+ // order as "type parameter order" (7.5.3.2).
+ // Parameters of the most deeply nested "base class" come first when the
+ // derived type is an extension.
+ const DerivedTypeDetails &typeDetails{typeSymbol->get<DerivedTypeDetails>()};
+ auto parameterNames{typeDetails.OrderParameterNames(*typeSymbol)};
+ auto nextNameIter{parameterNames.begin()};
+ bool seenAnyName{false};
+ for (const auto &typeParamSpec :
+ std::get<std::list<parser::TypeParamSpec>>(x.t)) {
+ const auto &optKeyword{
+ std::get<std::optional<parser::Keyword>>(typeParamSpec.t)};
+ SourceName name;
+ if (optKeyword.has_value()) {
+ seenAnyName = true;
+ name = optKeyword->v.source;
+ if (std::find(parameterNames.begin(), parameterNames.end(), name) ==
+ parameterNames.end()) {
+ Say(name,
+ "'%s' is not the name of a parameter for this type"_err_en_US);
+ }
+ } else if (seenAnyName) {
+ Say(typeName.source, "Type parameter value must have a name"_err_en_US);
+ continue;
+ } else if (nextNameIter != parameterNames.end()) {
+ name = *nextNameIter++;
+ } else {
+ Say(typeName.source,
+ "Too many type parameters given for derived type '%s'"_err_en_US);
+ break;
+ }
+ if (spec.FindParameter(name)) {
+ Say(typeName.source,
+ "Multiple values given for type parameter '%s'"_err_en_US, name);
+ } else {
+ const auto &value{std::get<parser::TypeParamValue>(typeParamSpec.t)};
+ ParamValue param{GetParamValue(value)}; // folded
+ if (!param.isExplicit() || param.GetExplicit().has_value()) {
+ spec.AddParamValue(name, std::move(param));
+ }
+ }
+ }
+
+ // Ensure that any type parameter without an explicit value has a
+ // default initialization in the derived type's definition.
+ const Scope *typeScope{typeSymbol->scope()};
+ CHECK(typeScope != nullptr);
+ for (const SourceName &name : parameterNames) {
+ if (!spec.FindParameter(name)) {
+ const Symbol *symbol{FindInTypeOrParents(*typeScope, name)};
+ CHECK(symbol != nullptr);
+ const auto *details{symbol->detailsIf<TypeParamDetails>()};
+ if (details == nullptr || !details->init().has_value()) {
+ Say(typeName.source,
+ "Type parameter '%s' lacks a value and has no default"_err_en_US,
+ symbol->name());
+ }
+ }
+ }
+
+ auto category{GetDeclTypeSpecCategory()};
+ if (const DeclTypeSpec *
+ extant{currScope().FindInstantiatedDerivedType(spec, category)}) {
+ // This derived type and parameter expressions (if any) are already present
+ // in this scope.
+ SetDeclTypeSpec(*extant);
+ } else {
+ DeclTypeSpec &type{currScope().MakeDerivedType(std::move(spec), category)};
+ if (parameterNames.empty() || currScope().IsParameterizedDerivedType()) {
+ // The derived type being instantiated is not a parameterized derived
+ // type, or the instantiation is within the definition of a parameterized
+ // derived type; don't instantiate a new scope.
+ type.derivedTypeSpec().set_scope(*typeScope);
+ } else {
+ // This is a parameterized derived type and this spec is not in the
+ // context of a parameterized derived type definition, so we need to
+ // clone its contents, specialize them with the actual type parameter
+ // values, and check constraints.
+ auto inLocation{
+ GetFoldingContext().messages.SetLocation(*currStmtSource())};
+ type.derivedTypeSpec().Instantiate(currScope(), GetFoldingContext());
+ }
+ SetDeclTypeSpec(type);
}
- return true;
}
void DeclarationVisitor::Post(const parser::DerivedTypeDef &x) {
std::set<SourceName> paramNames;
auto &scope{currScope()};
+ CHECK(scope.symbol() != nullptr);
+ CHECK(scope.symbol()->scope() == &scope);
auto &details{scope.symbol()->get<DerivedTypeDetails>()};
auto &stmt{std::get<parser::Statement<parser::DerivedTypeStmt>>(x.t)};
for (auto ¶mName : std::get<std::list<parser::Name>>(stmt.statement.t)) {
PushScope(Scope::Kind::DerivedType, &symbol);
if (auto *extendsName{derivedTypeInfo_.extends}) {
if (const Symbol * extends{ResolveDerivedType(*extendsName)}) {
- symbol.get<DerivedTypeDetails>().set_extends(extendsName->source);
// Declare the "parent component"; private if the type is
if (OkToAddComponent(*extendsName, extends)) {
+ symbol.get<DerivedTypeDetails>().set_extends(extendsName->source);
auto &comp{DeclareEntity<ObjectEntityDetails>(*extendsName, Attrs{})};
comp.attrs().set(Attr::PRIVATE, extends->attrs().test(Attr::PRIVATE));
comp.set(Symbol::Flag::ParentComp);
- DerivedTypeSpec &derived{currScope().MakeDerivedType(*extends)};
- derived.set_scope(currScope());
- comp.SetType(
- currScope().MakeDerivedType(DeclTypeSpec::TypeDerived, derived));
+ DeclTypeSpec &type{currScope().MakeDerivedType(*extends)};
+ type.derivedTypeSpec().set_scope(*extends->scope());
+ comp.SetType(type);
}
}
}
if (!genericSymbol->has<GenericBindingDetails>()) {
genericSymbol = nullptr; // MakeTypeSymbol will report the error below
}
- } else if (const auto *inheritedSymbol{FindTypeSymbol(*genericName)}) {
+ } else if (const auto *inheritedSymbol{
+ FindInTypeOrParents(genericName->source)}) {
// look in parent types:
if (inheritedSymbol->has<GenericBindingDetails>()) {
inheritedProcs =
details.add_specificProcs(*inheritedProcs);
}
for (const auto &bindingName : std::get<std::list<parser::Name>>(x.t)) {
- const auto *symbol{FindTypeSymbol(bindingName)};
+ const auto *symbol{FindInTypeOrParents(bindingName.source)};
if (!symbol) {
Say(bindingName,
"Binding name '%s' not found in this derived type"_err_en_US);
// Find the Symbol for this derived type.
const Symbol *DeclarationVisitor::ResolveDerivedType(const parser::Name &name) {
const auto *symbol{FindSymbol(name)};
+ const Symbol *symbol{FindSymbol(name)};
if (!symbol) {
Say(name, "Derived type '%s' not found"_err_en_US);
return nullptr;
return symbol;
}
-// Find a component by name in the current derived type or its parents.
-const Symbol *DeclarationVisitor::FindTypeSymbol(const parser::Name &name) {
- for (const Scope *scope{&currScope()};;) {
- CHECK(scope->kind() == Scope::Kind::DerivedType);
- if (const Symbol * symbol{FindInScope(*scope, name)}) {
- return symbol;
- }
- const Symbol *parent{scope->symbol()->GetParent()};
- if (parent == nullptr) {
- return nullptr;
- }
- scope = parent->scope();
- }
-}
-
// Create a symbol for a type parameter, component, or procedure binding in
// the current derived type scope. Return false on error.
Symbol *DeclarationVisitor::MakeTypeSymbol(
std::holds_alternative<ProcBindingDetails>(details)) {
attrs.set(Attr::PRIVATE);
}
- return &MakeSymbol(name, attrs, details);
+ Symbol &result{MakeSymbol(name, attrs, details)};
+ if (result.has<TypeParamDetails>()) {
+ derivedType.symbol()->get<DerivedTypeDetails>().add_paramDecl(result);
+ }
+ return &result;
}
}
// Otherwise, emit an error and return false.
bool DeclarationVisitor::OkToAddComponent(
const parser::Name &name, const Symbol *extends) {
- const Scope *scope{&currScope()};
- for (bool inParent{false};; inParent = true) {
+ for (const Scope *scope{&currScope()}; scope != nullptr;) {
CHECK(scope->kind() == Scope::Kind::DerivedType);
if (auto *prev{FindInScope(*scope, name)}) {
auto msg{""_en_US};
} else if (prev->test(Symbol::Flag::ParentComp)) {
msg = "'%s' is a parent type of this type and so cannot be"
" a component"_err_en_US;
- } else if (inParent) {
+ } else if (scope != &currScope()) {
msg = "Component '%s' is already declared in a parent of this"
" derived type"_err_en_US;
} else {
Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US);
return false;
}
- if (!inParent && extends != nullptr) {
+ if (scope == &currScope() && extends != nullptr) {
// The parent component has not yet been added to the scope.
scope = extends->scope();
- } else if (const Symbol * parent{scope->symbol()->GetParent()}) {
- scope = parent->scope();
} else {
- return true;
+ scope = scope->GetDerivedTypeParent();
}
}
+ return true;
+}
+
+ParamValue DeclarationVisitor::GetParamValue(const parser::TypeParamValue &x) {
+ return std::visit(
+ common::visitors{
+ [=](const parser::ScalarIntExpr &x) {
+ return ParamValue{EvaluateIntExpr(x)};
+ },
+ [](const parser::Star &) { return ParamValue::Assumed(); },
+ [](const parser::TypeParamValue::Deferred &) {
+ return ParamValue::Deferred();
+ },
+ },
+ x.u);
}
// ConstructVisitor implementation
std::get<parser::LoopBounds<parser::ScalarIntConstantExpr>>(x.t)};
if (type) {
BeginDeclTypeSpec();
- DeclTypeSpecVisitor::Post(*type);
+ DeclarationVisitor::Post(*type);
}
if (auto *symbol{DeclareConstructEntity(bounds.name.thing.thing)}) {
CheckIntegerType(*symbol);
}
// base is a part-ref of a derived type; find the named component in its type.
+// Also handles intrinsic type parameter inquiries (%kind, %len) and
+// COMPLEX component references (%re, %im).
const parser::Name *ResolveNamesVisitor::FindComponent(
const parser::Name *base, const parser::Name &component) {
if (!base || !base->symbol) {
return nullptr;
}
} else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
- if (const auto *scope{derived->scope()}) {
- if (!FindComponent(*scope, component)) {
+ if (const Scope * scope{derived->scope()}) {
+ if (Resolve(component, FindInTypeOrParents(*scope, component.source))) {
+ if (CheckAccessibleComponent(component)) {
+ return &component;
+ }
+ } else {
SayDerivedType(component.source,
"Component '%s' not found in derived type '%s'"_err_en_US, *scope);
- } else if (CheckAccessibleComponent(component)) {
- return &component;
}
- return nullptr;
}
+ return nullptr;
}
if (symbol.test(Symbol::Flag::Implicit)) {
Say(*base,
return false;
}
-// Look in this type's scope and then its parents for component.
-Symbol *ResolveNamesVisitor::FindComponent(
- const Scope &type, const parser::Name &component) {
- CHECK(type.kind() == Scope::Kind::DerivedType);
- if (auto *symbol{FindInScope(type, component)}) {
- return symbol;
- }
- if (const Symbol * parent{type.symbol()->GetParent()}) {
- return FindComponent(*parent->scope(), component);
- }
- return nullptr;
-}
-
void ResolveNamesVisitor::Post(const parser::ProcedureDesignator &x) {
if (const auto *name{std::get_if<parser::Name>(&x.u)}) {
auto *symbol{FindSymbol(*name)};
#include "scope.h"
#include "symbol.h"
+#include "type.h"
+#include "../evaluate/fold.h"
+#include "../parser/characters.h"
#include <algorithm>
#include <memory>
}
Scope &Scope::MakeScope(Kind kind, Symbol *symbol) {
- children_.emplace_back(*this, kind, symbol);
- return children_.back();
+ return children_.emplace_back(*this, kind, symbol);
}
Scope::iterator Scope::find(const SourceName &name) {
return submodules_.emplace(name, &submodule).second;
}
-const DeclTypeSpec &Scope::MakeNumericType(TypeCategory category, int kind) {
- return MakeLengthlessType(NumericTypeSpec{category, kind});
+const DeclTypeSpec &Scope::MakeNumericType(TypeCategory category, KindExpr &&kind) {
+ return MakeLengthlessType(NumericTypeSpec{category, std::move(kind)});
}
-const DeclTypeSpec &Scope::MakeLogicalType(int kind) {
- return MakeLengthlessType(LogicalTypeSpec{kind});
+const DeclTypeSpec &Scope::MakeLogicalType(KindExpr &&kind) {
+ return MakeLengthlessType(LogicalTypeSpec{std::move(kind)});
}
const DeclTypeSpec &Scope::MakeTypeStarType() {
return MakeLengthlessType(DeclTypeSpec{DeclTypeSpec::TypeStar});
}
// Types that can't have length parameters can be reused without having to
// compare length expressions. They are stored in the global scope.
-const DeclTypeSpec &Scope::MakeLengthlessType(const DeclTypeSpec &type) {
+const DeclTypeSpec &Scope::MakeLengthlessType(DeclTypeSpec &&type) {
auto it{std::find(declTypeSpecs_.begin(), declTypeSpecs_.end(), type)};
if (it != declTypeSpecs_.end()) {
return *it;
} else {
- declTypeSpecs_.push_back(type);
- return declTypeSpecs_.back();
+ return declTypeSpecs_.emplace_back(std::move(type));
}
}
-const DeclTypeSpec &Scope::MakeCharacterType(ParamValue &&length, int kind) {
- characterTypeSpecs_.emplace_back(std::move(length), kind);
- declTypeSpecs_.emplace_back(characterTypeSpecs_.back());
- return declTypeSpecs_.back();
+const DeclTypeSpec &Scope::MakeCharacterType(ParamValue &&length, KindExpr &&kind) {
+ return declTypeSpecs_.emplace_back(
+ CharacterTypeSpec{std::move(length), std::move(kind)});
}
-DerivedTypeSpec &Scope::MakeDerivedType(const Symbol &typeSymbol) {
- return derivedTypeSpecs_.emplace_back(typeSymbol);
-}
const DeclTypeSpec &Scope::MakeDerivedType(
DeclTypeSpec::Category category, const DerivedTypeSpec &derived) {
return declTypeSpecs_.emplace_back(category, derived);
}
+DeclTypeSpec &Scope::MakeDerivedType(const Symbol &typeSymbol) {
+ CHECK(typeSymbol.has<DerivedTypeDetails>());
+ CHECK(typeSymbol.scope() != nullptr);
+ return MakeDerivedType(
+ DerivedTypeSpec{typeSymbol}, DeclTypeSpec::TypeDerived);
+}
+
+DeclTypeSpec &Scope::MakeDerivedType(
+ DerivedTypeSpec &&instance, DeclTypeSpec::Category category) {
+ return declTypeSpecs_.emplace_back(
+ category, DerivedTypeSpec{std::move(instance)});
+}
+
Scope::ImportKind Scope::GetImportKind() const {
if (importKind_) {
return *importKind_;
}
return os;
}
+
+bool Scope::IsParameterizedDerivedType() const {
+ if (kind_ != Kind::DerivedType) {
+ return false;
+ }
+ if (const Scope * parent{GetDerivedTypeParent()}) {
+ if (parent->IsParameterizedDerivedType()) {
+ return true;
+ }
+ }
+ for (const auto &pair : symbols_) {
+ if (pair.second->has<TypeParamDetails>()) {
+ return true;
+ }
+ }
+ return false;
+}
+
+const DeclTypeSpec *Scope::FindInstantiatedDerivedType(
+ const DerivedTypeSpec &spec, DeclTypeSpec::Category category) const {
+ DeclTypeSpec type{category, spec};
+ auto typeIter{std::find(declTypeSpecs_.begin(), declTypeSpecs_.end(), type)};
+ if (typeIter != declTypeSpecs_.end()) {
+ return &*typeIter;
+ }
+ return nullptr;
+}
+
+const DeclTypeSpec &Scope::FindOrInstantiateDerivedType(DerivedTypeSpec &&spec,
+ DeclTypeSpec::Category category, evaluate::FoldingContext &foldingContext) {
+ spec.FoldParameterExpressions(foldingContext);
+ if (const DeclTypeSpec * type{FindInstantiatedDerivedType(spec, category)}) {
+ return *type;
+ }
+ // Create a new instantiation of this parameterized derived type
+ // for this particular distinct set of actual parameter values.
+ DeclTypeSpec &type{MakeDerivedType(std::move(spec), category)};
+ type.derivedTypeSpec().Instantiate(*this, foldingContext);
+ return type;
+}
+
+void Scope::InstantiateDerivedType(
+ Scope &clone, evaluate::FoldingContext &foldingContext) const {
+ clone.sourceRange_ = sourceRange_;
+ clone.chars_ = chars_;
+ for (const auto &pair : symbols_) {
+ pair.second->Instantiate(clone, foldingContext);
+ }
+}
+
+const DeclTypeSpec &Scope::InstantiateIntrinsicType(
+ const DeclTypeSpec &spec, evaluate::FoldingContext &foldingContext) {
+ const IntrinsicTypeSpec *intrinsic{spec.AsIntrinsic()};
+ CHECK(intrinsic != nullptr);
+ if (evaluate::ToInt64(intrinsic->kind()).has_value()) {
+ return spec; // KIND is already a known constant
+ }
+ // The expression was not originally constant, but now it must be so
+ // in the context of a parameterized derived type instantiation.
+ KindExpr copy{intrinsic->kind()};
+ copy = evaluate::Fold(foldingContext, std::move(copy));
+ auto value{evaluate::ToInt64(copy)};
+ CHECK(value.has_value() &&
+ "KIND parameter of intrinsic type did not resolve to a "
+ "constant INTEGER value in a parameterized derived type instance");
+ if (!evaluate::IsValidKindOfIntrinsicType(intrinsic->category(), *value)) {
+ foldingContext.messages.Say(
+ "KIND parameter value (%jd) of intrinsic type %s did not resolve to a supported value"_err_en_US,
+ static_cast<std::intmax_t>(*value),
+ parser::ToUpperCaseLetters(common::EnumToString(intrinsic->category()))
+ .data());
+ }
+ switch (spec.category()) {
+ case DeclTypeSpec::Numeric:
+ return declTypeSpecs_.emplace_back(
+ NumericTypeSpec{intrinsic->category(), KindExpr{*value}});
+ case DeclTypeSpec::Logical:
+ return declTypeSpecs_.emplace_back(LogicalTypeSpec{KindExpr{*value}});
+ case DeclTypeSpec::Character:
+ return declTypeSpecs_.emplace_back(CharacterTypeSpec{
+ ParamValue{spec.characterTypeSpec().length()}, KindExpr{*value}});
+ default: CRASH_NO_CASE;
+ }
+}
+
+const Symbol *Scope::GetSymbol() const {
+ if (symbol_ != nullptr) {
+ return symbol_;
+ }
+ if (derivedTypeSpec_ != nullptr) {
+ return &derivedTypeSpec_->typeSymbol();
+ }
+ return nullptr;
+}
+
+const Scope *Scope::GetDerivedTypeParent() const {
+ if (const Symbol * symbol{GetSymbol()}) {
+ if (const DerivedTypeSpec * parent{symbol->GetParentTypeSpec(this)}) {
+ return parent->scope();
+ }
+ }
+ return nullptr;
+}
}
#include <set>
#include <string>
+namespace Fortran::evaluate {
+struct FoldingContext;
+}
+
namespace Fortran::semantics {
using namespace parser::literals;
}
Kind kind() const { return kind_; }
bool IsModule() const; // only module, not submodule
+ bool IsParameterizedDerivedType() const;
Symbol *symbol() { return symbol_; }
const Symbol *symbol() const { return symbol_; }
+ const Symbol *GetSymbol() const;
+ const Scope *GetDerivedTypeParent() const;
+
const SourceName &name() const {
- CHECK(symbol_); // must only be called for Scopes known to have a symbol
- return symbol_->name();
+ const Symbol *sym{GetSymbol()};
+ CHECK(sym != nullptr);
+ return sym->name();
}
/// Make a scope nested in this one
const_iterator find(const SourceName &name) const;
size_type erase(const SourceName &);
size_type size() const { return symbols_.size(); }
+ bool empty() const { return symbols_.empty(); }
// Look for symbol by name in this scope and host (depending on imports).
+ // Be advised: when the scope is a derived type, the search begins in its
+ // enclosing scope and will not match any component or parameter of the
+ // derived type; use find() instead when seeking those.
Symbol *FindSymbol(const SourceName &) const;
/// Make a Symbol with unknown details.
Scope *FindSubmodule(const SourceName &) const;
bool AddSubmodule(const SourceName &, Scope &);
- DerivedTypeSpec &MakeDerivedType(const Symbol &);
+ DeclTypeSpec &MakeDerivedType(const Symbol &);
- const DeclTypeSpec &MakeNumericType(TypeCategory, int kind);
- const DeclTypeSpec &MakeLogicalType(int kind);
- const DeclTypeSpec &MakeCharacterType(ParamValue &&length, int kind = 0);
- const DeclTypeSpec &MakeDerivedType(
- DeclTypeSpec::Category, const DerivedTypeSpec &);
+ const DeclTypeSpec &MakeNumericType(TypeCategory, KindExpr &&kind);
+ const DeclTypeSpec &MakeLogicalType(KindExpr &&kind);
+ const DeclTypeSpec &MakeCharacterType(
+ ParamValue &&length, KindExpr &&kind = KindExpr{0});
+ const DeclTypeSpec &MakeDerivedType(DeclTypeSpec::Category, DerivedTypeSpec &&);
const DeclTypeSpec &MakeTypeStarType();
const DeclTypeSpec &MakeClassStarType();
void add_importName(const SourceName &);
+ const DerivedTypeSpec *derivedTypeSpec() const { return derivedTypeSpec_; }
+ void set_derivedTypeSpec(const DerivedTypeSpec &spec) {
+ derivedTypeSpec_ = &spec;
+ }
+
// The range of the source of this and nested scopes.
const parser::CharBlock &sourceRange() const { return sourceRange_; }
void AddSourceRange(const parser::CharBlock &);
// Find the smallest scope under this one that contains source
const Scope *FindScope(const parser::CharBlock &) const;
+ // Attempts to find a match for a derived type instance
+ const DeclTypeSpec *FindInstantiatedDerivedType(
+ const DerivedTypeSpec &, DeclTypeSpec::Category) const;
+
+ // Returns a matching derived type instance if one exists, otherwise
+ // creates one
+ const DeclTypeSpec &FindOrInstantiateDerivedType(
+ DerivedTypeSpec &&, DeclTypeSpec::Category, evaluate::FoldingContext &);
+
+ // Clones a DerivedType scope into a new derived type instance's scope.
+ void InstantiateDerivedType(Scope &, evaluate::FoldingContext &) const;
+
+ const DeclTypeSpec &InstantiateIntrinsicType(
+ const DeclTypeSpec &, evaluate::FoldingContext &);
+
private:
- Scope &parent_;
+ Scope &parent_; // this is enclosing scope, not extended derived type base
const Kind kind_;
parser::CharBlock sourceRange_;
- Symbol *const symbol_;
+ Symbol *const symbol_; // if not null, symbol_->scope() == this
std::list<Scope> children_;
mapType symbols_;
std::map<SourceName, Scope *> submodules_;
std::list<DeclTypeSpec> declTypeSpecs_;
- std::list<CharacterTypeSpec> characterTypeSpecs_;
- std::list<DerivedTypeSpec> derivedTypeSpecs_;
std::string chars_;
std::optional<ImportKind> importKind_;
std::set<SourceName> importNames_;
+ const DerivedTypeSpec *derivedTypeSpec_{nullptr}; // dTS->scope() == this
+ // When additional data members are added to Scope, remember to
+ // copy them, if appropriate, in InstantiateDerivedType().
// Storage for all Symbols. Every Symbol is in allSymbols and every Symbol*
// or Symbol& points to one in there.
// limitations under the License.
#include "semantics.h"
+#include "assignment.h"
#include "canonicalize-do.h"
#include "check-do-concurrent.h"
#include "default-kinds.h"
if (kind == 0) {
kind = defaultKinds_.GetDefaultKind(category);
}
- return globalScope_.MakeNumericType(category, kind);
+ return globalScope_.MakeNumericType(category, KindExpr{kind});
}
const DeclTypeSpec &SemanticsContext::MakeLogicalType(int kind) {
if (kind == 0) {
kind = defaultKinds_.GetDefaultKind(TypeCategory::Logical);
}
- return globalScope_.MakeLogicalType(kind);
+ return globalScope_.MakeLogicalType(KindExpr{kind});
}
bool SemanticsContext::AnyFatalError() const {
}
if (context_.debugExpressions()) {
AnalyzeExpressions(program_, context_);
+ AnalyzeAssignments(program_, context_);
}
return !AnyFatalError();
}
return os;
}
-Symbol &Symbol::Instantiate(Scope &scope, const DerivedTypeSpec &spec,
- evaluate::FoldingContext &foldingContext) const {
+Symbol &Symbol::Instantiate(
+ Scope &scope, evaluate::FoldingContext &foldingContext) const {
+ CHECK(foldingContext.pdtInstance != nullptr);
+ const DerivedTypeSpec &instanceSpec{*foldingContext.pdtInstance};
auto pair{scope.try_emplace(name_, attrs_)};
Symbol &symbol{*pair.first->second};
if (!pair.second) {
// Symbol was already present in the scope, which can only happen
- // in the case of type parameters that had actual values present in
- // the derived type spec.
+ // in the case of type parameters with actual or default values.
get<TypeParamDetails>(); // confirm or crash with message
return symbol;
}
[&](const ObjectEntityDetails &that) {
symbol.details_ = that;
ObjectEntityDetails &details{symbol.get<ObjectEntityDetails>()};
+ if (DeclTypeSpec * origType{symbol.GetType()}) {
+ if (const DerivedTypeSpec * derived{origType->AsDerived()}) {
+ DerivedTypeSpec newSpec{*derived};
+ if (test(Flag::ParentComp)) {
+ // Forward all explicit type parameter values from the
+ // derived type spec under instantiation to this parent
+ // component spec when they define type parameters that
+ // pertain to the parent component.
+ for (const auto &pair : instanceSpec.parameters()) {
+ if (scope.find(pair.first) == scope.end()) {
+ newSpec.AddParamValue(
+ pair.first, ParamValue{pair.second});
+ }
+ }
+ }
+ details.ReplaceType(scope.FindOrInstantiateDerivedType(
+ std::move(newSpec), origType->category(), foldingContext));
+ } else if (origType->AsIntrinsic() != nullptr) {
+ const DeclTypeSpec &newType{
+ scope.InstantiateIntrinsicType(*origType, foldingContext)};
+ details.ReplaceType(newType);
+ } else {
+ common::die("instantiated component has type that is "
+ "neither intrinsic nor derived");
+ }
+ }
details.set_init(
evaluate::Fold(foldingContext, std::move(details.init())));
for (ShapeSpec &dim : details.shape()) {
},
[&](const ProcBindingDetails &that) {
symbol.details_ = ProcBindingDetails{
- that.symbol().Instantiate(scope, spec, foldingContext)};
+ that.symbol().Instantiate(scope, foldingContext)};
},
[&](const GenericBindingDetails &that) {
symbol.details_ = GenericBindingDetails{};
GenericBindingDetails &details{symbol.get<GenericBindingDetails>()};
for (const Symbol *sym : that.specificProcs()) {
- details.add_specificProc(
- sym->Instantiate(scope, spec, foldingContext));
+ details.add_specificProc(sym->Instantiate(scope, foldingContext));
}
},
[&](const TypeParamDetails &that) {
+ // LEN type parameter, or error recovery on a KIND type parameter
+ // with no corresponding actual argument or default
symbol.details_ = that;
- TypeParamDetails &details{symbol.get<TypeParamDetails>()};
- details.set_init(
- evaluate::Fold(foldingContext, std::move(details.init())));
},
- [&](const FinalProcDetails &that) { symbol.details_ = that; },
- [&](const auto &) {
- get<ObjectEntityDetails>(); // crashes with actual details
+ [&](const auto &that) {
+ common::die("unexpected details in Symbol::Instantiate");
},
},
details_);
return symbol;
}
-const Symbol *Symbol::GetParent() const {
+const Symbol *Symbol::GetParentComponent(const Scope *scope) const {
const auto &details{get<DerivedTypeDetails>()};
- CHECK(scope_ != nullptr);
- if (!details.extends().empty()) {
- auto iter{scope_->find(details.extends())};
- CHECK(iter != scope_->end());
- const Symbol &parentComp{*iter->second};
- CHECK(parentComp.test(Symbol::Flag::ParentComp));
- const auto &object{parentComp.get<ObjectEntityDetails>()};
- const DerivedTypeSpec *derived{object.type()->AsDerived()};
- CHECK(derived != nullptr);
- return &derived->typeSymbol();
+ if (scope == nullptr) {
+ CHECK(scope_ != nullptr);
+ scope = scope_;
+ }
+ if (details.extends().empty()) {
+ return nullptr;
+ }
+ auto iter{scope->find(details.extends())};
+ CHECK(iter != scope->end());
+ const Symbol &parentComp{*iter->second};
+ CHECK(parentComp.test(Symbol::Flag::ParentComp));
+ return &parentComp;
+}
+
+const DerivedTypeSpec *Symbol::GetParentTypeSpec(const Scope *scope) const {
+ if (const Symbol * parentComponent{GetParentComponent(scope)}) {
+ const auto &object{parentComponent->get<ObjectEntityDetails>()};
+ const DerivedTypeSpec *spec{object.type()->AsDerived()};
+ CHECK(spec != nullptr);
+ return spec;
+ } else {
+ return nullptr;
}
- return nullptr;
}
std::list<SourceName> DerivedTypeDetails::OrderParameterNames(
const Symbol &type) const {
std::list<SourceName> result;
- if (const Symbol * parent{type.GetParent()}) {
- result = parent->get<DerivedTypeDetails>().OrderParameterNames(*parent);
+ if (const DerivedTypeSpec * spec{type.GetParentTypeSpec()}) {
+ const DerivedTypeDetails &details{
+ spec->typeSymbol().get<DerivedTypeDetails>()};
+ result = details.OrderParameterNames(spec->typeSymbol());
}
for (const auto &name : paramNames_) {
result.push_back(name);
std::list<Symbol *> DerivedTypeDetails::OrderParameterDeclarations(
const Symbol &type) const {
std::list<Symbol *> result;
- if (const Symbol * parent{type.GetParent()}) {
- result =
- parent->get<DerivedTypeDetails>().OrderParameterDeclarations(*parent);
+ if (const DerivedTypeSpec * spec{type.GetParentTypeSpec()}) {
+ const DerivedTypeDetails &details{
+ spec->typeSymbol().get<DerivedTypeDetails>()};
+ result = details.OrderParameterDeclarations(spec->typeSymbol());
}
for (Symbol *symbol : paramDecls_) {
result.push_back(symbol);
int Rank() const;
// Clones the Symbol in the context of a parameterized derived type instance
- Symbol &Instantiate(
- Scope &, const DerivedTypeSpec &, evaluate::FoldingContext &) const;
+ Symbol &Instantiate(Scope &, evaluate::FoldingContext &) const;
- // If the symbol refers to a derived type with a parent component,
- // return the symbol of the parent component's derived type.
- const Symbol *GetParent() const;
+ // If there is a parent component, return a pointer to its
+ // derived type spec.
+ // The Scope * argument defaults to this->scope_ but should be overridden
+ // for a parameterized derived type instantiation with the instance's scope.
+ const DerivedTypeSpec *GetParentTypeSpec(const Scope * = nullptr) const;
private:
const Scope *owner_;
const std::string GetDetailsName() const;
friend std::ostream &operator<<(std::ostream &, const Symbol &);
friend std::ostream &DumpForUnparse(std::ostream &, const Symbol &, bool);
+
+ // If the symbol refers to a derived type with a parent component,
+ // return that parent component's symbol.
+ const Symbol *GetParentComponent(const Scope * = nullptr) const;
+
template<std::size_t> friend class Symbols;
template<class, std::size_t> friend struct std::array;
};
#include "../evaluate/tools.h"
#include "../evaluate/type.h"
#include "../parser/characters.h"
+#include <algorithm>
+#include <sstream>
namespace Fortran::semantics {
+DerivedTypeSpec::DerivedTypeSpec(const DerivedTypeSpec &that)
+ : typeSymbol_{that.typeSymbol_}, parameters_{that.parameters_} {}
+
+DerivedTypeSpec::DerivedTypeSpec(DerivedTypeSpec &&that)
+ : typeSymbol_{that.typeSymbol_}, parameters_{std::move(that.parameters_)} {}
+
void DerivedTypeSpec::set_scope(const Scope &scope) {
CHECK(!scope_);
CHECK(scope.kind() == Scope::Kind::DerivedType);
scope_ = &scope;
}
-void DerivedTypeSpec::AddParamValue(ParamValue &&value) {
- paramValues_.emplace_back(std::nullopt, std::move(value));
+bool DerivedTypeSpec::operator==(const DerivedTypeSpec &that) const {
+ return &typeSymbol_ == &that.typeSymbol_ && parameters_ == that.parameters_;
+}
+
+ParamValue &DerivedTypeSpec::AddParamValue(
+ SourceName name, ParamValue &&value) {
+ auto pair{parameters_.insert(std::make_pair(name, std::move(value)))};
+ CHECK(pair.second); // name was not already present
+ return pair.first->second;
}
-void DerivedTypeSpec::AddParamValue(
- const SourceName &name, ParamValue &&value) {
- paramValues_.emplace_back(name, std::move(value));
+
+ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
+ auto iter{parameters_.find(target)};
+ if (iter != parameters_.end()) {
+ return &iter->second;
+ } else {
+ return nullptr;
+ }
+}
+
+const ParamValue *DerivedTypeSpec::FindParameter(SourceName target) const {
+ auto iter{parameters_.find(target)};
+ if (iter != parameters_.end()) {
+ return &iter->second;
+ } else {
+ return nullptr;
+ }
+}
+
+void DerivedTypeSpec::FoldParameterExpressions(
+ evaluate::FoldingContext &foldingContext) {
+ for (auto &pair : parameters_) {
+ if (MaybeIntExpr expr{pair.second.GetExplicit()}) {
+ pair.second.SetExplicit(evaluate::Fold(foldingContext, std::move(*expr)));
+ }
+ }
+}
+
+void DerivedTypeSpec::Instantiate(
+ Scope &containingScope, evaluate::FoldingContext &origFoldingContext) {
+ CHECK(scope_ == nullptr);
+ Scope &newScope{containingScope.MakeScope(Scope::Kind::DerivedType)};
+ newScope.set_derivedTypeSpec(*this);
+ scope_ = &newScope;
+ const DerivedTypeDetails &typeDetails{typeSymbol_.get<DerivedTypeDetails>()};
+
+ // Evaluate any necessary default initial value expressions for those
+ // type parameters that lack explicit initialization. These expressions
+ // are evaluated in the scope of the derived type instance and follow the
+ // order in which their declarations appeared so as to allow later
+ // parameter values to depend on those of their predecessors.
+ // The folded values of the expressions replace the init() expressions
+ // of the parameters' symbols in the instantiation's scope.
+ evaluate::FoldingContext foldingContext{origFoldingContext};
+ foldingContext.pdtInstance = this;
+
+ for (Symbol *symbol : typeDetails.OrderParameterDeclarations(typeSymbol_)) {
+ const SourceName &name{symbol->name()};
+ const TypeParamDetails &details{symbol->get<TypeParamDetails>()};
+ MaybeIntExpr expr;
+ ParamValue *paramValue{FindParameter(name)};
+ if (paramValue != nullptr) {
+ expr = paramValue->GetExplicit();
+ } else {
+ expr = details.init();
+ expr = evaluate::Fold(foldingContext, std::move(expr));
+ }
+ // Ensure that any kind type parameters are constant by now.
+ if (details.attr() == common::TypeParamAttr::Kind && expr.has_value()) {
+ // Any errors in rank and type will have already elicited messages, so
+ // don't complain further here.
+ if (auto maybeDynamicType{expr->GetType()}) {
+ if (expr->Rank() == 0 &&
+ maybeDynamicType->category == TypeCategory::Integer &&
+ !evaluate::ToInt64(expr).has_value()) {
+ std::stringstream fortran;
+ expr->AsFortran(fortran);
+ if (auto *msg{foldingContext.messages.Say(
+ "Value of kind type parameter '%s' (%s) is not "
+ "scalar INTEGER constant"_err_en_US,
+ name.ToString().data(), fortran.str().data())}) {
+ msg->Attach(name, "declared here"_en_US);
+ }
+ }
+ }
+ }
+ if (expr.has_value()) {
+ const Scope *typeScope{typeSymbol_.scope()};
+ if (typeScope != nullptr &&
+ typeScope->find(symbol->name()) != typeScope->end()) {
+ // This type parameter belongs to the derived type itself, not
+ // one of its parents. Put the type parameter expression value
+ // into the new scope as the initialization value for the parameter
+ // so that type parameter inquiries can acquire it.
+ TypeParamDetails instanceDetails{details.attr()};
+ instanceDetails.set_init(std::move(*expr));
+ Symbol *parameter{newScope.try_emplace(name, std::move(instanceDetails))
+ .first->second};
+ CHECK(parameter != nullptr);
+ } else if (paramValue != nullptr) {
+ // Update the type parameter value in the spec for parent component
+ // derived type instantiation later (in symbol.cc) and folding.
+ paramValue->SetExplicit(std::move(*expr));
+ } else {
+ // Save the resolved value in the spec in case folding needs it.
+ AddParamValue(symbol->name(), ParamValue{std::move(*expr)});
+ }
+ }
+ }
+
+ // Instantiate every non-parameter symbol from the original derived
+ // type's scope into the new instance.
+ const Scope *typeScope{typeSymbol_.scope()};
+ CHECK(typeScope != nullptr);
+ typeScope->InstantiateDerivedType(newScope, foldingContext);
}
std::ostream &operator<<(std::ostream &o, const DerivedTypeSpec &x) {
o << x.typeSymbol().name().ToString();
- if (!x.paramValues_.empty()) {
- bool first = true;
+ if (!x.parameters_.empty()) {
o << '(';
- for (const auto &[name, value] : x.paramValues_) {
+ bool first = true;
+ for (const auto &[name, value] : x.parameters_) {
if (first) {
first = false;
} else {
o << ',';
}
- if (name) {
- o << name->ToString() << '=';
- }
- o << value;
+ o << name.ToString() << '=' << value;
}
o << ')';
}
return o;
}
-Bound::Bound(int bound)
- : category_{Category::Explicit},
- expr_{evaluate::Expr<evaluate::SubscriptInteger>{bound}} {}
+Bound::Bound(int bound) : expr_{bound} {}
std::ostream &operator<<(std::ostream &o, const Bound &x) {
if (x.isAssumed()) {
: ParamValue(SomeIntExpr{evaluate::Expr<evaluate::SubscriptInteger>{value}}) {
}
+void ParamValue::SetExplicit(SomeIntExpr &&x) {
+ category_ = Category::Explicit;
+ expr_ = std::move(x);
+}
+
+bool ParamValue::operator==(const ParamValue &that) const {
+ return category_ == that.category_ && expr_ == that.expr_;
+}
+
std::ostream &operator<<(std::ostream &o, const ParamValue &x) {
if (x.isAssumed()) {
o << '*';
return o;
}
-IntrinsicTypeSpec::IntrinsicTypeSpec(TypeCategory category, int kind)
- : category_{category}, kind_{kind} {
+IntrinsicTypeSpec::IntrinsicTypeSpec(TypeCategory category, KindExpr &&kind)
+ : category_{category}, kind_{std::move(kind)} {
CHECK(category != TypeCategory::Derived);
- CHECK(kind > 0);
}
std::ostream &operator<<(std::ostream &os, const IntrinsicTypeSpec &x) {
os << parser::ToUpperCaseLetters(common::EnumToString(x.category()));
- if (x.kind() != 0) {
- os << '(' << x.kind() << ')';
+ if (auto k{evaluate::ToInt64(x.kind())}) {
+ return os << '(' << *k << ')'; // emit unsuffixed kind code
+ } else {
+ return x.kind().AsFortran(os << '(') << ')';
}
- return os;
}
std::ostream &operator<<(std::ostream &os, const CharacterTypeSpec &x) {
- return os << "CHARACTER(" << x.length() << ',' << x.kind() << ')';
+ os << "CHARACTER(" << x.length() << ',';
+ if (auto k{evaluate::ToInt64(x.kind())}) {
+ return os << *k << ')'; // emit unsuffixed kind code
+ } else {
+ return x.kind().AsFortran(os) << ')';
+ }
}
-DeclTypeSpec::DeclTypeSpec(const NumericTypeSpec &typeSpec)
- : category_{Numeric}, typeSpec_{typeSpec} {}
-DeclTypeSpec::DeclTypeSpec(const LogicalTypeSpec &typeSpec)
- : category_{Logical}, typeSpec_{typeSpec} {}
-DeclTypeSpec::DeclTypeSpec(CharacterTypeSpec &typeSpec)
- : category_{Character}, typeSpec_{&typeSpec} {}
+DeclTypeSpec::DeclTypeSpec(NumericTypeSpec &&typeSpec)
+ : category_{Numeric}, typeSpec_{std::move(typeSpec)} {}
+DeclTypeSpec::DeclTypeSpec(LogicalTypeSpec &&typeSpec)
+ : category_{Logical}, typeSpec_{std::move(typeSpec)} {}
+DeclTypeSpec::DeclTypeSpec(const CharacterTypeSpec &typeSpec)
+ : category_{Character}, typeSpec_{typeSpec} {}
+DeclTypeSpec::DeclTypeSpec(CharacterTypeSpec &&typeSpec)
+ : category_{Character}, typeSpec_{std::move(typeSpec)} {}
DeclTypeSpec::DeclTypeSpec(Category category, const DerivedTypeSpec &typeSpec)
- : category_{category}, typeSpec_{&typeSpec} {
+ : category_{category}, typeSpec_{typeSpec} {
+ CHECK(category == TypeDerived || category == ClassDerived);
+}
+DeclTypeSpec::DeclTypeSpec(Category category, DerivedTypeSpec &&typeSpec)
+ : category_{category}, typeSpec_{std::move(typeSpec)} {
CHECK(category == TypeDerived || category == ClassDerived);
}
DeclTypeSpec::DeclTypeSpec(Category category) : category_{category} {
bool DeclTypeSpec::IsNumeric(TypeCategory tc) const {
return category_ == Numeric && numericTypeSpec().category() == tc;
}
+IntrinsicTypeSpec *DeclTypeSpec::AsIntrinsic() {
+ switch (category_) {
+ case Numeric: return &std::get<NumericTypeSpec>(typeSpec_);
+ case Logical: return &std::get<LogicalTypeSpec>(typeSpec_);
+ case Character: return &std::get<CharacterTypeSpec>(typeSpec_);
+ default: return nullptr;
+ }
+}
const IntrinsicTypeSpec *DeclTypeSpec::AsIntrinsic() const {
switch (category_) {
- case Numeric: return &typeSpec_.numeric;
- case Logical: return &typeSpec_.logical;
- case Character: return typeSpec_.character;
+ case Numeric: return &std::get<NumericTypeSpec>(typeSpec_);
+ case Logical: return &std::get<LogicalTypeSpec>(typeSpec_);
+ case Character: return &std::get<CharacterTypeSpec>(typeSpec_);
default: return nullptr;
}
}
const DerivedTypeSpec *DeclTypeSpec::AsDerived() const {
switch (category_) {
case TypeDerived:
- case ClassDerived: return typeSpec_.derived;
+ case ClassDerived: return &std::get<DerivedTypeSpec>(typeSpec_);
default: return nullptr;
}
}
const NumericTypeSpec &DeclTypeSpec::numericTypeSpec() const {
CHECK(category_ == Numeric);
- return typeSpec_.numeric;
+ return std::get<NumericTypeSpec>(typeSpec_);
}
const LogicalTypeSpec &DeclTypeSpec::logicalTypeSpec() const {
CHECK(category_ == Logical);
- return typeSpec_.logical;
+ return std::get<LogicalTypeSpec>(typeSpec_);
}
const CharacterTypeSpec &DeclTypeSpec::characterTypeSpec() const {
CHECK(category_ == Character);
- return *typeSpec_.character;
+ return std::get<CharacterTypeSpec>(typeSpec_);
}
const DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() const {
CHECK(category_ == TypeDerived || category_ == ClassDerived);
- return *typeSpec_.derived;
+ return std::get<DerivedTypeSpec>(typeSpec_);
+}
+DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() {
+ CHECK(category_ == TypeDerived || category_ == ClassDerived);
+ return std::get<DerivedTypeSpec>(typeSpec_);
}
bool DeclTypeSpec::operator==(const DeclTypeSpec &that) const {
- if (category_ != that.category_) {
- return false;
- }
- switch (category_) {
- case Numeric: return typeSpec_.numeric == that.typeSpec_.numeric;
- case Logical: return typeSpec_.logical == that.typeSpec_.logical;
- case Character: return typeSpec_.character == that.typeSpec_.character;
- case TypeDerived:
- case ClassDerived: return typeSpec_.derived == that.typeSpec_.derived;
- default: return true;
- }
+ return category_ == that.category_ && typeSpec_ == that.typeSpec_;
}
std::ostream &operator<<(std::ostream &o, const DeclTypeSpec &x) {
struct Expr;
}
+namespace Fortran::evaluate {
+struct FoldingContext;
+}
+
namespace Fortran::semantics {
class Scope;
using MaybeIntExpr = std::optional<SomeIntExpr>;
using SubscriptIntExpr = evaluate::Expr<evaluate::SubscriptInteger>;
using MaybeSubscriptIntExpr = std::optional<SubscriptIntExpr>;
+using KindExpr = SubscriptIntExpr;
// An array spec bound: an explicit integer expression or ASSUMED or DEFERRED
class Bound {
// A type parameter value: integer expression or assumed or deferred.
class ParamValue {
public:
- static ParamValue Assumed() { return Category::Assumed; }
- static ParamValue Deferred() { return Category::Deferred; }
- explicit ParamValue(MaybeIntExpr &&expr);
+ static constexpr ParamValue Assumed() { return Category::Assumed; }
+ static constexpr ParamValue Deferred() { return Category::Deferred; }
+ ParamValue(const ParamValue &) = default;
+ explicit ParamValue(MaybeIntExpr &&);
explicit ParamValue(std::int64_t);
bool isExplicit() const { return category_ == Category::Explicit; }
bool isAssumed() const { return category_ == Category::Assumed; }
bool isDeferred() const { return category_ == Category::Deferred; }
const MaybeIntExpr &GetExplicit() const { return expr_; }
+ void SetExplicit(SomeIntExpr &&);
+ bool operator==(const ParamValue &) const;
private:
enum class Category { Explicit, Deferred, Assumed };
class IntrinsicTypeSpec {
public:
TypeCategory category() const { return category_; }
- int kind() const { return kind_; }
+ const KindExpr &kind() const { return kind_; }
bool operator==(const IntrinsicTypeSpec &x) const {
return category_ == x.category_ && kind_ == x.kind_;
}
bool operator!=(const IntrinsicTypeSpec &x) const { return !operator==(x); }
protected:
- IntrinsicTypeSpec(TypeCategory, int kind);
+ IntrinsicTypeSpec(TypeCategory, KindExpr &&);
private:
TypeCategory category_;
- int kind_;
+ KindExpr kind_;
friend std::ostream &operator<<(std::ostream &os, const IntrinsicTypeSpec &x);
};
class NumericTypeSpec : public IntrinsicTypeSpec {
public:
- NumericTypeSpec(TypeCategory category, int kind)
- : IntrinsicTypeSpec(category, kind) {
+ NumericTypeSpec(TypeCategory category, KindExpr &&kind)
+ : IntrinsicTypeSpec(category, std::move(kind)) {
CHECK(category == TypeCategory::Integer || category == TypeCategory::Real ||
category == TypeCategory::Complex);
}
class LogicalTypeSpec : public IntrinsicTypeSpec {
public:
- LogicalTypeSpec(int kind) : IntrinsicTypeSpec(TypeCategory::Logical, kind) {}
+ explicit LogicalTypeSpec(KindExpr &&kind)
+ : IntrinsicTypeSpec(TypeCategory::Logical, std::move(kind)) {}
};
class CharacterTypeSpec : public IntrinsicTypeSpec {
public:
- CharacterTypeSpec(ParamValue &&length, int kind)
- : IntrinsicTypeSpec(TypeCategory::Character, kind), length_{std::move(
- length)} {}
+ CharacterTypeSpec(ParamValue &&length, KindExpr &&kind)
+ : IntrinsicTypeSpec(TypeCategory::Character, std::move(kind)),
+ length_{std::move(length)} {}
const ParamValue length() const { return length_; }
private:
class DerivedTypeSpec {
public:
- using listType = std::list<std::pair<std::optional<SourceName>, ParamValue>>;
- DerivedTypeSpec &operator=(const DerivedTypeSpec &) = delete;
explicit DerivedTypeSpec(const Symbol &symbol) : typeSymbol_{symbol} {}
- DerivedTypeSpec() = delete;
+ DerivedTypeSpec(const DerivedTypeSpec &);
+ DerivedTypeSpec(DerivedTypeSpec &&);
+
const Symbol &typeSymbol() const { return typeSymbol_; }
const Scope *scope() const { return scope_; }
void set_scope(const Scope &);
- listType ¶mValues() { return paramValues_; }
- const listType ¶mValues() const { return paramValues_; }
- void AddParamValue(ParamValue &&);
- void AddParamValue(const SourceName &, ParamValue &&);
+ const std::map<SourceName, ParamValue> ¶meters() const {
+ return parameters_;
+ }
+
+ bool HasActualParameters() const { return !parameters_.empty(); }
+ ParamValue &AddParamValue(SourceName, ParamValue &&);
+ ParamValue *FindParameter(SourceName);
+ const ParamValue *FindParameter(SourceName) const;
+ void FoldParameterExpressions(evaluate::FoldingContext &);
+ void Instantiate(Scope &, evaluate::FoldingContext &);
+ bool operator==(const DerivedTypeSpec &) const; // for std::find()
private:
const Symbol &typeSymbol_;
- const Scope *scope_{nullptr};
- listType paramValues_;
+ const Scope *scope_{nullptr}; // same as typeSymbol_.scope() unless PDT
+ std::map<SourceName, ParamValue> parameters_;
friend std::ostream &operator<<(std::ostream &, const DerivedTypeSpec &);
};
};
// intrinsic-type-spec or TYPE(intrinsic-type-spec), not character
- DeclTypeSpec(const NumericTypeSpec &);
- DeclTypeSpec(const LogicalTypeSpec &);
+ DeclTypeSpec(NumericTypeSpec &&);
+ DeclTypeSpec(LogicalTypeSpec &&);
// character
- DeclTypeSpec(CharacterTypeSpec &);
+ DeclTypeSpec(const CharacterTypeSpec &);
+ DeclTypeSpec(CharacterTypeSpec &&);
// TYPE(derived-type-spec) or CLASS(derived-type-spec)
DeclTypeSpec(Category, const DerivedTypeSpec &);
+ DeclTypeSpec(Category, DerivedTypeSpec &&);
// TYPE(*) or CLASS(*)
DeclTypeSpec(Category);
- DeclTypeSpec() = delete;
bool operator==(const DeclTypeSpec &) const;
bool operator!=(const DeclTypeSpec &that) const { return !operator==(that); }
Category category() const { return category_; }
+ void set_category(Category category) { category_ = category; }
bool IsNumeric(TypeCategory) const;
+ IntrinsicTypeSpec *AsIntrinsic();
const IntrinsicTypeSpec *AsIntrinsic() const;
const DerivedTypeSpec *AsDerived() const;
const NumericTypeSpec &numericTypeSpec() const;
const LogicalTypeSpec &logicalTypeSpec() const;
const CharacterTypeSpec &characterTypeSpec() const;
const DerivedTypeSpec &derivedTypeSpec() const;
- void set_category(Category category) { category_ = category; }
+ DerivedTypeSpec &derivedTypeSpec();
private:
Category category_;
- union TypeSpec {
- TypeSpec() : derived{nullptr} {}
- TypeSpec(NumericTypeSpec numeric) : numeric{numeric} {}
- TypeSpec(LogicalTypeSpec logical) : logical{logical} {}
- TypeSpec(const CharacterTypeSpec *character) : character{character} {}
- TypeSpec(const DerivedTypeSpec *derived) : derived{derived} {}
- NumericTypeSpec numeric;
- LogicalTypeSpec logical;
- const CharacterTypeSpec *character;
- const DerivedTypeSpec *derived;
- } typeSpec_;
+ std::variant<std::monostate, NumericTypeSpec, LogicalTypeSpec,
+ CharacterTypeSpec, DerivedTypeSpec>
+ typeSpec_;
};
std::ostream &operator<<(std::ostream &, const DeclTypeSpec &);
const DeclTypeSpec *type_{nullptr};
};
}
-
#endif // FORTRAN_SEMANTICS_TYPE_H_
implicit06.f90
implicit07.f90
implicit08.f90
+ kinds02.f90
resolve01.f90
resolve02.f90
resolve03.f90
symbol09.f90
symbol10.f90
symbol11.f90
+ kinds01.f90
+ kinds03.f90
)
# These test files have expected .mod file contents in the source
modfile14.f90
modfile15.f90
modfile16.f90
+ modfile17.f90
)
set(LABEL_TESTS
--- /dev/null
+! Copyright (c) 2018, 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.
+
+ !DEF: /MainProgram1/jk1 ObjectEntity INTEGER(1)
+ integer(kind=1) jk1
+ !DEF: /MainProgram1/js1 ObjectEntity INTEGER(1)
+ integer*1 js1
+ !DEF: /MainProgram1/jk2 ObjectEntity INTEGER(2)
+ integer(kind=2) jk2
+ !DEF: /MainProgram1/js2 ObjectEntity INTEGER(2)
+ integer*2 js2
+ !DEF: /MainProgram1/jk4 ObjectEntity INTEGER(4)
+ integer(kind=4) jk4
+ !DEF: /MainProgram1/js4 ObjectEntity INTEGER(4)
+ integer*4 js4
+ !DEF: /MainProgram1/jk8 ObjectEntity INTEGER(8)
+ integer(kind=8) jk8
+ !DEF: /MainProgram1/js8 ObjectEntity INTEGER(8)
+ integer*8 js8
+ !DEF: /MainProgram1/jk16 ObjectEntity INTEGER(16)
+ integer(kind=16) jk16
+ !DEF: /MainProgram1/js16 ObjectEntity INTEGER(16)
+ integer*16 js16
+ !DEF: /MainProgram1/ak2 ObjectEntity REAL(2)
+ real(kind=2) ak2
+ !DEF: /MainProgram1/as2 ObjectEntity REAL(2)
+ real*2 as2
+ !DEF: /MainProgram1/ak4 ObjectEntity REAL(4)
+ real(kind=4) ak4
+ !DEF: /MainProgram1/as4 ObjectEntity REAL(4)
+ real*4 as4
+ !DEF: /MainProgram1/ak8 ObjectEntity REAL(8)
+ real(kind=8) ak8
+ !DEF: /MainProgram1/as8 ObjectEntity REAL(8)
+ real*8 as8
+ !DEF: /MainProgram1/dp ObjectEntity REAL(8)
+ double precision dp
+ !DEF: /MainProgram1/ak10 ObjectEntity REAL(10)
+ real(kind=10) ak10
+ !DEF: /MainProgram1/as10 ObjectEntity REAL(10)
+ real*10 as10
+ !DEF: /MainProgram1/ak16 ObjectEntity REAL(16)
+ real(kind=16) ak16
+ !DEF: /MainProgram1/as16 ObjectEntity REAL(16)
+ real*16 as16
+ !DEF: /MainProgram1/zk2 ObjectEntity COMPLEX(2)
+ complex(kind=2) zk2
+ !DEF: /MainProgram1/zs2 ObjectEntity COMPLEX(2)
+ complex*4 zs2
+ !DEF: /MainProgram1/zk4 ObjectEntity COMPLEX(4)
+ complex(kind=4) zk4
+ !DEF: /MainProgram1/zs4 ObjectEntity COMPLEX(4)
+ complex*8 zs4
+ !DEF: /MainProgram1/zk8 ObjectEntity COMPLEX(8)
+ complex(kind=8) zk8
+ !DEF: /MainProgram1/zs8 ObjectEntity COMPLEX(8)
+ complex*16 zs8
+ !DEF: /MainProgram1/zdp ObjectEntity COMPLEX(8)
+ double complex zdp
+ !DEF: /MainProgram1/zk10 ObjectEntity COMPLEX(10)
+ complex(kind=10) zk10
+ !DEF: /MainProgram1/zs10 ObjectEntity COMPLEX(10)
+ complex*20 zs10
+ !DEF: /MainProgram1/zk16 ObjectEntity COMPLEX(16)
+ complex(kind=16) zk16
+ !DEF: /MainProgram1/zs16 ObjectEntity COMPLEX(16)
+ complex*32 zs16
+ !DEF: /MainProgram1/lk1 ObjectEntity LOGICAL(1)
+ logical(kind=1) lk1
+ !DEF: /MainProgram1/ls1 ObjectEntity LOGICAL(1)
+ logical*1 ls1
+ !DEF: /MainProgram1/lk2 ObjectEntity LOGICAL(2)
+ logical(kind=2) lk2
+ !DEF: /MainProgram1/ls2 ObjectEntity LOGICAL(2)
+ logical*2 ls2
+ !DEF: /MainProgram1/lk4 ObjectEntity LOGICAL(4)
+ logical(kind=4) lk4
+ !DEF: /MainProgram1/ls4 ObjectEntity LOGICAL(4)
+ logical*4 ls4
+ !DEF: /MainProgram1/lk8 ObjectEntity LOGICAL(8)
+ logical(kind=8) lk8
+ !DEF: /MainProgram1/ls8 ObjectEntity LOGICAL(8)
+ logical*8 ls8
+end program
--- /dev/null
+! Copyright (c) 2018-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.
+
+!ERROR: INTEGER(KIND=0) is not a supported type
+integer(kind=0) :: j0
+!ERROR: INTEGER(KIND=-1) is not a supported type
+integer(kind=-1) :: jm1
+!ERROR: INTEGER(KIND=3) is not a supported type
+integer(kind=3) :: j3
+!ERROR: INTEGER(KIND=32) is not a supported type
+integer(kind=32) :: j32
+!ERROR: REAL(KIND=0) is not a supported type
+real(kind=0) :: a0
+!ERROR: REAL(KIND=-1) is not a supported type
+real(kind=-1) :: am1
+!ERROR: REAL(KIND=1) is not a supported type
+real(kind=1) :: a1
+!ERROR: REAL(KIND=7) is not a supported type
+real(kind=7) :: a7
+!ERROR: REAL(KIND=32) is not a supported type
+real(kind=32) :: a32
+!ERROR: COMPLEX(KIND=0) is not a supported type
+complex(kind=0) :: z0
+!ERROR: COMPLEX(KIND=-1) is not a supported type
+complex(kind=-1) :: zm1
+!ERROR: COMPLEX(KIND=1) is not a supported type
+complex(kind=1) :: z1
+!ERROR: COMPLEX(KIND=7) is not a supported type
+complex(kind=7) :: z7
+!ERROR: COMPLEX(KIND=32) is not a supported type
+complex(kind=32) :: z32
+!ERROR: COMPLEX*1 is not a supported type
+complex*1 :: zs1
+!ERROR: COMPLEX*2 is not a supported type
+complex*2 :: zs2
+!ERROR: COMPLEX*64 is not a supported type
+complex*64 :: zs64
+!ERROR: LOGICAL(KIND=0) is not a supported type
+logical(kind=0) :: l0
+!ERROR: LOGICAL(KIND=-1) is not a supported type
+logical(kind=-1) :: lm1
+!ERROR: LOGICAL(KIND=3) is not a supported type
+logical(kind=3) :: l3
+!ERROR: LOGICAL(KIND=16) is not a supported type
+logical(kind=16) :: l16
+end program
--- /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.
+
+type ipdt(k)
+ integer, kind :: k
+ integer(kind=k) :: x
+end type ipdt
+
+type rpdt(k)
+ integer, kind :: k
+ real(kind=k) :: x
+end type rpdt
+
+type zpdt(k)
+ integer, kind :: k
+ complex(kind=k) :: x
+end type zpdt
+
+type lpdt(k)
+ integer, kind :: k
+ logical(kind=k) :: x
+end type lpdt
+
+type(ipdt(1)) i1
+type(ipdt(2)) i2
+type(ipdt(4)) i4
+type(ipdt(8)) i8
+type(ipdt(16)) i16
+type(rpdt(2)) a2
+type(rpdt(4)) a4
+type(rpdt(8)) a8
+type(rpdt(10)) a10
+type(rpdt(16)) a16
+type(zpdt(2)) z2
+type(zpdt(4)) z4
+type(zpdt(8)) z8
+type(zpdt(10)) z10
+type(zpdt(16)) z16
+type(lpdt(1)) l1
+type(lpdt(2)) l2
+type(lpdt(4)) l4
+type(lpdt(8)) l8
+
+end program
-! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+! Copyright (c) 2018-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.
! integer(4),kind::c=1_4
! integer(4),len::d=3_8
! end type
-! type(t(4_4,:)),allocatable::z
-! class(t(5_4,:)),allocatable::z2
+! type(t(c=4_4,d=:)),allocatable::z
+! class(t(c=5_4,d=:)),allocatable::z2
! type(*),allocatable::z3
! class(*),allocatable::z4
! real(2)::f
--- /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.
+
+! Tests parameterized derived type instantiation with KIND parameters
+
+module m
+ type :: capture(k1,k2,k4,k8)
+ integer(kind=1), kind :: k1
+ integer(kind=2), kind :: k2
+ integer(kind=4), kind :: k4
+ integer(kind=8), kind :: k8
+ integer(kind=k1) :: j1
+ integer(kind=k2) :: j2
+ integer(kind=k4) :: j4
+ integer(kind=k8) :: j8
+ end type capture
+ type :: defaulted(n1,n2,n4,n8)
+ integer(kind=1), kind :: n1 = 1
+ integer(kind=2), kind :: n2 = n1 * 2
+ integer(kind=4), kind :: n4 = 2 * n2
+ integer(kind=8), kind :: n8 = 12 - n4
+ type(capture(n1,n2,n4,n8)) :: cap
+ end type defaulted
+ type, extends(defaulted) :: extension(k5)
+ integer(kind=4), kind :: k5 = 4
+ integer(kind=k5) :: j5
+ end type extension
+ type(capture(1,1,1,1)) :: x1111
+ integer(kind=x1111%j1%kind) :: res01_1
+ integer(kind=x1111%j2%kind) :: res02_1
+ integer(kind=x1111%j4%kind) :: res03_1
+ integer(kind=x1111%j8%kind) :: res04_1
+ type(capture(8,8,8,8)) :: x8888
+ integer(kind=x8888%j1%kind) :: res05_8
+ integer(kind=x8888%j2%kind) :: res06_8
+ integer(kind=x8888%j4%kind) :: res07_8
+ integer(kind=x8888%j8%kind) :: res08_8
+ type(capture(2,k8=1,k4=8,k2=4)) :: x2481
+ integer(kind=x2481%j1%kind) :: res09_2
+ integer(kind=x2481%j2%kind) :: res10_4
+ integer(kind=x2481%j4%kind) :: res11_8
+ integer(kind=x2481%j8%kind) :: res12_1
+ type(capture(2,1,k4=8,k8=4)) :: x2184
+ integer(kind=x2184%j1%kind) :: res13_2
+ integer(kind=x2184%j2%kind) :: res14_1
+ integer(kind=x2184%j4%kind) :: res15_8
+ integer(kind=x2184%j8%kind) :: res16_4
+ type(defaulted) :: x1248
+ integer(kind=x1248%cap%j1%kind) :: res17_1
+ integer(kind=x1248%cap%j2%kind) :: res18_2
+ integer(kind=x1248%cap%j4%kind) :: res19_4
+ integer(kind=x1248%cap%j8%kind) :: res20_8
+ type(defaulted(2)) :: x2484
+ integer(kind=x2484%cap%j1%kind) :: res21_2
+ integer(kind=x2484%cap%j2%kind) :: res22_4
+ integer(kind=x2484%cap%j4%kind) :: res23_8
+ integer(kind=x2484%cap%j8%kind) :: res24_4
+ type(defaulted(n8=2)) :: x1242
+ integer(kind=x1242%cap%j1%kind) :: res25_1
+ integer(kind=x1242%cap%j2%kind) :: res26_2
+ integer(kind=x1242%cap%j4%kind) :: res27_4
+ integer(kind=x1242%cap%j8%kind) :: res28_2
+ type(extension(1,1,1,1,1)) :: x11111
+ integer(kind=x11111%defaulted%cap%j1%kind) :: res29_1
+ integer(kind=x11111%cap%j2%kind) :: res30_1
+ integer(kind=x11111%cap%j4%kind) :: res31_1
+ integer(kind=x11111%cap%j8%kind) :: res32_1
+ integer(kind=x11111%j5%kind) :: res33_1
+ type(extension(2,8,4,1,8)) :: x28418
+ integer(kind=x28418%defaulted%cap%j1%kind) :: res34_2
+ integer(kind=x28418%cap%j2%kind) :: res35_8
+ integer(kind=x28418%cap%j4%kind) :: res36_4
+ integer(kind=x28418%cap%j8%kind) :: res37_1
+ integer(kind=x28418%j5%kind) :: res38_8
+ type(extension(8,n8=1,k5=2,n2=4,n4=8)) :: x84812
+ integer(kind=x84812%defaulted%cap%j1%kind) :: res39_8
+ integer(kind=x84812%cap%j2%kind) :: res40_4
+ integer(kind=x84812%cap%j4%kind) :: res41_8
+ integer(kind=x84812%cap%j8%kind) :: res42_1
+ integer(kind=x84812%j5%kind) :: res43_2
+ type(extension(k5=2)) :: x12482
+ integer(kind=x12482%defaulted%cap%j1%kind) :: res44_1
+ integer(kind=x12482%cap%j2%kind) :: res45_2
+ integer(kind=x12482%cap%j4%kind) :: res46_4
+ integer(kind=x12482%cap%j8%kind) :: res47_8
+ integer(kind=x12482%j5%kind) :: res48_2
+end module
+
+!Expect: m.mod
+!module m
+!type::capture(k1,k2,k4,k8)
+!integer(1),kind::k1
+!integer(2),kind::k2
+!integer(4),kind::k4
+!integer(8),kind::k8
+!integer(int(k1,kind=8))::j1
+!integer(int(k2,kind=8))::j2
+!integer(int(k4,kind=8))::j4
+!integer(k8)::j8
+!end type
+!type::defaulted(n1,n2,n4,n8)
+!integer(1),kind::n1=1_4
+!integer(2),kind::n2=(int(n1,kind=4)*2_4)
+!integer(4),kind::n4=(2_4*int(n2,kind=4))
+!integer(8),kind::n8=(12_4-n4)
+!type(capture(k1=n1,k2=n2,k4=n4,k8=n8))::cap
+!end type
+!type,extends(defaulted)::extension(k5)
+!integer(4),kind::k5=4_4
+!integer(int(k5,kind=8))::j5
+!end type
+!type(capture(k1=1_4,k2=1_4,k4=1_4,k8=1_4))::x1111
+!integer(1)::res01_1
+!integer(1)::res02_1
+!integer(1)::res03_1
+!integer(1)::res04_1
+!type(capture(k1=8_4,k2=8_4,k4=8_4,k8=8_4))::x8888
+!integer(8)::res05_8
+!integer(8)::res06_8
+!integer(8)::res07_8
+!integer(8)::res08_8
+!type(capture(k1=2_4,k2=4_4,k4=8_4,k8=1_4))::x2481
+!integer(2)::res09_2
+!integer(4)::res10_4
+!integer(8)::res11_8
+!integer(1)::res12_1
+!type(capture(k1=2_4,k2=1_4,k4=8_4,k8=4_4))::x2184
+!integer(2)::res13_2
+!integer(1)::res14_1
+!integer(8)::res15_8
+!integer(4)::res16_4
+!type(defaulted)::x1248
+!integer(1)::res17_1
+!integer(2)::res18_2
+!integer(4)::res19_4
+!integer(8)::res20_8
+!type(defaulted(n1=2_4))::x2484
+!integer(2)::res21_2
+!integer(4)::res22_4
+!integer(8)::res23_8
+!integer(4)::res24_4
+!type(defaulted(n8=2_4))::x1242
+!integer(1)::res25_1
+!integer(2)::res26_2
+!integer(4)::res27_4
+!integer(2)::res28_2
+!type(extension(k5=1_4,n1=1_4,n2=1_4,n4=1_4,n8=1_4))::x11111
+!integer(1)::res29_1
+!integer(1)::res30_1
+!integer(1)::res31_1
+!integer(1)::res32_1
+!integer(1)::res33_1
+!type(extension(k5=8_4,n1=2_4,n2=8_4,n4=4_4,n8=1_4))::x28418
+!integer(2)::res34_2
+!integer(8)::res35_8
+!integer(4)::res36_4
+!integer(1)::res37_1
+!integer(8)::res38_8
+!type(extension(k5=2_4,n1=8_4,n2=4_4,n4=8_4,n8=1_4))::x84812
+!integer(8)::res39_8
+!integer(4)::res40_4
+!integer(8)::res41_8
+!integer(1)::res42_1
+!integer(2)::res43_2
+!type(extension(k5=2_4,n1=1_4,n2=2_4,n4=4_4,n8=8_4))::x12482
+!integer(1)::res44_1
+!integer(2)::res45_2
+!integer(4)::res46_4
+!integer(8)::res47_8
+!integer(2)::res48_2
+!end
-! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+! Copyright (c) 2018-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.
type t(k)
integer, kind :: k
end type
+!ERROR: Type parameter 'k' lacks a value and has no default
+type(t( &
!ERROR: Must have INTEGER type
-type(t(.true.)) :: w
+ .true.)) :: w
!ERROR: Must have INTEGER type
real :: w(l*2)
!ERROR: Must have INTEGER type
-! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+! Copyright (c) 2018-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.
integer :: a
end type t
!REF: /s4/t
- !DEF: /s4/x ObjectEntity TYPE(t(1_4))
+ !DEF: /s4/x ObjectEntity TYPE(t(k=1_4))
type(t(1)) :: x
!REF: /s4/x
!REF: /s4/t
integer, len :: l
end type t
!REF: /s5/t
- !DEF: /s5/x ALLOCATABLE ObjectEntity TYPE(t(:))
+ !DEF: /s5/x ALLOCATABLE ObjectEntity TYPE(t(l=:))
type(t(:)), allocatable :: x
!DEF: /s5/y ALLOCATABLE ObjectEntity REAL(4)
real, allocatable :: y
projects / platform / upstream / llvm.git / commitdiff