From be3b765e2aded4e2a6be603564094534fdf4f6b9 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Tue, 4 Dec 2018 10:55:32 -0800 Subject: [PATCH] [flang] basic skeleton of assignment analyzer remove needless template<> on some function overloads dodge bogus compiler warning from gcc 8.1.0 only stricter typing of expressions in symbols adjust modfile12.f90 expected test results add Unwrap, massage folding a bit Use Unwrap to simplify folding Move KindSelector analysis into expression semantics fix crash checkpoint updates to TypeParamInquiry support of %KIND type parameter inquiry equality testing for expressions checkpoint during PDT implementation reformat checkpoint derived type instantiation checkpoint resolve merge debugging failed tests fix failing resolve37.f90 test all existing tests pass clean up all build warnings fix bug update copyright dates fix copyright dates address review comments review comment merge with master after peeling off changes bugfixing new feature fix warning from old g++s tweaks after merging with latest head more bugfixing making modfile17.f90 test work Make kinds into expressions in symbol table types big refactor for deferring kinds in intrinsic types modfile17.f90 test passes clean up TODOs Simplify types as stored in scopes Test KIND parameter default init expressions, debug them Update copyright dates address comments remove dead line address comments Original-commit: flang-compiler/f18@1f43d0a04813dc02909e9952ee479d13f630df4c Reviewed-on: https://github.com/flang-compiler/f18/pull/260 Tree-same-pre-rewrite: false --- flang/lib/evaluate/call.h | 8 +- flang/lib/evaluate/fold.cc | 138 +++++++++-- flang/lib/evaluate/fold.h | 2 +- flang/lib/evaluate/intrinsics.cc | 2 + flang/lib/evaluate/type.cc | 16 +- flang/lib/evaluate/variable.cc | 6 +- flang/lib/evaluate/variable.h | 7 +- flang/lib/parser/parse-tree-visitor.h | 50 +++- flang/lib/semantics/assignment.cc | 327 ++++++++++++++++++++++--- flang/lib/semantics/assignment.h | 8 +- flang/lib/semantics/dump-parse-tree.h | 53 ++-- flang/lib/semantics/expression.cc | 123 ++++++---- flang/lib/semantics/expression.h | 8 +- flang/lib/semantics/resolve-names.cc | 441 +++++++++++++++++++++------------- flang/lib/semantics/scope.cc | 145 +++++++++-- flang/lib/semantics/scope.h | 58 ++++- flang/lib/semantics/semantics.cc | 6 +- flang/lib/semantics/symbol.cc | 98 +++++--- flang/lib/semantics/symbol.h | 16 +- flang/lib/semantics/type.cc | 230 ++++++++++++++---- flang/lib/semantics/type.h | 86 ++++--- flang/test/semantics/CMakeLists.txt | 4 + flang/test/semantics/kinds01.f90 | 95 ++++++++ flang/test/semantics/kinds02.f90 | 57 +++++ flang/test/semantics/kinds03.f90 | 55 +++++ flang/test/semantics/modfile12.f90 | 6 +- flang/test/semantics/modfile17.f90 | 182 ++++++++++++++ flang/test/semantics/resolve37.f90 | 6 +- flang/test/semantics/symbol09.f90 | 6 +- 29 files changed, 1771 insertions(+), 468 deletions(-) create mode 100644 flang/test/semantics/kinds01.f90 create mode 100644 flang/test/semantics/kinds02.f90 create mode 100644 flang/test/semantics/kinds03.f90 create mode 100644 flang/test/semantics/modfile17.f90 diff --git a/flang/lib/evaluate/call.h b/flang/lib/evaluate/call.h index fc65810..d2c593f 100644 --- a/flang/lib/evaluate/call.h +++ b/flang/lib/evaluate/call.h @@ -1,4 +1,4 @@ -// 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. @@ -58,13 +58,17 @@ using ActualArguments = std::vector>; // 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 &&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; diff --git a/flang/lib/evaluate/fold.cc b/flang/lib/evaluate/fold.cc index 8f2eb39..aa5b571a 100644 --- a/flang/lib/evaluate/fold.cc +++ b/flang/lib/evaluate/fold.cc @@ -49,7 +49,7 @@ CoarrayRef FoldOperation(FoldingContext &, CoarrayRef &&); DataRef FoldOperation(FoldingContext &, DataRef &&); Substring FoldOperation(FoldingContext &, Substring &&); ComplexPart FoldOperation(FoldingContext &, ComplexPart &&); - +template Expr FoldOperation(FoldingContext &, FunctionRef &&); template Expr FoldOperation(FoldingContext &, Designator &&); template Expr> FoldOperation( @@ -153,6 +153,37 @@ ComplexPart FoldOperation(FoldingContext &context, ComplexPart &&complexPart) { } template +Expr FoldOperation(FoldingContext &context, FunctionRef &&funcRef) { + ActualArguments args{std::move(funcRef.arguments())}; + for (std::optional &arg : args) { + if (arg.has_value()) { + *arg->value = FoldOperation(context, std::move(*arg->value)); + } + } + if (auto *intrinsic{std::get_if(&funcRef.proc().u)}) { + std::string name{intrinsic->name}; + if (name == "kind") { + if constexpr (common::HasMember) { + return Expr{args[0]->value->GetType()->kind}; + } else { + common::die("kind() result not integral"); + } + } else if (name == "len") { + if constexpr (std::is_same_v) { + if (auto *charExpr{UnwrapExpr>(*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{FunctionRef{std::move(funcRef.proc()), std::move(args)}}; +} + +template Expr FoldOperation(FoldingContext &context, Designator &&designator) { if constexpr (T::category == TypeCategory::Character) { if (auto *substring{common::Unwrap(designator.u)}) { @@ -193,21 +224,29 @@ Expr> FoldOperation( 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()}; - CHECK(details != nullptr); - CHECK(details->init().has_value()); - Expr expr{*details->init()}; - return Fold(context, - Expr{ - Convert(std::move(expr))}); + if (iter != scope->end()) { + const Symbol &symbol{*iter->second}; + const auto *details{symbol.detailsIf()}; + CHECK(details != nullptr); + CHECK(details->init().has_value()); + Expr expr{*details->init()}; + return Fold(context, + Expr{ + Convert(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{Convert( + value->GetExplicit().value())}); + } } return Expr{std::move(inquiry)}; } -// TODO: Fold/rewrite intrinsic function references - // Unary operations template @@ -595,24 +634,34 @@ FOR_EACH_TYPE_AND_KIND(template class ExpressionBase) // 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 constantNames; }; +// Base cases bool IsConstExpr(ConstExprContext &, const BOZLiteralConstant &) { return true; } template bool IsConstExpr(ConstExprContext &, const Constant &) { return true; } +bool IsConstExpr(ConstExprContext &, const StaticDataObject::Pointer) { + return true; +} template bool IsConstExpr(ConstExprContext &, const TypeParamInquiry &inquiry) { return inquiry.parameter->template get() .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 bool IsConstExpr(ConstExprContext &, const Operation &); template @@ -625,14 +674,25 @@ template bool IsConstExpr(ConstExprContext &, const ArrayConstructorValues &); template bool IsConstExpr(ConstExprContext &, const ArrayConstructor &); +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 bool IsConstExpr(ConstExprContext &, const Designator &); +bool IsConstExpr(ConstExprContext &, const ActualArgument &); template bool IsConstExpr(ConstExprContext &, const FunctionRef &); template bool IsConstExpr(ConstExprContext &, const Expr &); template bool IsConstExpr(ConstExprContext &, const CopyableIndirection &); template +bool IsConstExpr(ConstExprContext &, const std::optional &); +template bool IsConstExpr(ConstExprContext &, const std::vector &); template bool IsConstExpr(ConstExprContext &, const std::variant &); @@ -675,14 +735,56 @@ bool IsConstExpr(ConstExprContext &context, const ArrayConstructor &array) { 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()}) { + 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 bool IsConstExpr(ConstExprContext &context, const Designator &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 bool IsConstExpr(ConstExprContext &context, const FunctionRef &funcRef) { - // TODO: calls to intrinsics with constant arguments + if (const auto *intrinsic{ + std::get_if(&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 @@ -694,6 +796,10 @@ bool IsConstExpr(ConstExprContext &context, const CopyableIndirection &x) { return IsConstExpr(context, *x); } template +bool IsConstExpr(ConstExprContext &context, const std::optional &maybe) { + return !maybe.has_value() || IsConstExpr(context, *maybe); +} +template bool IsConstExpr(ConstExprContext &context, const std::vector &v) { for (const auto &x : v) { if (!IsConstExpr(context, x)) { diff --git a/flang/lib/evaluate/fold.h b/flang/lib/evaluate/fold.h index 22edb53..bdaa520 100644 --- a/flang/lib/evaluate/fold.h +++ b/flang/lib/evaluate/fold.h @@ -82,7 +82,7 @@ const Scalar *GetScalarConstantValue(const Expr &expr) { bool IsConstantExpr(const Expr &); // 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 std::optional ToInt64( diff --git a/flang/lib/evaluate/intrinsics.cc b/flang/lib/evaluate/intrinsics.cc index 77a47d5..6757da8 100644 --- a/flang/lib/evaluate/intrinsics.cc +++ b/flang/lib/evaluate/intrinsics.cc @@ -111,6 +111,7 @@ static constexpr TypePattern AnyNumeric{NumericType, KindCode::any}; 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, @@ -385,6 +386,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ 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}, diff --git a/flang/lib/evaluate/type.cc b/flang/lib/evaluate/type.cc index 2257ab7..1a6eb44 100644 --- a/flang/lib/evaluate/type.cc +++ b/flang/lib/evaluate/type.cc @@ -13,6 +13,7 @@ // limitations under the License. #include "type.h" +#include "fold.h" #include "../common/idioms.h" #include "../semantics/symbol.h" #include "../semantics/type.h" @@ -33,14 +34,15 @@ std::optional GetSymbolType(const semantics::Symbol *symbol) { 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(*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}; diff --git a/flang/lib/evaluate/variable.cc b/flang/lib/evaluate/variable.cc index 9dd3f50..ac95368 100644 --- a/flang/lib/evaluate/variable.cc +++ b/flang/lib/evaluate/variable.cc @@ -1,4 +1,4 @@ -// 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. @@ -210,10 +210,6 @@ std::ostream &Emit(std::ostream &o, const Symbol &symbol) { 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); } diff --git a/flang/lib/evaluate/variable.h b/flang/lib/evaluate/variable.h index b34e8c9..81463e7 100644 --- a/flang/lib/evaluate/variable.h +++ b/flang/lib/evaluate/variable.h @@ -1,4 +1,4 @@ -// 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. @@ -95,7 +95,7 @@ using SymbolOrComponent = std::variant; // 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 struct TypeParamInquiry { using Result = Type; CLASS_BOILERPLATE(TypeParamInquiry) @@ -109,6 +109,7 @@ template struct 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; }; @@ -331,7 +332,9 @@ public: 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 LEN() const; diff --git a/flang/lib/parser/parse-tree-visitor.h b/flang/lib/parser/parse-tree-visitor.h index f160cff..fc7a918 100644 --- a/flang/lib/parser/parse-tree-visitor.h +++ b/flang/lib/parser/parse-tree-visitor.h @@ -230,35 +230,65 @@ void Walk(common::Indirection &x, M &mutator) { // Walk a class with a single field 'thing'. template void Walk(const Scalar &x, V &visitor) { - Walk(x.thing, visitor); + if (visitor.Pre(x)) { + Walk(x.thing, visitor); + visitor.Post(x); + } } template void Walk(Scalar &x, M &mutator) { - Walk(x.thing, mutator); + if (mutator.Pre(x)) { + Walk(x.thing, mutator); + mutator.Post(x); + } } template void Walk(const Constant &x, V &visitor) { - Walk(x.thing, visitor); + if (visitor.Pre(x)) { + Walk(x.thing, visitor); + visitor.Post(x); + } } template void Walk(Constant &x, M &mutator) { - Walk(x.thing, mutator); + if (mutator.Pre(x)) { + Walk(x.thing, mutator); + mutator.Post(x); + } } template void Walk(const Integer &x, V &visitor) { - Walk(x.thing, visitor); + if (visitor.Pre(x)) { + Walk(x.thing, visitor); + visitor.Post(x); + } } template void Walk(Integer &x, M &mutator) { - Walk(x.thing, mutator); + if (mutator.Pre(x)) { + Walk(x.thing, mutator); + mutator.Post(x); + } } template void Walk(const Logical &x, V &visitor) { - Walk(x.thing, visitor); + if (visitor.Pre(x)) { + Walk(x.thing, visitor); + visitor.Post(x); + } } template void Walk(Logical &x, M &mutator) { - Walk(x.thing, mutator); + if (mutator.Pre(x)) { + Walk(x.thing, mutator); + mutator.Post(x); + } } template void Walk(const DefaultChar &x, V &visitor) { - Walk(x.thing, visitor); + if (visitor.Pre(x)) { + Walk(x.thing, visitor); + visitor.Post(x); + } } template void Walk(DefaultChar &x, M &mutator) { - Walk(x.thing, mutator); + if (mutator.Pre(x)) { + Walk(x.thing, mutator); + mutator.Post(x); + } } template void Walk(const Statement &x, V &visitor) { diff --git a/flang/lib/semantics/assignment.cc b/flang/lib/semantics/assignment.cc index 75b52b5..18c97f6 100644 --- a/flang/lib/semantics/assignment.cc +++ b/flang/lib/semantics/assignment.cc @@ -1,4 +1,4 @@ -// 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. @@ -18,63 +18,318 @@ #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 +#include using namespace Fortran::parser::literals; namespace Fortran::semantics { -template -void AnalyzeExecutableStmt(SemanticsContext &, const parser::Statement &) {} -template<> -void AnalyzeExecutableStmt(SemanticsContext &context, - const parser::Statement &stmt) {} -template<> -void AnalyzeExecutableStmt(SemanticsContext &context, - const parser::Statement &stmt) {} -template<> -void AnalyzeExecutableStmt(SemanticsContext &context, - const parser::Statement &stmt) {} -template<> -void AnalyzeExecutableStmt(SemanticsContext &context, - const parser::Statement &stmt) {} - -void AnalyzeAssignment(SemanticsContext &context, - const parser::Statement &stmt) { - AnalyzeExecutableStmt(context, stmt); +using ControlExpr = evaluate::Expr; +using MaskExpr = evaluate::Expr; + +// 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 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 constructName; + int integerKind; + std::vector control; + std::optional maskExpr; + std::set activeNames; +}; + +struct WhereContext { + explicit WhereContext(MaskExpr &&x) : thisMaskExpr{std::move(x)} {} + + const WhereContext *outer{nullptr}; + const ForallContext *forall{nullptr}; // innermost FORALL + std::optional 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 void Analyze(const parser::Statement &stmt) { + AssignmentContext nested{*this, stmt.source}; + nested.Analyze(stmt.statement); + } + template void Analyze(const common::Indirection &x) { + Analyze(*x); + } + template void Analyze(const std::variant &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 &); + + MaskExpr GetMask(const parser::LogicalExpr &, bool defaultValue = true) const; + + template parser::Message *Say(A... args) { + return messages_.Say(std::forward(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 &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 &stmt) { - AnalyzeExecutableStmt(context, stmt); + +void AssignmentContext::Analyze(const parser::WhereStmt &stmt) { + WhereContext where{GetMask(std::get(stmt.t))}; + AssignmentContext nested{*this, where}; + nested.Analyze(std::get(stmt.t)); } -void AnalyzeAssignment(SemanticsContext &context, - const parser::Statement &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>(construct.t)}; + WhereContext where{ + GetMask(std::get(whereStmt.statement.t))}; + if (const auto &name{ + std::get>(whereStmt.statement.t)}) { + where.constructName = name->source; + } + AssignmentContext nested{*this, where}; + for (const auto &x : + std::get>(construct.t)) { + nested.Analyze(x); + } + for (const auto &x : + std::get>( + construct.t)) { + nested.Analyze(x); + } + if (const auto &x{std::get>( + 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>(stmt.t)); + nested.Analyze(std::get(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>(construct.t) + .statement}; + nested.Analyze( + std::get>(forallStmt.t)); + for (const auto &body : + std::get>(construct.t)) { + nested.Analyze(body.u); + } +} + +void AssignmentContext::Analyze( + const parser::WhereConstruct::MaskedElsewhere &elsewhere) { + CHECK(where_ != nullptr); + const auto &elsewhereStmt{ + std::get>(elsewhere.t)}; + MaskExpr mask{ + GetMask(std::get(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>(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>(elsewhere.t)) { + Analyze(x); + } +} + +void AssignmentContext::Analyze(const parser::ConcurrentHeader &header) { + CHECK(forall_ != nullptr); + forall_->integerKind = GetIntegerKind( + std::get>(header.t)); + for (const auto &control : + std::get>(header.t)) { + const parser::CharBlock &name{std::get(control.t).source}; + bool inserted{forall_->activeNames.insert(name).second}; + CHECK(inserted); + } +} + +int AssignmentContext::GetIntegerKind( + const std::optional &spec) { + std::optional empty; + evaluate::Expr kind{AnalyzeKindSelector( + context_, messages_.at(), TypeCategory::Integer, spec ? spec->v : empty)}; + if (auto value{evaluate::ToInt64(kind)}) { + return static_cast(*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>(&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 bool Pre(A &) { return true /* visit children */; } - template void Post(A &) {} + template bool Pre(const A &) { return true /* visit children */; } + template void Post(const A &) {} - bool Pre(parser::Statement &stmt) { - AnalyzeAssignment(context_, stmt); + bool Pre(const parser::Statement &stmt) { + AssignmentContext{context_, stmt.source}.Analyze(stmt.statement); + return false; + } + bool Pre(const parser::Statement &stmt) { + AssignmentContext{context_, stmt.source}.Analyze(stmt.statement); + return false; + } + bool Pre(const parser::Statement &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 &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); } } diff --git a/flang/lib/semantics/assignment.h b/flang/lib/semantics/assignment.h index 2e9d179..2e1c9ab 100644 --- a/flang/lib/semantics/assignment.h +++ b/flang/lib/semantics/assignment.h @@ -1,4 +1,4 @@ -// 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. @@ -18,6 +18,7 @@ namespace Fortran::parser { template struct Statement; struct AssignmentStmt; +struct ConcurrentHeader; struct ForallStmt; struct PointerAssignmentStmt; struct Program; @@ -37,6 +38,11 @@ void AnalyzeAssignment( void AnalyzeAssignment( SemanticsContext &, const parser::Statement &); +// 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 &); } diff --git a/flang/lib/semantics/dump-parse-tree.h b/flang/lib/semantics/dump-parse-tree.h index b281d7f..436314f 100644 --- a/flang/lib/semantics/dump-parse-tree.h +++ b/flang/lib/semantics/dump-parse-tree.h @@ -715,11 +715,10 @@ public: #undef NODE_NAME template bool Pre(const T &x) { - IndentEmptyLine(); if (UnionTrait || WrapperTrait) { - out_ << GetNodeName(x) << " -> "; - emptyline_ = false; + Prefix(GetNodeName(x)); } else { + IndentEmptyLine(); out_ << GetNodeName(x); EndLine(); ++indent_; @@ -786,10 +785,16 @@ public: template bool Pre(const common::Indirection &) { return true; } template void Post(const common::Indirection &) {} + template bool Pre(const parser::Scalar &) { + Prefix("Scalar"); + return true; + } + template void Post(const parser::Scalar &) { + EndLineIfNonempty(); + } + template bool Pre(const parser::Constant &) { - IndentEmptyLine(); - out_ << "Constant ->"; - emptyline_ = false; + Prefix("Constant"); return true; } template void Post(const parser::Constant &) { @@ -797,20 +802,26 @@ public: } template bool Pre(const parser::Integer &) { - IndentEmptyLine(); - out_ << "Integer ->"; - emptyline_ = false; + Prefix("Integer"); return true; } - template void Post(const parser::Integer &) {} + template void Post(const parser::Integer &) { + EndLineIfNonempty(); + } - template bool Pre(const parser::Scalar &) { - IndentEmptyLine(); - out_ << "Scalar ->"; - emptyline_ = false; + template bool Pre(const parser::Logical &) { + Prefix("Logical"); return true; } - template void Post(const parser::Scalar &) { + template void Post(const parser::Logical &) { + EndLineIfNonempty(); + } + + template bool Pre(const parser::DefaultChar &) { + Prefix("DefaultChar"); + return true; + } + template void Post(const parser::DefaultChar &) { EndLineIfNonempty(); } @@ -830,6 +841,18 @@ protected: } } + 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; diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc index e9eca22..4745f79 100644 --- a/flang/lib/semantics/expression.cc +++ b/flang/lib/semantics/expression.cc @@ -13,7 +13,8 @@ // 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" @@ -24,9 +25,10 @@ #include "../parser/parse-tree-visitor.h" #include "../parser/parse-tree.h" #include -#include // TODO pmk rm #include +#include // TODO pmk rm + // Typedef for optional generic expressions (ubiquitous in this file) using MaybeExpr = std::optional>; @@ -662,6 +664,17 @@ struct TypeParamInquiryVisitor { const Symbol ¶meter; }; +static std::optional> MakeTypeParamInquiry( + const Symbol *symbol) { + if (std::optional 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) { @@ -677,13 +690,9 @@ static MaybeExpr AnalyzeExpr( 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()) { - // A bare reference to a derived type parameter (within the type definition) - if (std::optional 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 { @@ -897,6 +906,22 @@ static SymbolOrComponent IgnoreAnySubscripts( std::move(designator.u)); } +// Components of parent derived types are explicitly represented as such. +static std::optional 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) { @@ -914,27 +939,28 @@ static MaybeExpr AnalyzeExpr( if (sym->detailsIf()) { if (auto *designator{UnwrapExpr>(*dtExpr)}) { std::optional 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{ 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); @@ -964,7 +990,7 @@ static MaybeExpr AnalyzeExpr( } 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(*func.type, ProcedureRef{ProcedureDesignator{std::move(func)}, @@ -1071,7 +1097,7 @@ static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &context, std::visit( common::visitors{ [&](const common::Indirection &v) { - actualArgExpr = AnalyzeExpr(context, v); + actualArgExpr = AnalyzeExpr(context, *v); }, [&](const common::Indirection &x) { actualArgExpr = AnalyzeExpr(context, *x); @@ -1106,7 +1132,6 @@ static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &context, } // TODO: map user generic to specific procedure - // TODO: validate arguments against user interface if (std::optional proc{Procedure(context, std::get(funcRef.v.t), arguments)}) { if (std::optional dyType{ @@ -1417,44 +1442,51 @@ MaybeExpr ExpressionAnalysisContext::Analyze(const parser::Variable &variable) { return AnalyzeExpr(*this, variable.u); } -int ExpressionAnalysisContext::Analyze(TypeCategory category, +Expr ExpressionAnalysisContext::Analyze(TypeCategory category, const std::optional &selector) { int defaultKind{GetDefaultKind(category)}; if (!selector.has_value()) { - return defaultKind; + return Expr{defaultKind}; } return std::visit( common::visitors{ - [&](const parser::ScalarIntConstantExpr &x) -> int { + [&](const parser::ScalarIntConstantExpr &x) + -> Expr { if (MaybeExpr kind{AnalyzeExpr(*this, x)}) { - MaybeExpr folded{Fold(GetFoldingContext(), std::move(kind))}; - if (std::optional code{ToInt64(*folded)}) { + Expr folded{ + Fold(GetFoldingContext(), std::move(*kind))}; + if (std::optional code{ToInt64(folded)}) { if (IsValidKindOfIntrinsicType(category, *code)) { - return *code; + return Expr{*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>(folded)}) { + return ConvertToType(std::move(*intExpr)); } } - return defaultKind; + return Expr{defaultKind}; }, - [&](const parser::KindSelector::StarSize &x) -> int { + [&](const parser::KindSelector::StarSize &x) + -> Expr { 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{size}; }, }, selector->u); @@ -1504,7 +1536,8 @@ void AnalyzeExpressions(parser::Program &program, SemanticsContext &context) { parser::Walk(program, visitor); } -int AnalyzeKindSelector(SemanticsContext &context, parser::CharBlock source, +evaluate::Expr AnalyzeKindSelector( + SemanticsContext &context, parser::CharBlock source, common::TypeCategory category, const std::optional &selector) { evaluate::ExpressionAnalysisContext exprContext{context}; diff --git a/flang/lib/semantics/expression.h b/flang/lib/semantics/expression.h index 36f3e1a..d7e3a56 100644 --- a/flang/lib/semantics/expression.h +++ b/flang/lib/semantics/expression.h @@ -92,7 +92,7 @@ public: std::optional> Analyze(const parser::Expr &); std::optional> Analyze(const parser::Variable &); - int Analyze(common::TypeCategory category, + Expr Analyze(common::TypeCategory category, const std::optional &); int GetDefaultKind(common::TypeCategory); @@ -245,8 +245,8 @@ std::optional> AnalyzeExpr( 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, - common::TypeCategory, const std::optional &); +evaluate::Expr AnalyzeKindSelector( + SemanticsContext &, parser::CharBlock, common::TypeCategory, + const std::optional &); } #endif // FORTRAN_SEMANTICS_EXPRESSION_H_ diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc index 70ed475..3f8f64d 100644 --- a/flang/lib/semantics/resolve-names.cc +++ b/flang/lib/semantics/resolve-names.cc @@ -27,6 +27,7 @@ #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 @@ -91,6 +92,7 @@ private: // 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 *); @@ -113,6 +115,20 @@ private: 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 void Walk(const T &); @@ -122,17 +138,17 @@ public: 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 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 MaybeIntExpr EvaluateIntExpr(const T &expr) { @@ -147,7 +163,7 @@ public: template MaybeSubscriptIntExpr EvaluateSubscriptIntExpr(const T &expr) { if (MaybeIntExpr maybeIntExpr{EvaluateIntExpr(expr)}) { - return evaluate::Fold(context_->foldingContext(), + return evaluate::Fold(GetFoldingContext(), evaluate::ConvertToType( std::move(*maybeIntExpr))); } else { @@ -243,23 +259,18 @@ public: 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}; @@ -272,17 +283,17 @@ protected: 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 &); private: State state_; - void MakeNumericType( - TypeCategory, const std::optional &); void MakeNumericType(TypeCategory, int kind); - int GetKindParamValue( - TypeCategory, const std::optional &); }; // Visit ImplicitStmt and related parse tree nodes and updates implicit rules. @@ -399,6 +410,9 @@ public: // 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 *); @@ -419,7 +433,7 @@ public: 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); @@ -467,6 +481,10 @@ protected: bool ConvertToObjectEntity(Symbol &); bool ConvertToProcEntity(Symbol &); + DeclTypeSpec &MakeNumericType( + TypeCategory, const std::optional &); + DeclTypeSpec &MakeLogicalType(const std::optional &); + // Walk the ModuleSubprogramPart or InternalSubprogramPart collecting names. template void WalkSubprogramPart(const std::optional &subpPart) { @@ -624,12 +642,18 @@ public: 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); @@ -674,7 +698,7 @@ private: // Info about current character type while walking DeclTypeSpec struct { std::optional length; - int kind{0}; + std::optional kind; } charInfo_; // Info about current derived type while walking DerivedTypeStmt struct { @@ -697,9 +721,9 @@ private: 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 @@ -899,7 +923,6 @@ private: 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 &); @@ -1101,35 +1124,17 @@ void DeclTypeSpecVisitor::EndDeclTypeSpec() { 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(x.t)}; - if (const auto &keyword{std::get>(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 &) { @@ -1152,19 +1157,6 @@ bool DeclTypeSpecVisitor::Pre(const parser::AcSpec &x) { 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( @@ -1175,10 +1167,6 @@ void DeclTypeSpecVisitor::Post( MakeNumericType( TypeCategory::Complex, context().defaultKinds().doublePrecisionKind()); } -void DeclTypeSpecVisitor::MakeNumericType( - TypeCategory category, const std::optional &kind) { - MakeNumericType(category, GetKindParamValue(category, kind)); -} void DeclTypeSpecVisitor::MakeNumericType(TypeCategory category, int kind) { SetDeclTypeSpec(context().MakeNumericType(category, kind)); } @@ -1202,40 +1190,9 @@ void DeclTypeSpecVisitor::SetDeclTypeSpec(const DeclTypeSpec &declTypeSpec) { 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 &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 @@ -1447,9 +1404,11 @@ void ScopeHandler::SayAlreadyDeclared( } 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) { @@ -1513,6 +1472,13 @@ Symbol *ScopeHandler::FindSymbol(const parser::Name &name) { 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()) { + return Resolve(name, symbol); + } + } return Resolve(name, scope.FindSymbol(name.source)); } @@ -1559,6 +1525,22 @@ Symbol *ScopeHandler::FindInScope(const Scope &scope, const SourceName &name) { } } +// 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; @@ -1629,6 +1611,26 @@ bool ScopeHandler::ConvertToProcEntity(Symbol &symbol) { return true; } +DeclTypeSpec &ScopeHandler::MakeNumericType( + TypeCategory category, const std::optional &kind) { + KindExpr value{GetKindParamExpr(category, kind)}; + if (auto known{evaluate::ToInt64(value)}) { + return context().MakeNumericType(category, static_cast(*known)); + } else { + return currScope_->MakeNumericType(category, std::move(value)); + } +} + +DeclTypeSpec &ScopeHandler::MakeLogicalType( + const std::optional &kind) { + KindExpr value{GetKindParamExpr(TypeCategory::Logical, kind)}; + if (auto known{evaluate::ToInt64(value)}) { + return context().MakeLogicalType(static_cast(*known)); + } else { + return currScope_->MakeLogicalType(std::move(value)); + } +} + // ModuleVisitor implementation bool ModuleVisitor::Pre(const parser::Only &x) { @@ -2500,26 +2502,32 @@ Symbol &DeclarationVisitor::DeclareObjectEntity( 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 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); } @@ -2537,21 +2545,131 @@ void DeclarationVisitor::Post(const parser::LengthSelector &x) { } } +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(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()}; + auto parameterNames{typeDetails.OrderParameterNames(*typeSymbol)}; + auto nextNameIter{parameterNames.begin()}; + bool seenAnyName{false}; + for (const auto &typeParamSpec : + std::get>(x.t)) { + const auto &optKeyword{ + std::get>(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(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()}; + 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 paramNames; auto &scope{currScope()}; + CHECK(scope.symbol() != nullptr); + CHECK(scope.symbol()->scope() == &scope); auto &details{scope.symbol()->get()}; auto &stmt{std::get>(x.t)}; for (auto ¶mName : std::get>(stmt.statement.t)) { @@ -2603,16 +2721,15 @@ void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) { PushScope(Scope::Kind::DerivedType, &symbol); if (auto *extendsName{derivedTypeInfo_.extends}) { if (const Symbol * extends{ResolveDerivedType(*extendsName)}) { - symbol.get().set_extends(extendsName->source); // Declare the "parent component"; private if the type is if (OkToAddComponent(*extendsName, extends)) { + symbol.get().set_extends(extendsName->source); auto &comp{DeclareEntity(*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); } } } @@ -2785,7 +2902,8 @@ bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) { if (!genericSymbol->has()) { 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()) { inheritedProcs = @@ -2809,7 +2927,7 @@ bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) { details.add_specificProcs(*inheritedProcs); } for (const auto &bindingName : std::get>(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); @@ -2890,6 +3008,7 @@ void DeclarationVisitor::SetType( // 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; @@ -2938,21 +3057,6 @@ Symbol *DeclarationVisitor::FindExplicitInterface(const parser::Name &name) { 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( @@ -2973,7 +3077,11 @@ Symbol *DeclarationVisitor::MakeTypeSymbol( std::holds_alternative(details)) { attrs.set(Attr::PRIVATE); } - return &MakeSymbol(name, attrs, details); + Symbol &result{MakeSymbol(name, attrs, details)}; + if (result.has()) { + derivedType.symbol()->get().add_paramDecl(result); + } + return &result; } } @@ -2981,8 +3089,7 @@ Symbol *DeclarationVisitor::MakeTypeSymbol( // 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}; @@ -2992,7 +3099,7 @@ bool DeclarationVisitor::OkToAddComponent( } 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 { @@ -3002,15 +3109,28 @@ bool DeclarationVisitor::OkToAddComponent( 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 @@ -3061,7 +3181,7 @@ bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) { std::get>(x.t)}; if (type) { BeginDeclTypeSpec(); - DeclTypeSpecVisitor::Post(*type); + DeclarationVisitor::Post(*type); } if (auto *symbol{DeclareConstructEntity(bounds.name.thing.thing)}) { CheckIntegerType(*symbol); @@ -3420,6 +3540,8 @@ const parser::Name *ResolveNamesVisitor::ResolveName(const parser::Name &name) { } // 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) { @@ -3457,15 +3579,17 @@ const parser::Name *ResolveNamesVisitor::FindComponent( 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, @@ -3501,19 +3625,6 @@ bool ResolveNamesVisitor::CheckAccessibleComponent( 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(&x.u)}) { auto *symbol{FindSymbol(*name)}; diff --git a/flang/lib/semantics/scope.cc b/flang/lib/semantics/scope.cc index 7edd456..cdbafd1 100644 --- a/flang/lib/semantics/scope.cc +++ b/flang/lib/semantics/scope.cc @@ -14,6 +14,9 @@ #include "scope.h" #include "symbol.h" +#include "type.h" +#include "../evaluate/fold.h" +#include "../parser/characters.h" #include #include @@ -26,8 +29,7 @@ bool Scope::IsModule() const { } 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) { @@ -70,11 +72,11 @@ bool Scope::AddSubmodule(const SourceName &name, Scope &submodule) { 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}); @@ -84,30 +86,38 @@ const DeclTypeSpec &Scope::MakeClassStarType() { } // 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()); + 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_; @@ -188,4 +198,107 @@ std::ostream &operator<<(std::ostream &os, const Scope &scope) { } 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()) { + 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(*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; +} } diff --git a/flang/lib/semantics/scope.h b/flang/lib/semantics/scope.h index 96ce136..79f37ab 100644 --- a/flang/lib/semantics/scope.h +++ b/flang/lib/semantics/scope.h @@ -25,6 +25,10 @@ #include #include +namespace Fortran::evaluate { +struct FoldingContext; +} + namespace Fortran::semantics { using namespace parser::literals; @@ -59,12 +63,17 @@ public: } 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 @@ -85,8 +94,12 @@ public: 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. @@ -121,13 +134,13 @@ public: 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(); @@ -145,26 +158,47 @@ public: 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 children_; mapType symbols_; std::map submodules_; std::list declTypeSpecs_; - std::list characterTypeSpecs_; - std::list derivedTypeSpecs_; std::string chars_; std::optional importKind_; std::set 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. diff --git a/flang/lib/semantics/semantics.cc b/flang/lib/semantics/semantics.cc index 2eab98b..cfd7b38 100644 --- a/flang/lib/semantics/semantics.cc +++ b/flang/lib/semantics/semantics.cc @@ -13,6 +13,7 @@ // limitations under the License. #include "semantics.h" +#include "assignment.h" #include "canonicalize-do.h" #include "check-do-concurrent.h" #include "default-kinds.h" @@ -42,13 +43,13 @@ const DeclTypeSpec &SemanticsContext::MakeNumericType( 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 { @@ -84,6 +85,7 @@ bool Semantics::Perform() { } if (context_.debugExpressions()) { AnalyzeExpressions(program_, context_); + AnalyzeAssignments(program_, context_); } return !AnyFatalError(); } diff --git a/flang/lib/semantics/symbol.cc b/flang/lib/semantics/symbol.cc index 771e2b6..685d504 100644 --- a/flang/lib/semantics/symbol.cc +++ b/flang/lib/semantics/symbol.cc @@ -590,14 +590,15 @@ std::ostream &DumpForUnparse( 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(); // confirm or crash with message return symbol; } @@ -608,6 +609,32 @@ Symbol &Symbol::Instantiate(Scope &scope, const DerivedTypeSpec &spec, [&](const ObjectEntityDetails &that) { symbol.details_ = that; ObjectEntityDetails &details{symbol.get()}; + 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()) { @@ -624,52 +651,62 @@ Symbol &Symbol::Instantiate(Scope &scope, const DerivedTypeSpec &spec, }, [&](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()}; 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()}; - details.set_init( - evaluate::Fold(foldingContext, std::move(details.init()))); }, - [&](const FinalProcDetails &that) { symbol.details_ = that; }, - [&](const auto &) { - get(); // 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()}; - 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()}; - 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()}; + const DerivedTypeSpec *spec{object.type()->AsDerived()}; + CHECK(spec != nullptr); + return spec; + } else { + return nullptr; } - return nullptr; } std::list DerivedTypeDetails::OrderParameterNames( const Symbol &type) const { std::list result; - if (const Symbol * parent{type.GetParent()}) { - result = parent->get().OrderParameterNames(*parent); + if (const DerivedTypeSpec * spec{type.GetParentTypeSpec()}) { + const DerivedTypeDetails &details{ + spec->typeSymbol().get()}; + result = details.OrderParameterNames(spec->typeSymbol()); } for (const auto &name : paramNames_) { result.push_back(name); @@ -680,9 +717,10 @@ std::list DerivedTypeDetails::OrderParameterNames( std::list DerivedTypeDetails::OrderParameterDeclarations( const Symbol &type) const { std::list result; - if (const Symbol * parent{type.GetParent()}) { - result = - parent->get().OrderParameterDeclarations(*parent); + if (const DerivedTypeSpec * spec{type.GetParentTypeSpec()}) { + const DerivedTypeDetails &details{ + spec->typeSymbol().get()}; + result = details.OrderParameterDeclarations(spec->typeSymbol()); } for (Symbol *symbol : paramDecls_) { result.push_back(symbol); diff --git a/flang/lib/semantics/symbol.h b/flang/lib/semantics/symbol.h index 2169d67..2874805 100644 --- a/flang/lib/semantics/symbol.h +++ b/flang/lib/semantics/symbol.h @@ -437,12 +437,13 @@ public: 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_; @@ -456,6 +457,11 @@ private: 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 friend class Symbols; template friend struct std::array; }; diff --git a/flang/lib/semantics/type.cc b/flang/lib/semantics/type.cc index 6bc0e2c..5721579 100644 --- a/flang/lib/semantics/type.cc +++ b/flang/lib/semantics/type.cc @@ -21,47 +21,159 @@ #include "../evaluate/tools.h" #include "../evaluate/type.h" #include "../parser/characters.h" +#include +#include 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()}; + + // 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()}; + 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{bound}} {} +Bound::Bound(int bound) : expr_{bound} {} std::ostream &operator<<(std::ostream &o, const Bound &x) { if (x.isAssumed()) { @@ -97,6 +209,15 @@ ParamValue::ParamValue(std::int64_t value) : ParamValue(SomeIntExpr{evaluate::Expr{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 << '*'; @@ -110,32 +231,43 @@ std::ostream &operator<<(std::ostream &o, const ParamValue &x) { 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} { @@ -144,49 +276,51 @@ 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(typeSpec_); + case Logical: return &std::get(typeSpec_); + case Character: return &std::get(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(typeSpec_); + case Logical: return &std::get(typeSpec_); + case Character: return &std::get(typeSpec_); default: return nullptr; } } const DerivedTypeSpec *DeclTypeSpec::AsDerived() const { switch (category_) { case TypeDerived: - case ClassDerived: return typeSpec_.derived; + case ClassDerived: return &std::get(typeSpec_); default: return nullptr; } } const NumericTypeSpec &DeclTypeSpec::numericTypeSpec() const { CHECK(category_ == Numeric); - return typeSpec_.numeric; + return std::get(typeSpec_); } const LogicalTypeSpec &DeclTypeSpec::logicalTypeSpec() const { CHECK(category_ == Logical); - return typeSpec_.logical; + return std::get(typeSpec_); } const CharacterTypeSpec &DeclTypeSpec::characterTypeSpec() const { CHECK(category_ == Character); - return *typeSpec_.character; + return std::get(typeSpec_); } const DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() const { CHECK(category_ == TypeDerived || category_ == ClassDerived); - return *typeSpec_.derived; + return std::get(typeSpec_); +} +DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() { + CHECK(category_ == TypeDerived || category_ == ClassDerived); + return std::get(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) { diff --git a/flang/lib/semantics/type.h b/flang/lib/semantics/type.h index 1cf7768..17cf5d1 100644 --- a/flang/lib/semantics/type.h +++ b/flang/lib/semantics/type.h @@ -33,6 +33,10 @@ namespace Fortran::parser { struct Expr; } +namespace Fortran::evaluate { +struct FoldingContext; +} + namespace Fortran::semantics { class Scope; @@ -50,6 +54,7 @@ using SomeIntExpr = evaluate::Expr; using MaybeIntExpr = std::optional; using SubscriptIntExpr = evaluate::Expr; using MaybeSubscriptIntExpr = std::optional; +using KindExpr = SubscriptIntExpr; // An array spec bound: an explicit integer expression or ASSUMED or DEFERRED class Bound { @@ -85,14 +90,17 @@ private: // 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 }; @@ -105,25 +113,25 @@ private: 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); } @@ -131,14 +139,15 @@ public: 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: @@ -205,22 +214,29 @@ using ArraySpec = std::list; class DerivedTypeSpec { public: - using listType = std::list, 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 ¶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 parameters_; friend std::ostream &operator<<(std::ostream &, const DerivedTypeSpec &); }; @@ -237,42 +253,37 @@ public: }; // 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 + typeSpec_; }; std::ostream &operator<<(std::ostream &, const DeclTypeSpec &); @@ -292,5 +303,4 @@ private: const DeclTypeSpec *type_{nullptr}; }; } - #endif // FORTRAN_SEMANTICS_TYPE_H_ diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index 3950730..9487194 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/flang/test/semantics/CMakeLists.txt @@ -25,6 +25,7 @@ set(ERROR_TESTS implicit06.f90 implicit07.f90 implicit08.f90 + kinds02.f90 resolve01.f90 resolve02.f90 resolve03.f90 @@ -79,6 +80,8 @@ set(SYMBOL_TESTS symbol09.f90 symbol10.f90 symbol11.f90 + kinds01.f90 + kinds03.f90 ) # These test files have expected .mod file contents in the source @@ -99,6 +102,7 @@ set(MODFILE_TESTS modfile14.f90 modfile15.f90 modfile16.f90 + modfile17.f90 ) set(LABEL_TESTS diff --git a/flang/test/semantics/kinds01.f90 b/flang/test/semantics/kinds01.f90 new file mode 100644 index 0000000..a2fd2f4 --- /dev/null +++ b/flang/test/semantics/kinds01.f90 @@ -0,0 +1,95 @@ +! 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 diff --git a/flang/test/semantics/kinds02.f90 b/flang/test/semantics/kinds02.f90 new file mode 100644 index 0000000..e954d03 --- /dev/null +++ b/flang/test/semantics/kinds02.f90 @@ -0,0 +1,57 @@ +! 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 diff --git a/flang/test/semantics/kinds03.f90 b/flang/test/semantics/kinds03.f90 new file mode 100644 index 0000000..8e30d13 --- /dev/null +++ b/flang/test/semantics/kinds03.f90 @@ -0,0 +1,55 @@ +! 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 diff --git a/flang/test/semantics/modfile12.f90 b/flang/test/semantics/modfile12.f90 index 4740b20..52e1f7c 100644 --- a/flang/test/semantics/modfile12.f90 +++ b/flang/test/semantics/modfile12.f90 @@ -1,4 +1,4 @@ -! 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. @@ -54,8 +54,8 @@ end ! 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 diff --git a/flang/test/semantics/modfile17.f90 b/flang/test/semantics/modfile17.f90 new file mode 100644 index 0000000..3583e70 --- /dev/null +++ b/flang/test/semantics/modfile17.f90 @@ -0,0 +1,182 @@ +! 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 diff --git a/flang/test/semantics/resolve37.f90 b/flang/test/semantics/resolve37.f90 index 8978a7b..0b6bf4d 100644 --- a/flang/test/semantics/resolve37.f90 +++ b/flang/test/semantics/resolve37.f90 @@ -1,4 +1,4 @@ -! 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. @@ -25,8 +25,10 @@ integer(n) :: z 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 diff --git a/flang/test/semantics/symbol09.f90 b/flang/test/semantics/symbol09.f90 index e8863e6..0138673 100644 --- a/flang/test/semantics/symbol09.f90 +++ b/flang/test/semantics/symbol09.f90 @@ -1,4 +1,4 @@ -! 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. @@ -81,7 +81,7 @@ subroutine s4 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 @@ -100,7 +100,7 @@ subroutine s5 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 -- 2.7.4