maxjhandsome
/
llvm-project
forked from OSchip/llvm-project
1
0
Fork 0
Code Issues Pull Requests Packages Releases Wiki Activity

[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@1f43d0a048
Reviewed-on: https://github.com/flang-compiler/f18/pull/260
Tree-same-pre-rewrite: false
This commit is contained in:
peter klausler 2018-12-04 10:55:32 -08:00
parent 3035fc25a7
commit be3b765e2a
29 changed files with 1776 additions and 473 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
flang/lib/evaluate/call.h
View File

@ -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<std::optional<ActualArgument>>;
// Intrinsics are identified by their names and the characteristics
// of their arguments, at least for now.
using IntrinsicProcedure = const char *; // not an owning pointer
using IntrinsicProcedure = std::string;
struct SpecificIntrinsic {
explicit SpecificIntrinsic(IntrinsicProcedure n) : name{n} {}
SpecificIntrinsic(IntrinsicProcedure n, std::optional<DynamicType> &&dt,
int r, semantics::Attrs a)
: name{n}, type{std::move(dt)}, rank{r}, attrs{a} {}
SpecificIntrinsic(const SpecificIntrinsic &) = default;
SpecificIntrinsic(SpecificIntrinsic &&) = default;
SpecificIntrinsic &operator=(const SpecificIntrinsic &) = default;
SpecificIntrinsic &operator=(SpecificIntrinsic &&) = default;
bool operator==(const SpecificIntrinsic &) const;
std::ostream &AsFortran(std::ostream &) const;

138
flang/lib/evaluate/fold.cc
View File

@ -49,7 +49,7 @@ CoarrayRef FoldOperation(FoldingContext &, CoarrayRef &&);
DataRef FoldOperation(FoldingContext &, DataRef &&);
Substring FoldOperation(FoldingContext &, Substring &&);
ComplexPart FoldOperation(FoldingContext &, ComplexPart &&);
template<typename T> Expr<T> FoldOperation(FoldingContext &, FunctionRef<T> &&);
template<typename T> Expr<T> FoldOperation(FoldingContext &, Designator<T> &&);
template<int KIND>
Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(
@ -152,6 +152,37 @@ ComplexPart FoldOperation(FoldingContext &context, ComplexPart &&complexPart) {
FoldOperation(context, std::move(complex)), complexPart.part()};
}
template<typename T>
Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
ActualArguments args{std::move(funcRef.arguments())};
for (std::optional<ActualArgument> &arg : args) {
if (arg.has_value()) {
*arg->value = FoldOperation(context, std::move(*arg->value));
}
}
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
std::string name{intrinsic->name};
if (name == "kind") {
if constexpr (common::HasMember<T, IntegerTypes>) {
return Expr<T>{args[0]->value->GetType()->kind};
} else {
common::die("kind() result not integral");
}
} else if (name == "len") {
if constexpr (std::is_same_v<T, SubscriptInteger>) {
if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(*args[0]->value)}) {
return std::visit([](auto &kx) { return kx.LEN(); }, charExpr->u);
}
} else {
common::die("len() result not SubscriptInteger");
}
} else {
// TODO: many more intrinsic functions
}
}
return Expr<T>{FunctionRef<T>{std::move(funcRef.proc()), std::move(args)}};
}
template<typename T>
Expr<T> FoldOperation(FoldingContext &context, Designator<T> &&designator) {
if constexpr (T::category == TypeCategory::Character) {
@ -193,21 +224,29 @@ Expr<Type<TypeCategory::Integer, KIND>> 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<semantics::TypeParamDetails>()};
CHECK(details != nullptr);
CHECK(details->init().has_value());
Expr<SomeInteger> expr{*details->init()};
return Fold(context,
Expr<IntKIND>{
Convert<IntKIND, TypeCategory::Integer>(std::move(expr))});
if (iter != scope->end()) {
const Symbol &symbol{*iter->second};
const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
CHECK(details != nullptr);
CHECK(details->init().has_value());
Expr<SomeInteger> expr{*details->init()};
return Fold(context,
Expr<IntKIND>{
Convert<IntKIND, TypeCategory::Integer>(std::move(expr))});
} else {
// Parameter of a parent derived type; these are saved in the spec.
const auto *value{
context.pdtInstance->FindParameter(inquiry.parameter->name())};
CHECK(value != nullptr);
CHECK(value->isExplicit());
return Fold(context,
Expr<IntKIND>{Convert<IntKIND, TypeCategory::Integer>(
value->GetExplicit().value())});
}
}
return Expr<IntKIND>{std::move(inquiry)};
}
// TODO: Fold/rewrite intrinsic function references
// Unary operations
template<typename TO, TypeCategory FROMCAT>
@ -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<parser::CharBlock> constantNames;
};
// Base cases
bool IsConstExpr(ConstExprContext &, const BOZLiteralConstant &) {
return true;
}
template<typename A> bool IsConstExpr(ConstExprContext &, const Constant<A> &) {
return true;
}
bool IsConstExpr(ConstExprContext &, const StaticDataObject::Pointer) {
return true;
}
template<int KIND>
bool IsConstExpr(ConstExprContext &, const TypeParamInquiry<KIND> &inquiry) {
return inquiry.parameter->template get<semantics::TypeParamDetails>()
.attr() == common::TypeParamAttr::Kind;
}
bool IsConstExpr(ConstExprContext &, const Symbol *symbol) {
return symbol->attrs().test(semantics::Attr::PARAMETER);
}
bool IsConstExpr(ConstExprContext &, const CoarrayRef &) { return false; }
// Prototypes for mutual recursion
template<typename D, typename R, typename O1>
bool IsConstExpr(ConstExprContext &, const Operation<D, R, O1> &);
template<typename D, typename R, typename O1, typename O2>
@ -625,14 +674,25 @@ template<typename A>
bool IsConstExpr(ConstExprContext &, const ArrayConstructorValues<A> &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const ArrayConstructor<A> &);
bool IsConstExpr(ConstExprContext &, const BaseObject &);
bool IsConstExpr(ConstExprContext &, const Component &);
bool IsConstExpr(ConstExprContext &, const Triplet &);
bool IsConstExpr(ConstExprContext &, const Subscript &);
bool IsConstExpr(ConstExprContext &, const ArrayRef &);
bool IsConstExpr(ConstExprContext &, const DataRef &);
bool IsConstExpr(ConstExprContext &, const Substring &);
bool IsConstExpr(ConstExprContext &, const ComplexPart &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const Designator<A> &);
bool IsConstExpr(ConstExprContext &, const ActualArgument &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const FunctionRef<A> &);
template<typename A> bool IsConstExpr(ConstExprContext &, const Expr<A> &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const CopyableIndirection<A> &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const std::optional<A> &);
template<typename A>
bool IsConstExpr(ConstExprContext &, const std::vector<A> &);
template<typename... As>
bool IsConstExpr(ConstExprContext &, const std::variant<As...> &);
@ -675,14 +735,56 @@ bool IsConstExpr(ConstExprContext &context, const ArrayConstructor<A> &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<DataRef>()}) {
if (!IsConstExpr(context, *dataRef)) {
return false;
}
}
return IsConstExpr(context, substring.lower()) &&
IsConstExpr(context, substring.upper());
}
bool IsConstExpr(ConstExprContext &context, const ComplexPart &complexPart) {
return IsConstExpr(context, complexPart.complex());
}
template<typename A>
bool IsConstExpr(ConstExprContext &context, const Designator<A> &designator) {
// TODO: true for PARAMETER and for kind type parameters
return false;
return IsConstExpr(context, designator.u);
}
bool IsConstExpr(ConstExprContext &context, const ActualArgument &arg) {
return IsConstExpr(context, *arg.value);
}
template<typename A>
bool IsConstExpr(ConstExprContext &context, const FunctionRef<A> &funcRef) {
// TODO: calls to intrinsics with constant arguments
if (const auto *intrinsic{
std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
if (intrinsic->name == "kind") {
return true;
}
// TODO: This is a placeholder with obvious false positives
return IsConstExpr(context, funcRef.arguments());
}
return false;
}
template<typename A>
@ -694,6 +796,10 @@ bool IsConstExpr(ConstExprContext &context, const CopyableIndirection<A> &x) {
return IsConstExpr(context, *x);
}
template<typename A>
bool IsConstExpr(ConstExprContext &context, const std::optional<A> &maybe) {
return !maybe.has_value() || IsConstExpr(context, *maybe);
}
template<typename A>
bool IsConstExpr(ConstExprContext &context, const std::vector<A> &v) {
for (const auto &x : v) {
if (!IsConstExpr(context, x)) {

2
flang/lib/evaluate/fold.h
View File

@ -82,7 +82,7 @@ const Scalar<T> *GetScalarConstantValue(const Expr<SomeType> &expr) {
bool IsConstantExpr(const Expr<SomeType> &);
// When an expression is a constant integer, ToInt64() extracts its value.
// Ensure that the expression has been folded beforehand if folding might
// Ensure that the expression has been folded beforehand when folding might
// be required.
template<int KIND>
std::optional<std::int64_t> ToInt64(

2
flang/lib/evaluate/intrinsics.cc
View File

@ -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},

16
flang/lib/evaluate/type.cc
View File

@ -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<DynamicType> 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<int>(*kind)};
if (symbol->IsDescriptor()) {
dyType.descriptor = symbol;
}
return std::make_optional(std::move(dyType));
}
return std::make_optional(std::move(dyType));
}
} else if (const auto *derived{type->AsDerived()}) {
DynamicType dyType{TypeCategory::Derived, 0, derived};

6
flang/lib/evaluate/variable.cc
View File

@ -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);
}

7
flang/lib/evaluate/variable.h
View File

@ -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<const Symbol *, Component>;
// x%KIND for intrinsic types is similarly rewritten in semantics to
// KIND(x), which is then folded to a constant value.
// "Bare" type parameter references within a derived type definition do
// not have base objects here.
// not have base objects here, only symbols.
template<int KIND> struct TypeParamInquiry {
using Result = Type<TypeCategory::Integer, KIND>;
CLASS_BOILERPLATE(TypeParamInquiry)
@ -109,6 +109,7 @@ template<int KIND> 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<SubscriptInteger> LEN() const;

50
flang/lib/parser/parse-tree-visitor.h
View File

@ -230,35 +230,65 @@ void Walk(common::Indirection<T> &x, M &mutator) {
// Walk a class with a single field 'thing'.
template<typename T, typename V> void Walk(const Scalar<T> &x, V &visitor) {
Walk(x.thing, visitor);
if (visitor.Pre(x)) {
Walk(x.thing, visitor);
visitor.Post(x);
}
}
template<typename T, typename M> void Walk(Scalar<T> &x, M &mutator) {
Walk(x.thing, mutator);
if (mutator.Pre(x)) {
Walk(x.thing, mutator);
mutator.Post(x);
}
}
template<typename T, typename V> void Walk(const Constant<T> &x, V &visitor) {
Walk(x.thing, visitor);
if (visitor.Pre(x)) {
Walk(x.thing, visitor);
visitor.Post(x);
}
}
template<typename T, typename M> void Walk(Constant<T> &x, M &mutator) {
Walk(x.thing, mutator);
if (mutator.Pre(x)) {
Walk(x.thing, mutator);
mutator.Post(x);
}
}
template<typename T, typename V> void Walk(const Integer<T> &x, V &visitor) {
Walk(x.thing, visitor);
if (visitor.Pre(x)) {
Walk(x.thing, visitor);
visitor.Post(x);
}
}
template<typename T, typename M> void Walk(Integer<T> &x, M &mutator) {
Walk(x.thing, mutator);
if (mutator.Pre(x)) {
Walk(x.thing, mutator);
mutator.Post(x);
}
}
template<typename T, typename V> void Walk(const Logical<T> &x, V &visitor) {
Walk(x.thing, visitor);
if (visitor.Pre(x)) {
Walk(x.thing, visitor);
visitor.Post(x);
}
}
template<typename T, typename M> void Walk(Logical<T> &x, M &mutator) {
Walk(x.thing, mutator);
if (mutator.Pre(x)) {
Walk(x.thing, mutator);
mutator.Post(x);
}
}
template<typename T, typename V>
void Walk(const DefaultChar<T> &x, V &visitor) {
Walk(x.thing, visitor);
if (visitor.Pre(x)) {
Walk(x.thing, visitor);
visitor.Post(x);
}
}
template<typename T, typename M> void Walk(DefaultChar<T> &x, M &mutator) {
Walk(x.thing, mutator);
if (mutator.Pre(x)) {
Walk(x.thing, mutator);
mutator.Post(x);
}
}
template<typename T, typename V> void Walk(const Statement<T> &x, V &visitor) {

333
flang/lib/semantics/assignment.cc
View File

@ -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 <optional>
#include <set>
using namespace Fortran::parser::literals;
namespace Fortran::semantics {
template<typename A>
void AnalyzeExecutableStmt(SemanticsContext &, const parser::Statement<A> &) {}
template<>
void AnalyzeExecutableStmt(SemanticsContext &context,
const parser::Statement<parser::AssignmentStmt> &stmt) {}
template<>
void AnalyzeExecutableStmt(SemanticsContext &context,
const parser::Statement<parser::PointerAssignmentStmt> &stmt) {}
template<>
void AnalyzeExecutableStmt(SemanticsContext &context,
const parser::Statement<parser::WhereStmt> &stmt) {}
template<>
void AnalyzeExecutableStmt(SemanticsContext &context,
const parser::Statement<parser::ForallStmt> &stmt) {}
using ControlExpr = evaluate::Expr<evaluate::SubscriptInteger>;
using MaskExpr = evaluate::Expr<evaluate::LogicalResult>;
void AnalyzeAssignment(SemanticsContext &context,
const parser::Statement<parser::AssignmentStmt> &stmt) {
AnalyzeExecutableStmt(context, stmt);
}
void AnalyzeAssignment(SemanticsContext &context,
const parser::Statement<parser::PointerAssignmentStmt> &stmt) {
AnalyzeExecutableStmt(context, stmt);
}
void AnalyzeAssignment(SemanticsContext &context,
const parser::Statement<parser::WhereStmt> &stmt) {
AnalyzeExecutableStmt(context, stmt);
}
void AnalyzeAssignment(SemanticsContext &context,
const parser::Statement<parser::ForallStmt> &stmt) {
AnalyzeExecutableStmt(context, stmt);
}
// 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;
};
class Mutator {
struct ForallContext {
explicit ForallContext(const ForallContext *that) : outer{that} {}
// TODO pmk: Is this needed? Does semantics already track these kinds?
std::optional<int> GetActiveIntKind(const parser::CharBlock &name) const {
const auto iter{activeNames.find(name)};
if (iter != activeNames.cend()) {
return {integerKind};
} else if (outer != nullptr) {
return outer->GetActiveIntKind(name);
} else {
return std::nullopt;
}
}
const ForallContext *outer{nullptr};
std::optional<parser::CharBlock> constructName;
int integerKind;
std::vector<Control> control;
std::optional<MaskExpr> maskExpr;
std::set<parser::CharBlock> activeNames;
};
struct WhereContext {
explicit WhereContext(MaskExpr &&x) : thisMaskExpr{std::move(x)} {}
const WhereContext *outer{nullptr};
const ForallContext *forall{nullptr}; // innermost FORALL
std::optional<parser::CharBlock> constructName;
MaskExpr thisMaskExpr; // independent of outer WHERE, if any
MaskExpr cumulativeMaskExpr{thisMaskExpr};
};
class AssignmentContext {
public:
Mutator(SemanticsContext &context) : context_{context} {}
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} {}
template<typename A> bool Pre(A &) { return true /* visit children */; }
template<typename A> void Post(A &) {}
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 &);
bool Pre(parser::Statement<parser::AssignmentStmt> &stmt) {
AnalyzeAssignment(context_, stmt);
template<typename A> void Analyze(const parser::Statement<A> &stmt) {
AssignmentContext nested{*this, stmt.source};
nested.Analyze(stmt.statement);
}
template<typename A> void Analyze(const common::Indirection<A> &x) {
Analyze(*x);
}
template<typename... As> void Analyze(const std::variant<As...> &u) {
std::visit([&](const auto &x) { Analyze(x); }, u);
}
private:
void Analyze(const parser::WhereBodyConstruct &constr) { Analyze(constr.u); }
void Analyze(const parser::WhereConstruct::MaskedElsewhere &);
void Analyze(const parser::WhereConstruct::Elsewhere &);
void Analyze(const parser::ForallAssignmentStmt &stmt) { Analyze(stmt.u); }
int GetIntegerKind(const std::optional<parser::IntegerTypeSpec> &);
MaskExpr GetMask(const parser::LogicalExpr &, bool defaultValue = true) const;
template<typename... A> parser::Message *Say(A... args) {
return messages_.Say(std::forward<A>(args)...);
}
SemanticsContext &context_;
parser::ContextualMessages messages_;
WhereContext *where_{nullptr};
ForallContext *forall_{nullptr};
};
void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
if (forall_ != nullptr) {
// TODO: Warn if some name in forall_->activeNames or its outer
// contexts does not appear on LHS
}
// TODO: Fortran 2003 ALLOCATABLE assignment semantics (automatic
// (re)allocation of LHS array when unallocated or nonconformable)
}
void 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 AssignmentContext::Analyze(const parser::WhereStmt &stmt) {
WhereContext where{GetMask(std::get<parser::LogicalExpr>(stmt.t))};
AssignmentContext nested{*this, where};
nested.Analyze(std::get<parser::AssignmentStmt>(stmt.t));
}
// N.B. Construct name matching is checked during label resolution.
void AssignmentContext::Analyze(const parser::WhereConstruct &construct) {
const auto &whereStmt{
std::get<parser::Statement<parser::WhereConstructStmt>>(construct.t)};
WhereContext where{
GetMask(std::get<parser::LogicalExpr>(whereStmt.statement.t))};
if (const auto &name{
std::get<std::optional<parser::Name>>(whereStmt.statement.t)}) {
where.constructName = name->source;
}
AssignmentContext nested{*this, where};
for (const auto &x :
std::get<std::list<parser::WhereBodyConstruct>>(construct.t)) {
nested.Analyze(x);
}
for (const auto &x :
std::get<std::list<parser::WhereConstruct::MaskedElsewhere>>(
construct.t)) {
nested.Analyze(x);
}
if (const auto &x{std::get<std::optional<parser::WhereConstruct::Elsewhere>>(
construct.t)}) {
nested.Analyze(*x);
}
}
void AssignmentContext::Analyze(const parser::ForallStmt &stmt) {
CHECK(!where_);
ForallContext forall{forall_};
AssignmentContext nested{*this, forall};
nested.Analyze(
std::get<common::Indirection<parser::ConcurrentHeader>>(stmt.t));
nested.Analyze(std::get<parser::ForallAssignmentStmt>(stmt.t));
}
// N.B. Construct name matching is checked during label resolution;
// index name distinction is checked during name resolution.
void AssignmentContext::Analyze(const parser::ForallConstruct &construct) {
CHECK(!where_);
ForallContext forall{forall_};
AssignmentContext nested{*this, forall};
const auto &forallStmt{
std::get<parser::Statement<parser::ForallConstructStmt>>(construct.t)
.statement};
nested.Analyze(
std::get<common::Indirection<parser::ConcurrentHeader>>(forallStmt.t));
for (const auto &body :
std::get<std::list<parser::ForallBodyConstruct>>(construct.t)) {
nested.Analyze(body.u);
}
}
void AssignmentContext::Analyze(
const parser::WhereConstruct::MaskedElsewhere &elsewhere) {
CHECK(where_ != nullptr);
const auto &elsewhereStmt{
std::get<parser::Statement<parser::MaskedElsewhereStmt>>(elsewhere.t)};
MaskExpr mask{
GetMask(std::get<parser::LogicalExpr>(elsewhereStmt.statement.t))};
MaskExpr copyCumulative{where_->cumulativeMaskExpr};
MaskExpr notOldMask{evaluate::LogicalNegation(std::move(copyCumulative))};
if (!evaluate::AreConformable(notOldMask, mask)) {
Say(elsewhereStmt.source,
"mask of ELSEWHERE statement is not conformable with "
"the prior mask(s) in its WHERE construct"_err_en_US);
}
MaskExpr copyMask{mask};
where_->cumulativeMaskExpr =
evaluate::BinaryLogicalOperation(evaluate::LogicalOperator::Or,
std::move(where_->cumulativeMaskExpr), std::move(copyMask));
where_->thisMaskExpr = evaluate::BinaryLogicalOperation(
evaluate::LogicalOperator::And, std::move(notOldMask), std::move(mask));
if (where_->outer != nullptr &&
!evaluate::AreConformable(
where_->outer->thisMaskExpr, where_->thisMaskExpr)) {
Say(elsewhereStmt.source,
"effective mask of ELSEWHERE statement is not conformable "
"with the mask of the surrounding WHERE construct"_err_en_US);
}
for (const auto &x :
std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t)) {
Analyze(x);
}
}
void AssignmentContext::Analyze(
const parser::WhereConstruct::Elsewhere &elsewhere) {
CHECK(where_ != nullptr);
MaskExpr copyCumulative{where_->cumulativeMaskExpr};
where_->thisMaskExpr = evaluate::LogicalNegation(std::move(copyCumulative));
for (const auto &x :
std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t)) {
Analyze(x);
}
}
void AssignmentContext::Analyze(const parser::ConcurrentHeader &header) {
CHECK(forall_ != nullptr);
forall_->integerKind = GetIntegerKind(
std::get<std::optional<parser::IntegerTypeSpec>>(header.t));
for (const auto &control :
std::get<std::list<parser::ConcurrentControl>>(header.t)) {
const parser::CharBlock &name{std::get<parser::Name>(control.t).source};
bool inserted{forall_->activeNames.insert(name).second};
CHECK(inserted);
}
}
int AssignmentContext::GetIntegerKind(
const std::optional<parser::IntegerTypeSpec> &spec) {
std::optional<parser::KindSelector> empty;
evaluate::Expr<evaluate::SubscriptInteger> kind{AnalyzeKindSelector(
context_, messages_.at(), TypeCategory::Integer, spec ? spec->v : empty)};
if (auto value{evaluate::ToInt64(kind)}) {
return static_cast<int>(*value);
} else {
Say("Kind of INTEGER type must be a constant value"_err_en_US);
return context_.defaultKinds().GetDefaultKind(TypeCategory::Integer);
}
}
MaskExpr AssignmentContext::GetMask(
const parser::LogicalExpr &expr, bool defaultValue) const {
MaskExpr mask{defaultValue};
if (auto maybeExpr{AnalyzeExpr(context_, expr)}) {
auto *logical{
std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&maybeExpr->u)};
CHECK(logical != nullptr);
mask = evaluate::ConvertTo(mask, std::move(*logical));
}
return mask;
}
void AnalyzeConcurrentHeader(
SemanticsContext &context, const parser::ConcurrentHeader &header) {
AssignmentContext{context}.Analyze(header);
}
namespace {
class Visitor {
public:
Visitor(SemanticsContext &context) : context_{context} {}
template<typename A> bool Pre(const A &) { return true /* visit children */; }
template<typename A> void Post(const A &) {}
bool Pre(const parser::Statement<parser::AssignmentStmt> &stmt) {
AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
return false;
}
bool Pre(const parser::Statement<parser::PointerAssignmentStmt> &stmt) {
AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
return false;
}
bool Pre(const parser::Statement<parser::WhereStmt> &stmt) {
AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
return false;
}
bool Pre(const parser::WhereConstruct &construct) {
AssignmentContext{context_}.Analyze(construct);
return false;
}
bool Pre(const parser::Statement<parser::ForallStmt> &stmt) {
AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
return false;
}
bool Pre(const parser::ForallConstruct &construct) {
AssignmentContext{context_}.Analyze(construct);
return false;
}
private:
SemanticsContext &context_;
};
}
void AnalyzeAssignments(parser::Program &program, SemanticsContext &context) {
Mutator mutator{context};
parser::Walk(program, mutator);
Visitor visitor{context};
parser::Walk(program, visitor);
}
}

8
flang/lib/semantics/assignment.h
View File

@ -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<typename> struct Statement;
struct AssignmentStmt;
struct ConcurrentHeader;
struct ForallStmt;
struct PointerAssignmentStmt;
struct Program;
@ -37,6 +38,11 @@ void AnalyzeAssignment(
void AnalyzeAssignment(
SemanticsContext &, const parser::Statement<parser::ForallStmt> &);
// R1125 concurrent-header is used in FORALL statements & constructs as
// well as in DO CONCURRENT loops.
void AnalyzeConcurrentHeader(
SemanticsContext &, const parser::ConcurrentHeader &);
// Semantic analysis of all assignment statements and related constructs.
void AnalyzeAssignments(parser::Program &, SemanticsContext &);
}

53
flang/lib/semantics/dump-parse-tree.h
View File

@ -715,11 +715,10 @@ public:
#undef NODE_NAME
template<typename T> bool Pre(const T &x) {
IndentEmptyLine();
if (UnionTrait<T> || WrapperTrait<T>) {
out_ << GetNodeName(x) << " -> ";
emptyline_ = false;
Prefix(GetNodeName(x));
} else {
IndentEmptyLine();
out_ << GetNodeName(x);
EndLine();
++indent_;
@ -786,10 +785,16 @@ public:
template<typename T> bool Pre(const common::Indirection<T> &) { return true; }
template<typename T> void Post(const common::Indirection<T> &) {}
template<typename A> bool Pre(const parser::Scalar<A> &) {
Prefix("Scalar");
return true;
}
template<typename A> void Post(const parser::Scalar<A> &) {
EndLineIfNonempty();
}
template<typename A> bool Pre(const parser::Constant<A> &) {
IndentEmptyLine();
out_ << "Constant ->";
emptyline_ = false;
Prefix("Constant");
return true;
}
template<typename A> void Post(const parser::Constant<A> &) {
@ -797,20 +802,26 @@ public:
}
template<typename A> bool Pre(const parser::Integer<A> &) {
IndentEmptyLine();
out_ << "Integer ->";
emptyline_ = false;
Prefix("Integer");
return true;
}
template<typename A> void Post(const parser::Integer<A> &) {}
template<typename A> void Post(const parser::Integer<A> &) {
EndLineIfNonempty();
}
template<typename A> bool Pre(const parser::Scalar<A> &) {
IndentEmptyLine();
out_ << "Scalar ->";
emptyline_ = false;
template<typename A> bool Pre(const parser::Logical<A> &) {
Prefix("Logical");
return true;
}
template<typename A> void Post(const parser::Scalar<A> &) {
template<typename A> void Post(const parser::Logical<A> &) {
EndLineIfNonempty();
}
template<typename A> bool Pre(const parser::DefaultChar<A> &) {
Prefix("DefaultChar");
return true;
}
template<typename A> void Post(const parser::DefaultChar<A> &) {
EndLineIfNonempty();
}
@ -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;

123
flang/lib/semantics/expression.cc
View File

@ -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 <functional>
#include <iostream> // TODO pmk rm
#include <optional>
#include <iostream> // TODO pmk rm
// Typedef for optional generic expressions (ubiquitous in this file)
using MaybeExpr =
std::optional<Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>;
@ -662,6 +664,17 @@ struct TypeParamInquiryVisitor {
const Symbol &parameter;
};
static std::optional<Expr<SomeInteger>> MakeTypeParamInquiry(
const Symbol *symbol) {
if (std::optional<DynamicType> dyType{GetSymbolType(symbol)}) {
if (dyType->category == TypeCategory::Integer) {
return common::SearchDynamicTypes(TypeParamInquiryVisitor{
dyType->kind, SymbolOrComponent{nullptr}, *symbol});
}
}
return std::nullopt;
}
// Names and named constants
static MaybeExpr AnalyzeExpr(
ExpressionAnalysisContext &context, const parser::Name &n) {
@ -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<semantics::TypeParamDetails>()) {
// A bare reference to a derived type parameter (within the type definition)
if (std::optional<DynamicType> dyType{GetSymbolType(n.symbol)}) {
if (dyType->category == TypeCategory::Integer) {
return AsMaybeExpr(common::SearchDynamicTypes(TypeParamInquiryVisitor{
dyType->kind, SymbolOrComponent{nullptr}, *n.symbol}));
}
}
// A bare reference to a derived type parameter (within a parameterized
// derived type definition)
return AsMaybeExpr(MakeTypeParamInquiry(n.symbol));
} else if (MaybeExpr result{Designate(DataRef{*n.symbol})}) {
return result;
} else {
@ -897,6 +906,22 @@ static SymbolOrComponent IgnoreAnySubscripts(
std::move(designator.u));
}
// Components of parent derived types are explicitly represented as such.
static std::optional<Component> CreateComponent(
DataRef &&base, const Symbol &component, const semantics::Scope &scope) {
if (&component.owner() == &scope) {
return {Component{std::move(base), component}};
}
if (const semantics::Scope * parentScope{scope.GetDerivedTypeParent()}) {
if (const Symbol * parentComponent{parentScope->GetSymbol()}) {
return CreateComponent(
DataRef{Component{std::move(base), *parentComponent}}, component,
*parentScope);
}
}
return std::nullopt;
}
// Derived type component references and type parameter inquiries
static MaybeExpr AnalyzeExpr(
ExpressionAnalysisContext &context, const parser::StructureComponent &sc) {
@ -914,27 +939,28 @@ static MaybeExpr AnalyzeExpr(
if (sym->detailsIf<semantics::TypeParamDetails>()) {
if (auto *designator{UnwrapExpr<Designator<SomeDerived>>(*dtExpr)}) {
std::optional<DynamicType> dyType{GetSymbolType(sym)};
if (dyType.has_value() && dyType->category == TypeCategory::Integer) {
return AsMaybeExpr(
common::SearchDynamicTypes(TypeParamInquiryVisitor{dyType->kind,
IgnoreAnySubscripts(std::move(*designator)), *sym}));
}
CHECK(dyType.has_value());
CHECK(dyType->category == TypeCategory::Integer);
return AsMaybeExpr(
common::SearchDynamicTypes(TypeParamInquiryVisitor{dyType->kind,
IgnoreAnySubscripts(std::move(*designator)), *sym}));
} else {
context.Say(name,
"type parameter inquiry must be applied to a designator"_err_en_US);
}
} else if (dtSpec == nullptr) {
} else if (dtSpec == nullptr || dtSpec->scope() == nullptr) {
context.Say(name,
"TODO: base of component reference lacks a derived type"_err_en_US);
} else if (&sym->owner() != dtSpec->scope()) {
// TODO: extended derived types - insert explicit reference to base?
context.Say(name,
"component is not in scope of derived TYPE(%s)"_err_en_US,
dtSpec->typeSymbol().name().ToString().data());
} else if (std::optional<DataRef> dataRef{
ExtractDataRef(std::move(*dtExpr))}) {
Component component{std::move(*dataRef), *sym};
return Designate(DataRef{std::move(component)});
if (auto component{
CreateComponent(std::move(*dataRef), *sym, *dtSpec->scope())}) {
return Designate(DataRef{std::move(*component)});
} else {
context.Say(name,
"component is not in scope of derived TYPE(%s)"_err_en_US,
dtSpec->typeSymbol().name().ToString().data());
}
} else {
context.Say(name,
"base of component reference must be a data reference"_err_en_US);
@ -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<FunctionRef, ProcedureRef>(*func.type,
ProcedureRef{ProcedureDesignator{std::move(func)},
@ -1071,7 +1097,7 @@ static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &context,
std::visit(
common::visitors{
[&](const common::Indirection<parser::Variable> &v) {
actualArgExpr = AnalyzeExpr(context, v);
actualArgExpr = AnalyzeExpr(context, *v);
},
[&](const common::Indirection<parser::Expr> &x) {
actualArgExpr = AnalyzeExpr(context, *x);
@ -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<CallAndArguments> proc{Procedure(context,
std::get<parser::ProcedureDesignator>(funcRef.v.t), arguments)}) {
if (std::optional<DynamicType> dyType{
@ -1417,44 +1442,51 @@ MaybeExpr ExpressionAnalysisContext::Analyze(const parser::Variable &variable) {
return AnalyzeExpr(*this, variable.u);
}
int ExpressionAnalysisContext::Analyze(TypeCategory category,
Expr<SubscriptInteger> ExpressionAnalysisContext::Analyze(TypeCategory category,
const std::optional<parser::KindSelector> &selector) {
int defaultKind{GetDefaultKind(category)};
if (!selector.has_value()) {
return defaultKind;
return Expr<SubscriptInteger>{defaultKind};
}
return std::visit(
common::visitors{
[&](const parser::ScalarIntConstantExpr &x) -> int {
[&](const parser::ScalarIntConstantExpr &x)
-> Expr<SubscriptInteger> {
if (MaybeExpr kind{AnalyzeExpr(*this, x)}) {
MaybeExpr folded{Fold(GetFoldingContext(), std::move(kind))};
if (std::optional<std::int64_t> code{ToInt64(*folded)}) {
Expr<SomeType> folded{
Fold(GetFoldingContext(), std::move(*kind))};
if (std::optional<std::int64_t> code{ToInt64(folded)}) {
if (IsValidKindOfIntrinsicType(category, *code)) {
return *code;
return Expr<SubscriptInteger>{*code};
}
SayAt(x, "%s(kind=%jd) is not a supported type"_err_en_US,
EnumToString(category).data(), *code);
SayAt(x, "%s(KIND=%jd) is not a supported type"_err_en_US,
parser::ToUpperCaseLetters(EnumToString(category)).data(),
*code);
} else if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(folded)}) {
return ConvertToType<SubscriptInteger>(std::move(*intExpr));
}
}
return defaultKind;
return Expr<SubscriptInteger>{defaultKind};
},
[&](const parser::KindSelector::StarSize &x) -> int {
[&](const parser::KindSelector::StarSize &x)
-> Expr<SubscriptInteger> {
std::intmax_t size = x.v;
if (category == TypeCategory::Complex) {
// COMPLEX*16 == COMPLEX(KIND=8)
if ((size % 2) != 0 ||
!evaluate::IsValidKindOfIntrinsicType(category, size / 2)) {
Say("Complex*%jd is not a supported type"_err_en_US, size);
return defaultKind;
if ((size % 2) == 0 &&
evaluate::IsValidKindOfIntrinsicType(category, size / 2)) {
size /= 2;
} else {
Say("COMPLEX*%jd is not a supported type"_err_en_US, size);
size = defaultKind;
}
return size / 2;
} else if (!evaluate::IsValidKindOfIntrinsicType(category, size)) {
Say("%s*%jd is not a supported type"_err_en_US,
EnumToString(category).data(), size);
return defaultKind;
} else {
return size;
parser::ToUpperCaseLetters(EnumToString(category)).data(),
size);
size = defaultKind;
}
return Expr<SubscriptInteger>{size};
},
},
selector->u);
@ -1504,7 +1536,8 @@ void AnalyzeExpressions(parser::Program &program, SemanticsContext &context) {
parser::Walk(program, visitor);
}
int AnalyzeKindSelector(SemanticsContext &context, parser::CharBlock source,
evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
SemanticsContext &context, parser::CharBlock source,
common::TypeCategory category,
const std::optional<parser::KindSelector> &selector) {
evaluate::ExpressionAnalysisContext exprContext{context};

8
flang/lib/semantics/expression.h
View File

@ -92,7 +92,7 @@ public:
std::optional<Expr<SomeType>> Analyze(const parser::Expr &);
std::optional<Expr<SomeType>> Analyze(const parser::Variable &);
int Analyze(common::TypeCategory category,
Expr<SubscriptInteger> Analyze(common::TypeCategory category,
const std::optional<parser::KindSelector> &);
int GetDefaultKind(common::TypeCategory);
@ -245,8 +245,8 @@ std::optional<evaluate::Expr<evaluate::SomeType>> 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<parser::KindSelector> &);
evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
SemanticsContext &, parser::CharBlock, common::TypeCategory,
const std::optional<parser::KindSelector> &);
}
#endif // FORTRAN_SEMANTICS_EXPRESSION_H_

445
flang/lib/semantics/resolve-names.cc
View File

@ -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 <list>
@ -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<typename T> 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<typename T> MaybeExpr EvaluateExpr(const T &expr) {
if (auto maybeExpr{AnalyzeExpr(*context_, expr)}) {
return evaluate::Fold(context_->foldingContext(), std::move(*maybeExpr));
} else {
return std::nullopt;
}
auto maybeExpr{AnalyzeExpr(*context_, expr)};
return evaluate::Fold(GetFoldingContext(), std::move(maybeExpr));
}
template<typename T> MaybeIntExpr EvaluateIntExpr(const T &expr) {
@ -147,7 +163,7 @@ public:
template<typename T>
MaybeSubscriptIntExpr EvaluateSubscriptIntExpr(const T &expr) {
if (MaybeIntExpr maybeIntExpr{EvaluateIntExpr(expr)}) {
return evaluate::Fold(context_->foldingContext(),
return evaluate::Fold(GetFoldingContext(),
evaluate::ConvertToType<evaluate::SubscriptInteger>(
std::move(*maybeIntExpr)));
} else {
@ -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<parser::KindSelector> &);
private:
State state_;
void MakeNumericType(
TypeCategory, const std::optional<parser::KindSelector> &);
void MakeNumericType(TypeCategory, int kind);
int GetKindParamValue(
TypeCategory, const std::optional<parser::KindSelector> &);
};
// Visit ImplicitStmt and related parse tree nodes and updates implicit rules.
@ -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<parser::KindSelector> &);
DeclTypeSpec &MakeLogicalType(const std::optional<parser::KindSelector> &);
// Walk the ModuleSubprogramPart or InternalSubprogramPart collecting names.
template<typename T>
void WalkSubprogramPart(const std::optional<T> &subpPart) {
@ -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<ParamValue> length;
int kind{0};
std::optional<KindExpr> 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<parser::TypeParamValue>(x.t)};
if (const auto &keyword{std::get<std::optional<parser::Keyword>>(x.t)}) {
derivedTypeSpec.AddParamValue(keyword->v.source, GetParamValue(value));
} else {
derivedTypeSpec.AddParamValue(GetParamValue(value));
}
}
ParamValue DeclTypeSpecVisitor::GetParamValue(const parser::TypeParamValue &x) {
return std::visit(
common::visitors{
[=](const parser::ScalarIntExpr &x) {
return ParamValue{EvaluateIntExpr(x)};
},
[](const parser::Star &) { return ParamValue::Assumed(); },
[](const parser::TypeParamValue::Deferred &) {
return ParamValue::Deferred();
},
},
x.u);
void DeclTypeSpecVisitor::SetDeclTypeSpecCategory(
DeclTypeSpec::Category category) {
CHECK(state_.expectDeclTypeSpec);
state_.derived.category = category;
}
bool DeclTypeSpecVisitor::Pre(const parser::TypeGuardStmt &) {
@ -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<parser::KindSelector> &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<parser::KindSelector> &kind) {
if (!kind) {
return 0;
}
// TODO: check that we get a valid kind
return std::visit(
common::visitors{
[&](const parser::ScalarIntConstantExpr &x) -> int {
if (auto maybeExpr{EvaluateExpr(x)}) {
if (auto intConst{evaluate::ToInt64(*maybeExpr)}) {
return *intConst;
}
}
return 0;
},
[&](const parser::KindSelector::StarSize &x) -> int {
std::uint64_t size{x.v};
if (category == TypeCategory::Complex) {
size /= 2;
}
return size;
},
},
kind->u);
return AnalyzeKindSelector(context(), *currStmtSource(), category, kind);
}
// MessageHandler implementation
@ -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<TypeParamDetails>()) {
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<parser::KindSelector> &kind) {
KindExpr value{GetKindParamExpr(category, kind)};
if (auto known{evaluate::ToInt64(value)}) {
return context().MakeNumericType(category, static_cast<int>(*known));
} else {
return currScope_->MakeNumericType(category, std::move(value));
}
}
DeclTypeSpec &ScopeHandler::MakeLogicalType(
const std::optional<parser::KindSelector> &kind) {
KindExpr value{GetKindParamExpr(TypeCategory::Logical, kind)};
if (auto known{evaluate::ToInt64(value)}) {
return context().MakeLogicalType(static_cast<int>(*known));
} else {
return currScope_->MakeLogicalType(std::move(value));
}
}
// ModuleVisitor implementation
bool ModuleVisitor::Pre(const parser::Only &x) {
@ -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<std::int64_t> kind{evaluate::ToInt64(*maybeExpr)}) {
charInfo_.kind = *kind;
} else {
common::die("TODO: kind did not evaluate to a constant integer");
}
}
charInfo_.kind = EvaluateSubscriptIntExpr(x.kind);
if (x.length) {
charInfo_.length = GetParamValue(*x.length);
}
@ -2537,21 +2545,131 @@ void DeclarationVisitor::Post(const parser::LengthSelector &x) {
}
}
bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) {
return true; // TODO
bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Type &x) {
CHECK(GetDeclTypeSpecCategory() == DeclTypeSpec::Category::TypeDerived);
return true;
}
bool DeclarationVisitor::Pre(const parser::DerivedTypeSpec &x) {
const auto &typeName{std::get<parser::Name>(x.t)};
if (const auto *symbol{ResolveDerivedType(typeName)}) {
SetDerivedTypeSpec(currScope(), typeName).set_scope(*symbol->scope());
}
bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Class &x) {
SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived);
return true;
}
bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) {
// TODO
return true;
}
void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) {
const auto &typeName{std::get<parser::Name>(x.t)};
const Symbol *typeSymbol{ResolveDerivedType(&typeName)};
if (typeSymbol == nullptr) {
return;
}
// This DerivedTypeSpec is created initially as a search key.
// If it turns out to have the same name and actual parameter
// value expressions as some other DerivedTypeSpec in the current
// scope, then we'll use that extant spec; otherwise, when this
// spec is distinct from all derived types previously instantiated
// in the current scope, this spec will be moved to that collection.
DerivedTypeSpec spec{*typeSymbol};
// The expressions in a derived type specifier whose values define
// non-defaulted type parameters are evaluated in the enclosing scope.
// Default initialization expressions for the derived type's parameters
// may reference other parameters so long as the declaration precedes the
// use in the expression (10.1.12). This is not necessarily the same
// order as "type parameter order" (7.5.3.2).
// Parameters of the most deeply nested "base class" come first when the
// derived type is an extension.
const DerivedTypeDetails &typeDetails{typeSymbol->get<DerivedTypeDetails>()};
auto parameterNames{typeDetails.OrderParameterNames(*typeSymbol)};
auto nextNameIter{parameterNames.begin()};
bool seenAnyName{false};
for (const auto &typeParamSpec :
std::get<std::list<parser::TypeParamSpec>>(x.t)) {
const auto &optKeyword{
std::get<std::optional<parser::Keyword>>(typeParamSpec.t)};
SourceName name;
if (optKeyword.has_value()) {
seenAnyName = true;
name = optKeyword->v.source;
if (std::find(parameterNames.begin(), parameterNames.end(), name) ==
parameterNames.end()) {
Say(name,
"'%s' is not the name of a parameter for this type"_err_en_US);
}
} else if (seenAnyName) {
Say(typeName.source, "Type parameter value must have a name"_err_en_US);
continue;
} else if (nextNameIter != parameterNames.end()) {
name = *nextNameIter++;
} else {
Say(typeName.source,
"Too many type parameters given for derived type '%s'"_err_en_US);
break;
}
if (spec.FindParameter(name)) {
Say(typeName.source,
"Multiple values given for type parameter '%s'"_err_en_US, name);
} else {
const auto &value{std::get<parser::TypeParamValue>(typeParamSpec.t)};
ParamValue param{GetParamValue(value)}; // folded
if (!param.isExplicit() || param.GetExplicit().has_value()) {
spec.AddParamValue(name, std::move(param));
}
}
}
// Ensure that any type parameter without an explicit value has a
// default initialization in the derived type's definition.
const Scope *typeScope{typeSymbol->scope()};
CHECK(typeScope != nullptr);
for (const SourceName &name : parameterNames) {
if (!spec.FindParameter(name)) {
const Symbol *symbol{FindInTypeOrParents(*typeScope, name)};
CHECK(symbol != nullptr);
const auto *details{symbol->detailsIf<TypeParamDetails>()};
if (details == nullptr || !details->init().has_value()) {
Say(typeName.source,
"Type parameter '%s' lacks a value and has no default"_err_en_US,
symbol->name());
}
}
}
auto category{GetDeclTypeSpecCategory()};
if (const DeclTypeSpec *
extant{currScope().FindInstantiatedDerivedType(spec, category)}) {
// This derived type and parameter expressions (if any) are already present
// in this scope.
SetDeclTypeSpec(*extant);
} else {
DeclTypeSpec &type{currScope().MakeDerivedType(std::move(spec), category)};
if (parameterNames.empty() || currScope().IsParameterizedDerivedType()) {
// The derived type being instantiated is not a parameterized derived
// type, or the instantiation is within the definition of a parameterized
// derived type; don't instantiate a new scope.
type.derivedTypeSpec().set_scope(*typeScope);
} else {
// This is a parameterized derived type and this spec is not in the
// context of a parameterized derived type definition, so we need to
// clone its contents, specialize them with the actual type parameter
// values, and check constraints.
auto inLocation{
GetFoldingContext().messages.SetLocation(*currStmtSource())};
type.derivedTypeSpec().Instantiate(currScope(), GetFoldingContext());
}
SetDeclTypeSpec(type);
}
}
void DeclarationVisitor::Post(const parser::DerivedTypeDef &x) {
std::set<SourceName> paramNames;
auto &scope{currScope()};
CHECK(scope.symbol() != nullptr);
CHECK(scope.symbol()->scope() == &scope);
auto &details{scope.symbol()->get<DerivedTypeDetails>()};
auto &stmt{std::get<parser::Statement<parser::DerivedTypeStmt>>(x.t)};
for (auto &paramName : std::get<std::list<parser::Name>>(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<DerivedTypeDetails>().set_extends(extendsName->source);
// Declare the "parent component"; private if the type is
if (OkToAddComponent(*extendsName, extends)) {
symbol.get<DerivedTypeDetails>().set_extends(extendsName->source);
auto &comp{DeclareEntity<ObjectEntityDetails>(*extendsName, Attrs{})};
comp.attrs().set(Attr::PRIVATE, extends->attrs().test(Attr::PRIVATE));
comp.set(Symbol::Flag::ParentComp);
DerivedTypeSpec &derived{currScope().MakeDerivedType(*extends)};
derived.set_scope(currScope());
comp.SetType(
currScope().MakeDerivedType(DeclTypeSpec::TypeDerived, derived));
DeclTypeSpec &type{currScope().MakeDerivedType(*extends)};
type.derivedTypeSpec().set_scope(*extends->scope());
comp.SetType(type);
}
}
}
@ -2785,7 +2902,8 @@ bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) {
if (!genericSymbol->has<GenericBindingDetails>()) {
genericSymbol = nullptr; // MakeTypeSymbol will report the error below
}
} else if (const auto *inheritedSymbol{FindTypeSymbol(*genericName)}) {
} else if (const auto *inheritedSymbol{
FindInTypeOrParents(genericName->source)}) {
// look in parent types:
if (inheritedSymbol->has<GenericBindingDetails>()) {
inheritedProcs =
@ -2809,7 +2927,7 @@ bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) {
details.add_specificProcs(*inheritedProcs);
}
for (const auto &bindingName : std::get<std::list<parser::Name>>(x.t)) {
const auto *symbol{FindTypeSymbol(bindingName)};
const auto *symbol{FindInTypeOrParents(bindingName.source)};
if (!symbol) {
Say(bindingName,
"Binding name '%s' not found in this derived type"_err_en_US);
@ -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<ProcBindingDetails>(details)) {
attrs.set(Attr::PRIVATE);
}
return &MakeSymbol(name, attrs, details);
Symbol &result{MakeSymbol(name, attrs, details)};
if (result.has<TypeParamDetails>()) {
derivedType.symbol()->get<DerivedTypeDetails>().add_paramDecl(result);
}
return &result;
}
}
@ -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<parser::LoopBounds<parser::ScalarIntConstantExpr>>(x.t)};
if (type) {
BeginDeclTypeSpec();
DeclTypeSpecVisitor::Post(*type);
DeclarationVisitor::Post(*type);
}
if (auto *symbol{DeclareConstructEntity(bounds.name.thing.thing)}) {
CheckIntegerType(*symbol);
@ -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<parser::Name>(&x.u)}) {
auto *symbol{FindSymbol(*name)};

145
flang/lib/semantics/scope.cc
View File

@ -14,6 +14,9 @@
#include "scope.h"
#include "symbol.h"
#include "type.h"
#include "../evaluate/fold.h"
#include "../parser/characters.h"
#include <algorithm>
#include <memory>
@ -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<DerivedTypeDetails>());
CHECK(typeSymbol.scope() != nullptr);
return MakeDerivedType(
DerivedTypeSpec{typeSymbol}, DeclTypeSpec::TypeDerived);
}
DeclTypeSpec &Scope::MakeDerivedType(
DerivedTypeSpec &&instance, DeclTypeSpec::Category category) {
return declTypeSpecs_.emplace_back(
category, DerivedTypeSpec{std::move(instance)});
}
Scope::ImportKind Scope::GetImportKind() const {
if (importKind_) {
return *importKind_;
@ -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<TypeParamDetails>()) {
return true;
}
}
return false;
}
const DeclTypeSpec *Scope::FindInstantiatedDerivedType(
const DerivedTypeSpec &spec, DeclTypeSpec::Category category) const {
DeclTypeSpec type{category, spec};
auto typeIter{std::find(declTypeSpecs_.begin(), declTypeSpecs_.end(), type)};
if (typeIter != declTypeSpecs_.end()) {
return &*typeIter;
}
return nullptr;
}
const DeclTypeSpec &Scope::FindOrInstantiateDerivedType(DerivedTypeSpec &&spec,
DeclTypeSpec::Category category, evaluate::FoldingContext &foldingContext) {
spec.FoldParameterExpressions(foldingContext);
if (const DeclTypeSpec * type{FindInstantiatedDerivedType(spec, category)}) {
return *type;
}
// Create a new instantiation of this parameterized derived type
// for this particular distinct set of actual parameter values.
DeclTypeSpec &type{MakeDerivedType(std::move(spec), category)};
type.derivedTypeSpec().Instantiate(*this, foldingContext);
return type;
}
void Scope::InstantiateDerivedType(
Scope &clone, evaluate::FoldingContext &foldingContext) const {
clone.sourceRange_ = sourceRange_;
clone.chars_ = chars_;
for (const auto &pair : symbols_) {
pair.second->Instantiate(clone, foldingContext);
}
}
const DeclTypeSpec &Scope::InstantiateIntrinsicType(
const DeclTypeSpec &spec, evaluate::FoldingContext &foldingContext) {
const IntrinsicTypeSpec *intrinsic{spec.AsIntrinsic()};
CHECK(intrinsic != nullptr);
if (evaluate::ToInt64(intrinsic->kind()).has_value()) {
return spec; // KIND is already a known constant
}
// The expression was not originally constant, but now it must be so
// in the context of a parameterized derived type instantiation.
KindExpr copy{intrinsic->kind()};
copy = evaluate::Fold(foldingContext, std::move(copy));
auto value{evaluate::ToInt64(copy)};
CHECK(value.has_value() &&
"KIND parameter of intrinsic type did not resolve to a "
"constant INTEGER value in a parameterized derived type instance");
if (!evaluate::IsValidKindOfIntrinsicType(intrinsic->category(), *value)) {
foldingContext.messages.Say(
"KIND parameter value (%jd) of intrinsic type %s did not resolve to a supported value"_err_en_US,
static_cast<std::intmax_t>(*value),
parser::ToUpperCaseLetters(common::EnumToString(intrinsic->category()))
.data());
}
switch (spec.category()) {
case DeclTypeSpec::Numeric:
return declTypeSpecs_.emplace_back(
NumericTypeSpec{intrinsic->category(), KindExpr{*value}});
case DeclTypeSpec::Logical:
return declTypeSpecs_.emplace_back(LogicalTypeSpec{KindExpr{*value}});
case DeclTypeSpec::Character:
return declTypeSpecs_.emplace_back(CharacterTypeSpec{
ParamValue{spec.characterTypeSpec().length()}, KindExpr{*value}});
default: CRASH_NO_CASE;
}
}
const Symbol *Scope::GetSymbol() const {
if (symbol_ != nullptr) {
return symbol_;
}
if (derivedTypeSpec_ != nullptr) {
return &derivedTypeSpec_->typeSymbol();
}
return nullptr;
}
const Scope *Scope::GetDerivedTypeParent() const {
if (const Symbol * symbol{GetSymbol()}) {
if (const DerivedTypeSpec * parent{symbol->GetParentTypeSpec(this)}) {
return parent->scope();
}
}
return nullptr;
}
}

58
flang/lib/semantics/scope.h
View File

@ -25,6 +25,10 @@
#include <set>
#include <string>
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<Scope> children_;
mapType symbols_;
std::map<SourceName, Scope *> submodules_;
std::list<DeclTypeSpec> declTypeSpecs_;
std::list<CharacterTypeSpec> characterTypeSpecs_;
std::list<DerivedTypeSpec> derivedTypeSpecs_;
std::string chars_;
std::optional<ImportKind> importKind_;
std::set<SourceName> importNames_;
const DerivedTypeSpec *derivedTypeSpec_{nullptr}; // dTS->scope() == this
// When additional data members are added to Scope, remember to
// copy them, if appropriate, in InstantiateDerivedType().
// Storage for all Symbols. Every Symbol is in allSymbols and every Symbol*
// or Symbol& points to one in there.

6
flang/lib/semantics/semantics.cc
View File

@ -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();
}

98
flang/lib/semantics/symbol.cc
View File

@ -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<TypeParamDetails>(); // 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<ObjectEntityDetails>()};
if (DeclTypeSpec * origType{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{origType->AsDerived()}) {
DerivedTypeSpec newSpec{*derived};
if (test(Flag::ParentComp)) {
// Forward all explicit type parameter values from the
// derived type spec under instantiation to this parent
// component spec when they define type parameters that
// pertain to the parent component.
for (const auto &pair : instanceSpec.parameters()) {
if (scope.find(pair.first) == scope.end()) {
newSpec.AddParamValue(
pair.first, ParamValue{pair.second});
}
}
}
details.ReplaceType(scope.FindOrInstantiateDerivedType(
std::move(newSpec), origType->category(), foldingContext));
} else if (origType->AsIntrinsic() != nullptr) {
const DeclTypeSpec &newType{
scope.InstantiateIntrinsicType(*origType, foldingContext)};
details.ReplaceType(newType);
} else {
common::die("instantiated component has type that is "
"neither intrinsic nor derived");
}
}
details.set_init(
evaluate::Fold(foldingContext, std::move(details.init())));
for (ShapeSpec &dim : details.shape()) {
@ -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<GenericBindingDetails>()};
for (const Symbol *sym : that.specificProcs()) {
details.add_specificProc(
sym->Instantiate(scope, spec, foldingContext));
details.add_specificProc(sym->Instantiate(scope, foldingContext));
}
},
[&](const TypeParamDetails &that) {
// LEN type parameter, or error recovery on a KIND type parameter
// with no corresponding actual argument or default
symbol.details_ = that;
TypeParamDetails &details{symbol.get<TypeParamDetails>()};
details.set_init(
evaluate::Fold(foldingContext, std::move(details.init())));
},
[&](const FinalProcDetails &that) { symbol.details_ = that; },
[&](const auto &) {
get<ObjectEntityDetails>(); // crashes with actual details
[&](const auto &that) {
common::die("unexpected details in Symbol::Instantiate");
},
},
details_);
return symbol;
}
const Symbol *Symbol::GetParent() const {
const Symbol *Symbol::GetParentComponent(const Scope *scope) const {
const auto &details{get<DerivedTypeDetails>()};
CHECK(scope_ != nullptr);
if (!details.extends().empty()) {
auto iter{scope_->find(details.extends())};
CHECK(iter != scope_->end());
const Symbol &parentComp{*iter->second};
CHECK(parentComp.test(Symbol::Flag::ParentComp));
const auto &object{parentComp.get<ObjectEntityDetails>()};
const DerivedTypeSpec *derived{object.type()->AsDerived()};
CHECK(derived != nullptr);
return &derived->typeSymbol();
if (scope == nullptr) {
CHECK(scope_ != nullptr);
scope = scope_;
}
if (details.extends().empty()) {
return nullptr;
}
auto iter{scope->find(details.extends())};
CHECK(iter != scope->end());
const Symbol &parentComp{*iter->second};
CHECK(parentComp.test(Symbol::Flag::ParentComp));
return &parentComp;
}
const DerivedTypeSpec *Symbol::GetParentTypeSpec(const Scope *scope) const {
if (const Symbol * parentComponent{GetParentComponent(scope)}) {
const auto &object{parentComponent->get<ObjectEntityDetails>()};
const DerivedTypeSpec *spec{object.type()->AsDerived()};
CHECK(spec != nullptr);
return spec;
} else {
return nullptr;
}
return nullptr;
}
std::list<SourceName> DerivedTypeDetails::OrderParameterNames(
const Symbol &type) const {
std::list<SourceName> result;
if (const Symbol * parent{type.GetParent()}) {
result = parent->get<DerivedTypeDetails>().OrderParameterNames(*parent);
if (const DerivedTypeSpec * spec{type.GetParentTypeSpec()}) {
const DerivedTypeDetails &details{
spec->typeSymbol().get<DerivedTypeDetails>()};
result = details.OrderParameterNames(spec->typeSymbol());
}
for (const auto &name : paramNames_) {
result.push_back(name);
@ -680,9 +717,10 @@ std::list<SourceName> DerivedTypeDetails::OrderParameterNames(
std::list<Symbol *> DerivedTypeDetails::OrderParameterDeclarations(
const Symbol &type) const {
std::list<Symbol *> result;
if (const Symbol * parent{type.GetParent()}) {
result =
parent->get<DerivedTypeDetails>().OrderParameterDeclarations(*parent);
if (const DerivedTypeSpec * spec{type.GetParentTypeSpec()}) {
const DerivedTypeDetails &details{
spec->typeSymbol().get<DerivedTypeDetails>()};
result = details.OrderParameterDeclarations(spec->typeSymbol());
}
for (Symbol *symbol : paramDecls_) {
result.push_back(symbol);

16
flang/lib/semantics/symbol.h
View File

@ -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<std::size_t> friend class Symbols;
template<class, std::size_t> friend struct std::array;
};

230
flang/lib/semantics/type.cc
View File

@ -21,47 +21,159 @@
#include "../evaluate/tools.h"
#include "../evaluate/type.h"
#include "../parser/characters.h"
#include <algorithm>
#include <sstream>
namespace Fortran::semantics {
DerivedTypeSpec::DerivedTypeSpec(const DerivedTypeSpec &that)
: typeSymbol_{that.typeSymbol_}, parameters_{that.parameters_} {}
DerivedTypeSpec::DerivedTypeSpec(DerivedTypeSpec &&that)
: typeSymbol_{that.typeSymbol_}, parameters_{std::move(that.parameters_)} {}
void DerivedTypeSpec::set_scope(const Scope &scope) {
CHECK(!scope_);
CHECK(scope.kind() == Scope::Kind::DerivedType);
scope_ = &scope;
}
void DerivedTypeSpec::AddParamValue(ParamValue &&value) {
paramValues_.emplace_back(std::nullopt, std::move(value));
bool DerivedTypeSpec::operator==(const DerivedTypeSpec &that) const {
return &typeSymbol_ == &that.typeSymbol_ && parameters_ == that.parameters_;
}
void DerivedTypeSpec::AddParamValue(
const SourceName &name, ParamValue &&value) {
paramValues_.emplace_back(name, std::move(value));
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;
}
ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
auto iter{parameters_.find(target)};
if (iter != parameters_.end()) {
return &iter->second;
} else {
return nullptr;
}
}
const ParamValue *DerivedTypeSpec::FindParameter(SourceName target) const {
auto iter{parameters_.find(target)};
if (iter != parameters_.end()) {
return &iter->second;
} else {
return nullptr;
}
}
void DerivedTypeSpec::FoldParameterExpressions(
evaluate::FoldingContext &foldingContext) {
for (auto &pair : parameters_) {
if (MaybeIntExpr expr{pair.second.GetExplicit()}) {
pair.second.SetExplicit(evaluate::Fold(foldingContext, std::move(*expr)));
}
}
}
void DerivedTypeSpec::Instantiate(
Scope &containingScope, evaluate::FoldingContext &origFoldingContext) {
CHECK(scope_ == nullptr);
Scope &newScope{containingScope.MakeScope(Scope::Kind::DerivedType)};
newScope.set_derivedTypeSpec(*this);
scope_ = &newScope;
const DerivedTypeDetails &typeDetails{typeSymbol_.get<DerivedTypeDetails>()};
// Evaluate any necessary default initial value expressions for those
// type parameters that lack explicit initialization. These expressions
// are evaluated in the scope of the derived type instance and follow the
// order in which their declarations appeared so as to allow later
// parameter values to depend on those of their predecessors.
// The folded values of the expressions replace the init() expressions
// of the parameters' symbols in the instantiation's scope.
evaluate::FoldingContext foldingContext{origFoldingContext};
foldingContext.pdtInstance = this;
for (Symbol *symbol : typeDetails.OrderParameterDeclarations(typeSymbol_)) {
const SourceName &name{symbol->name()};
const TypeParamDetails &details{symbol->get<TypeParamDetails>()};
MaybeIntExpr expr;
ParamValue *paramValue{FindParameter(name)};
if (paramValue != nullptr) {
expr = paramValue->GetExplicit();
} else {
expr = details.init();
expr = evaluate::Fold(foldingContext, std::move(expr));
}
// Ensure that any kind type parameters are constant by now.
if (details.attr() == common::TypeParamAttr::Kind && expr.has_value()) {
// Any errors in rank and type will have already elicited messages, so
// don't complain further here.
if (auto maybeDynamicType{expr->GetType()}) {
if (expr->Rank() == 0 &&
maybeDynamicType->category == TypeCategory::Integer &&
!evaluate::ToInt64(expr).has_value()) {
std::stringstream fortran;
expr->AsFortran(fortran);
if (auto *msg{foldingContext.messages.Say(
"Value of kind type parameter '%s' (%s) is not "
"scalar INTEGER constant"_err_en_US,
name.ToString().data(), fortran.str().data())}) {
msg->Attach(name, "declared here"_en_US);
}
}
}
}
if (expr.has_value()) {
const Scope *typeScope{typeSymbol_.scope()};
if (typeScope != nullptr &&
typeScope->find(symbol->name()) != typeScope->end()) {
// This type parameter belongs to the derived type itself, not
// one of its parents. Put the type parameter expression value
// into the new scope as the initialization value for the parameter
// so that type parameter inquiries can acquire it.
TypeParamDetails instanceDetails{details.attr()};
instanceDetails.set_init(std::move(*expr));
Symbol *parameter{newScope.try_emplace(name, std::move(instanceDetails))
.first->second};
CHECK(parameter != nullptr);
} else if (paramValue != nullptr) {
// Update the type parameter value in the spec for parent component
// derived type instantiation later (in symbol.cc) and folding.
paramValue->SetExplicit(std::move(*expr));
} else {
// Save the resolved value in the spec in case folding needs it.
AddParamValue(symbol->name(), ParamValue{std::move(*expr)});
}
}
}
// Instantiate every non-parameter symbol from the original derived
// type's scope into the new instance.
const Scope *typeScope{typeSymbol_.scope()};
CHECK(typeScope != nullptr);
typeScope->InstantiateDerivedType(newScope, foldingContext);
}
std::ostream &operator<<(std::ostream &o, const DerivedTypeSpec &x) {
o << x.typeSymbol().name().ToString();
if (!x.paramValues_.empty()) {
bool first = true;
if (!x.parameters_.empty()) {
o << '(';
for (const auto &[name, value] : x.paramValues_) {
bool first = true;
for (const auto &[name, value] : x.parameters_) {
if (first) {
first = false;
} else {
o << ',';
}
if (name) {
o << name->ToString() << '=';
}
o << value;
o << name.ToString() << '=' << value;
}
o << ')';
}
return o;
}
Bound::Bound(int bound)
: category_{Category::Explicit},
expr_{evaluate::Expr<evaluate::SubscriptInteger>{bound}} {}
Bound::Bound(int bound) : expr_{bound} {}
std::ostream &operator<<(std::ostream &o, const Bound &x) {
if (x.isAssumed()) {
@ -97,6 +209,15 @@ ParamValue::ParamValue(std::int64_t value)
: ParamValue(SomeIntExpr{evaluate::Expr<evaluate::SubscriptInteger>{value}}) {
}
void ParamValue::SetExplicit(SomeIntExpr &&x) {
category_ = Category::Explicit;
expr_ = std::move(x);
}
bool ParamValue::operator==(const ParamValue &that) const {
return category_ == that.category_ && expr_ == that.expr_;
}
std::ostream &operator<<(std::ostream &o, const ParamValue &x) {
if (x.isAssumed()) {
o << '*';
@ -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<NumericTypeSpec>(typeSpec_);
case Logical: return &std::get<LogicalTypeSpec>(typeSpec_);
case Character: return &std::get<CharacterTypeSpec>(typeSpec_);
default: return nullptr;
}
}
const IntrinsicTypeSpec *DeclTypeSpec::AsIntrinsic() const {
switch (category_) {
case Numeric: return &typeSpec_.numeric;
case Logical: return &typeSpec_.logical;
case Character: return typeSpec_.character;
case Numeric: return &std::get<NumericTypeSpec>(typeSpec_);
case Logical: return &std::get<LogicalTypeSpec>(typeSpec_);
case Character: return &std::get<CharacterTypeSpec>(typeSpec_);
default: return nullptr;
}
}
const DerivedTypeSpec *DeclTypeSpec::AsDerived() const {
switch (category_) {
case TypeDerived:
case ClassDerived: return typeSpec_.derived;
case ClassDerived: return &std::get<DerivedTypeSpec>(typeSpec_);
default: return nullptr;
}
}
const NumericTypeSpec &DeclTypeSpec::numericTypeSpec() const {
CHECK(category_ == Numeric);
return typeSpec_.numeric;
return std::get<NumericTypeSpec>(typeSpec_);
}
const LogicalTypeSpec &DeclTypeSpec::logicalTypeSpec() const {
CHECK(category_ == Logical);
return typeSpec_.logical;
return std::get<LogicalTypeSpec>(typeSpec_);
}
const CharacterTypeSpec &DeclTypeSpec::characterTypeSpec() const {
CHECK(category_ == Character);
return *typeSpec_.character;
return std::get<CharacterTypeSpec>(typeSpec_);
}
const DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() const {
CHECK(category_ == TypeDerived || category_ == ClassDerived);
return *typeSpec_.derived;
return std::get<DerivedTypeSpec>(typeSpec_);
}
DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() {
CHECK(category_ == TypeDerived || category_ == ClassDerived);
return std::get<DerivedTypeSpec>(typeSpec_);
}
bool DeclTypeSpec::operator==(const DeclTypeSpec &that) const {
if (category_ != that.category_) {
return false;
}
switch (category_) {
case Numeric: return typeSpec_.numeric == that.typeSpec_.numeric;
case Logical: return typeSpec_.logical == that.typeSpec_.logical;
case Character: return typeSpec_.character == that.typeSpec_.character;
case TypeDerived:
case ClassDerived: return typeSpec_.derived == that.typeSpec_.derived;
default: return true;
}
return category_ == that.category_ && typeSpec_ == that.typeSpec_;
}
std::ostream &operator<<(std::ostream &o, const DeclTypeSpec &x) {

86
flang/lib/semantics/type.h
View File

@ -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<evaluate::SomeInteger>;
using MaybeIntExpr = std::optional<SomeIntExpr>;
using SubscriptIntExpr = evaluate::Expr<evaluate::SubscriptInteger>;
using MaybeSubscriptIntExpr = std::optional<SubscriptIntExpr>;
using KindExpr = SubscriptIntExpr;
// An array spec bound: an explicit integer expression or ASSUMED or DEFERRED
class Bound {
@ -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<ShapeSpec>;
class DerivedTypeSpec {
public:
using listType = std::list<std::pair<std::optional<SourceName>, ParamValue>>;
DerivedTypeSpec &operator=(const DerivedTypeSpec &) = delete;
explicit DerivedTypeSpec(const Symbol &symbol) : typeSymbol_{symbol} {}
DerivedTypeSpec() = delete;
DerivedTypeSpec(const DerivedTypeSpec &);
DerivedTypeSpec(DerivedTypeSpec &&);
const Symbol &typeSymbol() const { return typeSymbol_; }
const Scope *scope() const { return scope_; }
void set_scope(const Scope &);
listType &paramValues() { return paramValues_; }
const listType &paramValues() const { return paramValues_; }
void AddParamValue(ParamValue &&);
void AddParamValue(const SourceName &, ParamValue &&);
const std::map<SourceName, ParamValue> &parameters() const {
return parameters_;
}
bool HasActualParameters() const { return !parameters_.empty(); }
ParamValue &AddParamValue(SourceName, ParamValue &&);
ParamValue *FindParameter(SourceName);
const ParamValue *FindParameter(SourceName) const;
void FoldParameterExpressions(evaluate::FoldingContext &);
void Instantiate(Scope &, evaluate::FoldingContext &);
bool operator==(const DerivedTypeSpec &) const; // for std::find()
private:
const Symbol &typeSymbol_;
const Scope *scope_{nullptr};
listType paramValues_;
const Scope *scope_{nullptr}; // same as typeSymbol_.scope() unless PDT
std::map<SourceName, ParamValue> parameters_;
friend std::ostream &operator<<(std::ostream &, const DerivedTypeSpec &);
};
@ -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<std::monostate, NumericTypeSpec, LogicalTypeSpec,
CharacterTypeSpec, DerivedTypeSpec>
typeSpec_;
};
std::ostream &operator<<(std::ostream &, const DeclTypeSpec &);
@ -292,5 +303,4 @@ private:
const DeclTypeSpec *type_{nullptr};
};
}
#endif // FORTRAN_SEMANTICS_TYPE_H_

4
flang/test/semantics/CMakeLists.txt
View File

@ -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

95
flang/test/semantics/kinds01.f90 Normal file
View File

@ -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

57
flang/test/semantics/kinds02.f90 Normal file
View File

@ -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

55
flang/test/semantics/kinds03.f90 Normal file
View File

@ -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

6
flang/test/semantics/modfile12.f90
View File

@ -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

182
flang/test/semantics/modfile17.f90 Normal file
View File

@ -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

6
flang/test/semantics/resolve37.f90
View File

@ -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

6
flang/test/semantics/symbol09.f90
View File

@ -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