From b2f84a5eda64f4d5185c14ed82851fadbc054e23 Mon Sep 17 00:00:00 2001 From: Tim Keith Date: Mon, 15 Apr 2019 10:26:20 -0700 Subject: [PATCH] [flang] More coarray name resolution and semantic checks Add CoarrayChecker to check for valid team-value in CHANGE TEAM, SYNC TEAM, and image selector. Check that coarray names and selector names are distinct in CHANGE TEAM. Resolve the variable in a coarray-association. Create a scope for the construct entities of a CHANGE TEAM construct. Add ResolveSelector to resolve a parser::Selector into an Expr and optional variable name (and a source location for messages). Make use of ResolveSelector to handle coarray-association, as well as it's previous use in associate-stmt. Improve the check for C1157 in select-type-stmt and add a test. Add a test for "Associate name must have a type". Move ResolveName, ResolveDataRef, etc. from ResolveNamesVisitor to DeclarationVisitor so that they are available in ConstructVisitor as well. Add ResolveVariable and ResolveDesignator. In the parse tree, change TeamValue from a type alias to a wrapper class. We already had a wrapper class anyway, ImageSelectorSpec::Team, so the new TeamValue can be used instead. This allows the member of ImageSelectorSpec to be treated like other occurrences of TeamValue. Original-commit: flang-compiler/f18@f856744b542a453dea1a9e01ad4e629bf072cff3 Reviewed-on: https://github.com/flang-compiler/f18/pull/414 Tree-same-pre-rewrite: false --- flang/lib/parser/dump-parse-tree.h | 2 +- flang/lib/parser/grammar.h | 2 +- flang/lib/parser/parse-tree.h | 5 +- flang/lib/parser/unparse.cc | 2 +- flang/lib/semantics/CMakeLists.txt | 1 + flang/lib/semantics/check-coarray.cc | 118 +++++++++++++++++++ flang/lib/semantics/check-coarray.h | 52 ++++++++ flang/lib/semantics/resolve-names.cc | 203 ++++++++++++++++++++------------ flang/lib/semantics/semantics.cc | 8 +- flang/test/semantics/CMakeLists.txt | 4 + flang/test/semantics/coarrays01.f90 | 68 +++++++++++ flang/test/semantics/coarrays02.f90 | 35 ++++++ flang/test/semantics/doconcurrent01.f90 | 9 +- flang/test/semantics/resolve39.f90 | 6 + flang/test/semantics/resolve50.f90 | 48 ++++++++ flang/test/semantics/resolve51.f90 | 31 +++++ 16 files changed, 510 insertions(+), 84 deletions(-) create mode 100644 flang/lib/semantics/check-coarray.cc create mode 100644 flang/lib/semantics/check-coarray.h create mode 100644 flang/test/semantics/coarrays01.f90 create mode 100644 flang/test/semantics/coarrays02.f90 create mode 100644 flang/test/semantics/resolve50.f90 create mode 100644 flang/test/semantics/resolve51.f90 diff --git a/flang/lib/parser/dump-parse-tree.h b/flang/lib/parser/dump-parse-tree.h index 287e9ee..2b47929 100644 --- a/flang/lib/parser/dump-parse-tree.h +++ b/flang/lib/parser/dump-parse-tree.h @@ -300,10 +300,10 @@ public: NODE(parser::IfConstruct, ElseIfBlock) NODE(parser, IfStmt) NODE(parser, IfThenStmt) + NODE(parser, TeamValue) NODE(parser, ImageSelector) NODE(parser, ImageSelectorSpec) NODE(parser::ImageSelectorSpec, Stat) - NODE(parser::ImageSelectorSpec, Team) NODE(parser::ImageSelectorSpec, Team_Number) NODE(parser, ImplicitPart) NODE(parser, ImplicitPartStmt) diff --git a/flang/lib/parser/grammar.h b/flang/lib/parser/grammar.h index c558585..e6efaaa 100644 --- a/flang/lib/parser/grammar.h +++ b/flang/lib/parser/grammar.h @@ -1518,7 +1518,7 @@ constexpr auto teamValue{scalar(indirect(expr))}; TYPE_PARSER(construct(construct( "STAT =" >> scalar(integer(indirect(variable))))) || construct( - construct("TEAM =" >> teamValue)) || + construct("TEAM =" >> teamValue)) || construct(construct( "TEAM_NUMBER =" >> scalarIntExpr))) diff --git a/flang/lib/parser/parse-tree.h b/flang/lib/parser/parse-tree.h index f9a9185..9152f26 100644 --- a/flang/lib/parser/parse-tree.h +++ b/flang/lib/parser/parse-tree.h @@ -1578,17 +1578,16 @@ struct SectionSubscript { using Cosubscript = ScalarIntExpr; // R1115 team-value -> scalar-expr -using TeamValue = Scalar>; +WRAPPER_CLASS(TeamValue, Scalar>); // R926 image-selector-spec -> // STAT = stat-variable | TEAM = team-value | // TEAM_NUMBER = scalar-int-expr struct ImageSelectorSpec { WRAPPER_CLASS(Stat, Scalar>>); - WRAPPER_CLASS(Team, TeamValue); WRAPPER_CLASS(Team_Number, ScalarIntExpr); UNION_CLASS_BOILERPLATE(ImageSelectorSpec); - std::variant u; + std::variant u; }; // R924 image-selector -> diff --git a/flang/lib/parser/unparse.cc b/flang/lib/parser/unparse.cc index 87d1740..3cc2b8d 100644 --- a/flang/lib/parser/unparse.cc +++ b/flang/lib/parser/unparse.cc @@ -755,7 +755,7 @@ public: void Before(const ImageSelectorSpec::Stat &) { // R926 Word("STAT="); } - void Before(const ImageSelectorSpec::Team &) { Word("TEAM="); } + void Before(const TeamValue &) { Word("TEAM="); } void Before(const ImageSelectorSpec::Team_Number &) { Word("TEAM_NUMBER="); } void Unparse(const AllocateStmt &x) { // R927 Word("ALLOCATE("); diff --git a/flang/lib/semantics/CMakeLists.txt b/flang/lib/semantics/CMakeLists.txt index ca8ce97..ff6c0dc 100644 --- a/flang/lib/semantics/CMakeLists.txt +++ b/flang/lib/semantics/CMakeLists.txt @@ -17,6 +17,7 @@ add_library(FortranSemantics attr.cc canonicalize-do.cc check-arithmeticif.cc + check-coarray.cc check-computed-goto.cc check-deallocate.cc check-do-concurrent.cc diff --git a/flang/lib/semantics/check-coarray.cc b/flang/lib/semantics/check-coarray.cc new file mode 100644 index 0000000..942d7b4 --- /dev/null +++ b/flang/lib/semantics/check-coarray.cc @@ -0,0 +1,118 @@ +// 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. + +#include "check-coarray.h" +#include "expression.h" +#include "tools.h" +#include "../common/indirection.h" +#include "../evaluate/expression.h" +#include "../parser/message.h" +#include "../parser/parse-tree.h" + +namespace Fortran::semantics { + +// Is this a derived type from module with this name? +static bool IsDerivedTypeFromModule( + const DerivedTypeSpec *derived, const char *module, const char *name) { + if (!derived) { + return false; + } else { + const auto &symbol{derived->typeSymbol()}; + return symbol.name() == name && symbol.owner().IsModule() && + symbol.owner().name() == module; + } +} +static bool IsTeamType(const DerivedTypeSpec *derived) { + return IsDerivedTypeFromModule(derived, "iso_fortran_env", "team_type"); +} + +void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) { + CheckNamesAreUnique(std::get>(x.t)); + CheckTeamValue(std::get(x.t)); +} + +void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) { + CheckTeamValue(std::get(x.t)); +} + +void CoarrayChecker::Leave(const parser::ImageSelectorSpec &x) { + if (const auto *team{std::get_if(&x.u)}) { + CheckTeamValue(*team); + } +} + +void CoarrayChecker::Leave(const parser::FormTeamStmt &x) { + AnalyzeExpr(context_, std::get(x.t)); + const auto &teamVar{std::get(x.t)}; + AnalyzeExpr(context_, teamVar); + const parser::Name *name{GetSimpleName(teamVar.thing)}; + CHECK(name); + if (const auto *type{name->symbol->GetType()}) { + if (!IsTeamType(type->AsDerived())) { + context_.Say(name->source, // C1179 + "Team variable '%s' must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US, + name->ToString().c_str()); + } + } +} + +// Check that coarray names and selector names are all distinct. +void CoarrayChecker::CheckNamesAreUnique( + const std::list &list) { + std::set names; + auto getPreviousUse{ + [&](const parser::Name &name) -> const parser::CharBlock * { + auto pair{names.insert(name.source)}; + return !pair.second ? &*pair.first : nullptr; + }}; + for (const auto &assoc : list) { + const auto &decl{std::get(assoc.t)}; + const auto &selector{std::get(assoc.t)}; + const auto &declName{std::get(decl.t)}; + if (auto *prev{getPreviousUse(declName)}) { + Say2(declName.source, // C1113 + "Coarray '%s' was already used as a selector or coarray in this statement"_err_en_US, + *prev, "Previous use of '%s'"_en_US); + } + // ResolveNames verified the selector is a simple name + const auto &variable{std::get(selector.u)}; + const parser::Name *name{GetSimpleName(variable)}; + CHECK(name); + if (auto *prev{getPreviousUse(*name)}) { + Say2(name->source, // C1113, C1115 + "Selector '%s' was already used as a selector or coarray in this statement"_err_en_US, + *prev, "Previous use of '%s'"_en_US); + } + } +} + +void CoarrayChecker::CheckTeamValue(const parser::TeamValue &x) { + const auto &parsedExpr{x.v.thing.value()}; + const auto &expr{parsedExpr.typedExpr->v}; + if (auto type{expr.GetType()}) { + if (!IsTeamType(type->derived)) { + context_.Say(parsedExpr.source, // C1114 + "Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US); + } + } +} + +void CoarrayChecker::Say2(const parser::CharBlock &name1, + parser::MessageFixedText &&msg1, const parser::CharBlock &name2, + parser::MessageFixedText &&msg2) { + context_.Say(name1, std::move(msg1), name1.ToString().c_str()) + .Attach(name2, std::move(msg2), name2.ToString().c_str()); +} + +} diff --git a/flang/lib/semantics/check-coarray.h b/flang/lib/semantics/check-coarray.h new file mode 100644 index 0000000..f1bceae --- /dev/null +++ b/flang/lib/semantics/check-coarray.h @@ -0,0 +1,52 @@ +// 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. + +#ifndef FORTRAN_SEMANTICS_CHECK_COARRAY_H_ +#define FORTRAN_SEMANTICS_CHECK_COARRAY_H_ + +#include "semantics.h" +#include + +namespace Fortran::parser { +class CharBlock; +class MessageFixedText; +struct ChangeTeamStmt; +struct CoarrayAssociation; +struct FormTeamStmt; +struct ImageSelectorSpec; +struct SyncTeamStmt; +struct TeamValue; +} + +namespace Fortran::semantics { + +class CoarrayChecker : public virtual BaseChecker { +public: + inline CoarrayChecker(SemanticsContext &context) : context_{context} {} + void Leave(const parser::ChangeTeamStmt &); + void Leave(const parser::SyncTeamStmt &); + void Leave(const parser::ImageSelectorSpec &); + void Leave(const parser::FormTeamStmt &); + +private: + SemanticsContext &context_; + + void CheckNamesAreUnique(const std::list &); + void CheckTeamValue(const parser::TeamValue &); + void Say2(const parser::CharBlock &, parser::MessageFixedText &&, + const parser::CharBlock &, parser::MessageFixedText &&); +}; + +} +#endif // FORTRAN_SEMANTICS_CHECK_COARRAY_H_ diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc index 3e6e141..ee418bc 100644 --- a/flang/lib/semantics/resolve-names.cc +++ b/flang/lib/semantics/resolve-names.cc @@ -761,6 +761,15 @@ protected: bool CheckNotInBlock(const char *); bool NameIsKnownOrIntrinsic(const parser::Name &); + // Each of these returns a pointer to a resolved Name (i.e. with symbol) + // or nullptr in case of error. + const parser::Name *ResolveStructureComponent( + const parser::StructureComponent &); + const parser::Name *ResolveDesignator(const parser::Designator &); + const parser::Name *ResolveDataRef(const parser::DataRef &); + const parser::Name *ResolveVariable(const parser::Variable &); + const parser::Name *ResolveName(const parser::Name &); + private: // The attribute corresponding to the statement containing an ObjectDecl std::optional objectDeclAttr_; @@ -812,6 +821,7 @@ private: void AddSaveName(std::set &, const SourceName &); void SetSaveAttr(Symbol &); bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &); + const parser::Name *FindComponent(const parser::Name *, const parser::Name &); // Declare an object or procedure entity. // T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails @@ -889,11 +899,13 @@ public: bool Pre(const parser::SelectTypeConstruct::TypeCase &); void Post(const parser::SelectTypeConstruct::TypeCase &); void Post(const parser::TypeGuardStmt::Guard &); + bool Pre(const parser::ChangeTeamStmt &); + void Post(const parser::EndChangeTeamStmt &); + void Post(const parser::CoarrayAssociation &); // Definitions of construct names bool Pre(const parser::WhereConstructStmt &x) { return CheckDef(x.t); } bool Pre(const parser::ForallConstructStmt &x) { return CheckDef(x.t); } - bool Pre(const parser::ChangeTeamStmt &x) { return CheckDef(x.t); } bool Pre(const parser::CriticalStmt &x) { return CheckDef(x.t); } bool Pre(const parser::LabelDoStmt &x) { common::die("should not happen"); } bool Pre(const parser::NonLabelDoStmt &x) { return CheckDef(x.t); } @@ -911,7 +923,6 @@ public: void Post(const parser::ElsewhereStmt &x) { CheckRef(x.v); } void Post(const parser::EndWhereStmt &x) { CheckRef(x.v); } void Post(const parser::EndForallStmt &x) { CheckRef(x.v); } - void Post(const parser::EndChangeTeamStmt &x) { CheckRef(x.t); } void Post(const parser::EndCriticalStmt &x) { CheckRef(x.v); } void Post(const parser::EndDoStmt &x) { CheckRef(x.v); } void Post(const parser::ElseIfStmt &x) { CheckRef(x.t); } @@ -925,12 +936,22 @@ public: void Post(const parser::ExitStmt &x) { CheckRef(x.v); } private: - // This represents: associate-name => expr | variable - // expr is set unless there were errors + // R1105 selector -> expr | variable + // expr is set in either case unless there were errors + struct Selector { + Selector() : variable{nullptr} {} + Selector(const parser::CharBlock &source, MaybeExpr &&expr, + const parser::Name *variable = nullptr) + : source{source}, expr{std::move(expr)}, variable{variable} {} + operator bool() const { return expr.has_value(); } + parser::CharBlock source; + MaybeExpr expr; + const parser::Name *variable; + }; + // association -> [associate-name =>] selector struct { const parser::Name *name{nullptr}; - const parser::Name *variable{nullptr}; - MaybeExpr expr; + Selector selector; } association_; template bool CheckDef(const T &t) { @@ -947,6 +968,7 @@ private: Symbol *MakeAssocEntity(); void SetTypeFromAssociation(Symbol &); void SetAttrsFromAssociation(Symbol &); + Selector ResolveSelector(const parser::Selector &); }; // Walk the parse tree and resolve names to symbols. @@ -1004,17 +1026,6 @@ private: std::optional expectedProcFlag_; const SourceName *prevImportStmt_{nullptr}; - // Each of these returns a pointer to a resolved Name (i.e. with symbol) - // or nullptr in case of error. - const parser::Name *ResolveStructureComponent( - const parser::StructureComponent &); - const parser::Name *ResolveArrayElement(const parser::ArrayElement &); - const parser::Name *ResolveCoindexedNamedObject( - const parser::CoindexedNamedObject &); - const parser::Name *ResolveDataRef(const parser::DataRef &); - const parser::Name *ResolveName(const parser::Name &); - const parser::Name *FindComponent(const parser::Name *, const parser::Name &); - void CheckImports(); void CheckImport(const SourceName &, const SourceName &); void HandleCall(Symbol::Flag, const parser::Call &); @@ -2541,12 +2552,10 @@ void DeclarationVisitor::Post(const parser::CodimensionDecl &x) { const auto &name{std::get(x.t)}; DeclareObjectEntity(name, Attrs{}); } -// TODO: ChangeTeamStmt also uses CodimensionDecl void DeclarationVisitor::Post(const parser::EntityDecl &x) { // TODO: may be under StructureStmt const auto &name{std::get(x.t)}; - // TODO: CoarraySpec Attrs attrs{attrs_ ? HandleSaveName(name.source, *attrs_) : Attrs{}}; Symbol &symbol{DeclareUnknownEntity(name, attrs)}; if (auto &init{std::get>(x.t)}) { @@ -4015,25 +4024,7 @@ bool ConstructVisitor::Pre(const parser::EndBlockStmt &x) { } void ConstructVisitor::Post(const parser::Selector &x) { - association_ = {}; - const parser::Name *variable{nullptr}; - MaybeExpr expr{std::visit( - common::visitors{ - [&](const parser::Expr &y) { return EvaluateExpr(y); }, - [&](const parser::Variable &y) { - variable = GetSimpleName(y); - if (variable && !FindSymbol(*variable)) { - variable = nullptr; - return MaybeExpr{}; - } - return EvaluateExpr(y); - }, - }, - x.u)}; - if (expr) { - association_.expr = std::move(expr); - association_.variable = variable; - } + association_.selector = ResolveSelector(x); } bool ConstructVisitor::Pre(const parser::AssociateStmt &x) { @@ -4055,14 +4046,47 @@ void ConstructVisitor::Post(const parser::Association &x) { } } +bool ConstructVisitor::Pre(const parser::ChangeTeamStmt &x) { + CheckDef(x.t); + PushScope(Scope::Kind::Block, nullptr); + return true; +} + +void ConstructVisitor::Post(const parser::CoarrayAssociation &x) { + const auto &decl{std::get(x.t)}; + const auto &name{std::get(decl.t)}; + if (auto *symbol{FindInScope(currScope(), name)}) { + const auto &selector{std::get(x.t)}; + if (auto sel{ResolveSelector(selector)}) { + if (!sel.variable || sel.variable->symbol->Corank() == 0) { + Say(sel.source, // C1116 + "Selector in coarray association must name a coarray"_err_en_US); + } else if (auto dynType{sel.expr->GetType()}) { + if (!symbol->GetType()) { + symbol->SetType(ToDeclTypeSpec(std::move(*dynType))); + } + } + } + } +} + +void ConstructVisitor::Post(const parser::EndChangeTeamStmt &x) { + PopScope(); + CheckRef(x.t); +} + void ConstructVisitor::Post(const parser::SelectTypeStmt &x) { if (const std::optional &name{std::get<1>(x.t)}) { // This isn't a name in the current scope, it is in each TypeGuardStmt MakePlaceholder(*name, MiscDetails::Kind::SelectTypeAssociateName); association_.name = &*name; - } else if (!association_.variable) { - Say("Selector is not a named variable: 'associate-name =>' is required"_err_en_US); - association_ = {}; + } else { + const auto *varName{association_.selector.variable}; + if (!varName || !varName->symbol->has()) { + Say(association_.selector.source, // C1157 + "Selector is not a named variable: 'associate-name =>' is required"_err_en_US); + association_ = {}; + } } } @@ -4110,9 +4134,9 @@ Symbol *ConstructVisitor::MakeAssocEntity() { "The associate name '%s' is already used in this associate statement"_err_en_US); return nullptr; } - if (auto &expr{association_.expr}) { + if (auto &expr{association_.selector.expr}) { symbol.set_details(AssocEntityDetails{std::move(*expr)}); - association_.expr.reset(); + association_.selector.expr.reset(); } else { symbol.set_details(AssocEntityDetails{}); } @@ -4121,11 +4145,11 @@ Symbol *ConstructVisitor::MakeAssocEntity() { // Set the type of symbol based on the current association variable or expr. void ConstructVisitor::SetTypeFromAssociation(Symbol &symbol) { - if (association_.variable) { - if (const Symbol * varSymbol{association_.variable->symbol}) { - if (const DeclTypeSpec * type{varSymbol->GetType()}) { - symbol.SetType(*type); - } + if (association_.selector.variable) { + const Symbol *varSymbol{association_.selector.variable->symbol}; + CHECK(varSymbol); + if (const DeclTypeSpec * type{varSymbol->GetType()}) { + symbol.SetType(*type); } } else { auto &details{symbol.get()}; @@ -4151,8 +4175,8 @@ void ConstructVisitor::SetTypeFromAssociation(Symbol &symbol) { // If current selector is a variable, set some of its attributes on symbol. void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) { - if (association_.variable) { - if (const auto *varSymbol{association_.variable->symbol}) { + if (association_.selector.variable) { + if (const auto *varSymbol{association_.selector.variable->symbol}) { symbol.attrs() |= varSymbol->attrs() & Attrs{Attr::TARGET, Attr::ASYNCHRONOUS, Attr::VOLATILE, Attr::CONTIGUOUS}; @@ -4163,6 +4187,24 @@ void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) { } } +ConstructVisitor::Selector ConstructVisitor::ResolveSelector( + const parser::Selector &x) { + return std::visit( + common::visitors{ + [&](const parser::Expr &y) { + return Selector{y.source, EvaluateExpr(y)}; + }, + [&](const parser::Variable &y) { + if (const auto *variable{ResolveVariable(y)}) { + return Selector{variable->source, EvaluateExpr(y), variable}; + } else { + return Selector{}; + } + }, + }, + x.u); +} + const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec( evaluate::DynamicType &&type) { switch (type.category) { @@ -4237,22 +4279,24 @@ bool ResolveNamesVisitor::Pre(const parser::ImportStmt &x) { return false; } -const parser::Name *ResolveNamesVisitor::ResolveStructureComponent( +const parser::Name *DeclarationVisitor::ResolveStructureComponent( const parser::StructureComponent &x) { return FindComponent(ResolveDataRef(x.base), x.component); } -const parser::Name *ResolveNamesVisitor::ResolveArrayElement( - const parser::ArrayElement &x) { - return ResolveDataRef(x.base); -} - -const parser::Name *ResolveNamesVisitor::ResolveCoindexedNamedObject( - const parser::CoindexedNamedObject &x) { - return nullptr; // TODO +const parser::Name *DeclarationVisitor::ResolveDesignator( + const parser::Designator &x) { + return std::visit( + common::visitors{ + [&](const parser::DataRef &x) { return ResolveDataRef(x); }, + [&](const parser::Substring &x) { + return ResolveDataRef(std::get(x.t)); + }, + }, + x.u); } -const parser::Name *ResolveNamesVisitor::ResolveDataRef( +const parser::Name *DeclarationVisitor::ResolveDataRef( const parser::DataRef &x) { return std::visit( common::visitors{ @@ -4260,11 +4304,29 @@ const parser::Name *ResolveNamesVisitor::ResolveDataRef( [=](const Indirection &y) { return ResolveStructureComponent(y.value()); }, - [=](const Indirection &y) { - return ResolveArrayElement(y.value()); + [=](const auto &y) { return ResolveDataRef(y.value().base); }, + }, + x.u); +} + +const parser::Name *DeclarationVisitor::ResolveVariable( + const parser::Variable &x) { + return std::visit( + common::visitors{ + [&](const common::Indirection &y) { + return ResolveDesignator(y.value()); }, - [=](const Indirection &y) { - return ResolveCoindexedNamedObject(y.value()); + [&](const common::Indirection &y) { + const auto &proc{ + std::get(y.value().v.t)}; + return std::visit( + common::visitors{ + [&](const parser::Name &z) { return &z; }, + [&](const parser::ProcComponentRef &z) { + return ResolveStructureComponent(z.v.thing); + }, + }, + proc.u); }, }, x.u); @@ -4272,7 +4334,7 @@ const parser::Name *ResolveNamesVisitor::ResolveDataRef( // If implicit types are allowed, ensure name is in the symbol table. // Otherwise, report an error if it hasn't been declared. -const parser::Name *ResolveNamesVisitor::ResolveName(const parser::Name &name) { +const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) { if (FindSymbol(name)) { if (CheckUseError(name)) { return nullptr; // reported an error @@ -4298,7 +4360,7 @@ 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 *DeclarationVisitor::FindComponent( const parser::Name *base, const parser::Name &component) { if (!base || !base->symbol) { return nullptr; @@ -4615,14 +4677,7 @@ bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) { return false; } void ResolveNamesVisitor::Post(const parser::Designator &x) { - std::visit( - common::visitors{ - [&](const parser::DataRef &x) { ResolveDataRef(x); }, - [&](const parser::Substring &x) { - ResolveDataRef(std::get(x.t)); - }, - }, - x.u); + ResolveDesignator(x); } template diff --git a/flang/lib/semantics/semantics.cc b/flang/lib/semantics/semantics.cc index 25461f6..85e0ed1 100644 --- a/flang/lib/semantics/semantics.cc +++ b/flang/lib/semantics/semantics.cc @@ -16,6 +16,7 @@ #include "assignment.h" #include "canonicalize-do.h" #include "check-arithmeticif.h" +#include "check-coarray.h" #include "check-computed-goto.h" #include "check-deallocate.h" #include "check-do-concurrent.h" @@ -78,9 +79,10 @@ private: }; using StatementSemanticsPass1 = ExprChecker; -using StatementSemanticsPass2 = SemanticsVisitor; +using StatementSemanticsPass2 = + SemanticsVisitor; SemanticsContext::SemanticsContext( const common::IntrinsicTypeDefaultKinds &defaultKinds, diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index 1aafbcf..bcb5c51 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/flang/test/semantics/CMakeLists.txt @@ -76,6 +76,8 @@ set(ERROR_TESTS resolve47.f90 resolve48.f90 resolve49.f90 + resolve50.f90 + resolve51.f90 structconst01.f90 structconst02.f90 structconst03.f90 @@ -94,6 +96,8 @@ set(ERROR_TESTS deallocate01.f90 deallocate04.f90 deallocate05.f90 + coarrays01.f90 + coarrays02.f90 altreturn01.f90 # Issue 407 # altreturn02.f90 diff --git a/flang/test/semantics/coarrays01.f90 b/flang/test/semantics/coarrays01.f90 new file mode 100644 index 0000000..f90b9f8 --- /dev/null +++ b/flang/test/semantics/coarrays01.f90 @@ -0,0 +1,68 @@ +! 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. + +! Test selector and team-value in CHANGE TEAM statement + +! Temporary, until we have real iso_fortran_env +module iso_fortran_env + type :: team_type + end type +end + +! OK +subroutine s1 + use iso_fortran_env, only: team_type + type(team_type) :: t + real :: y[10,*] + change team(t, x[10,*] => y) + end team + form team(1, t) +end + +subroutine s2 + use iso_fortran_env + type(team_type) :: t + real :: y[10,*], y2[*], x[*] + ! C1113 + !ERROR: Selector 'y' was already used as a selector or coarray in this statement + change team(t, x[10,*] => y, x2[*] => y) + end team + !ERROR: Selector 'x' was already used as a selector or coarray in this statement + change team(t, x[10,*] => y, x2[*] => x) + end team + !ERROR: Coarray 'y' was already used as a selector or coarray in this statement + change team(t, x[10,*] => y, y[*] => y2) + end team +end + +subroutine s3 + type :: team_type + end type + type :: foo + end type + type(team_type) :: t1 + type(foo) :: t2 + real :: y[10,*] + ! C1114 + !ERROR: Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV + change team(t1, x[10,*] => y) + end team + !ERROR: Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV + change team(t2, x[10,*] => y) + end team + !ERROR: Team variable 't1' must be of type TEAM_TYPE from module ISO_FORTRAN_ENV + form team(1, t1) + !ERROR: Team variable 't2' must be of type TEAM_TYPE from module ISO_FORTRAN_ENV + form team(2, t2) +end diff --git a/flang/test/semantics/coarrays02.f90 b/flang/test/semantics/coarrays02.f90 new file mode 100644 index 0000000..a6153ac --- /dev/null +++ b/flang/test/semantics/coarrays02.f90 @@ -0,0 +1,35 @@ +! 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. + +! Test team-variable in FORM TEAM statement + +! Temporary, until we have real iso_fortran_env +module iso_fortran_env + type :: team_type + end type +end + +subroutine s1 + use iso_fortran_env, only: team_type + complex :: z + integer :: i, j(10) + type(team_type) :: t, t2(2) + form team(i, t) + !ERROR: Must be a scalar value, but is a rank-1 array + form team(1, t2) + !ERROR: Must have INTEGER type, but is COMPLEX(4) + form team(z, t) + !ERROR: Must be a scalar value, but is a rank-1 array + form team(j, t) +end diff --git a/flang/test/semantics/doconcurrent01.f90 b/flang/test/semantics/doconcurrent01.f90 index 893c8a6..5ae5f8f 100644 --- a/flang/test/semantics/doconcurrent01.f90 +++ b/flang/test/semantics/doconcurrent01.f90 @@ -29,6 +29,11 @@ module ieee_exceptions end interface end module ieee_exceptions +module iso_fortran_env + type :: team_type + end type +end + subroutine do_concurrent_test1(i,n) implicit none integer :: i, n @@ -41,8 +46,10 @@ end subroutine do_concurrent_test1 subroutine do_concurrent_test2(i,j,n,flag) use ieee_exceptions + use iso_fortran_env, only: team_type implicit none - integer :: i, j, n, flag, flag2 + integer :: i, n, flag, flag2 + type(team_type) :: j do concurrent (i = 1:n) change team (j) call ieee_get_flag(flag, flag2) diff --git a/flang/test/semantics/resolve39.f90 b/flang/test/semantics/resolve39.f90 index 72c2b31..cd49847 100644 --- a/flang/test/semantics/resolve39.f90 +++ b/flang/test/semantics/resolve39.f90 @@ -22,3 +22,9 @@ subroutine s1 !ERROR: No explicit type declared for 'b' x = b end + +subroutine s2 + !ERROR: Associate name 'a' must have a type + associate (a => z'1') + end associate +end diff --git a/flang/test/semantics/resolve50.f90 b/flang/test/semantics/resolve50.f90 new file mode 100644 index 0000000..2331bec --- /dev/null +++ b/flang/test/semantics/resolve50.f90 @@ -0,0 +1,48 @@ +! 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. + +! Test coarray association in CHANGE TEAM statement + +module iso_fortran_env + type :: team_type + end type +end + +subroutine s1 + use iso_fortran_env + type(team_type) :: t + complex :: x[*] + real :: y[*] + real :: z + ! OK + change team(t, x[*] => y) + end team + ! C1116 + !ERROR: Selector in coarray association must name a coarray + change team(t, x[*] => 1) + end team + !ERROR: Selector in coarray association must name a coarray + change team(t, x[*] => z) + end team +end + +subroutine s2 + use iso_fortran_env + type(team_type) :: t + real :: y[10,*], y2[*], x[*] + ! C1113 + !ERROR: The codimensions of 'x' have already been declared + change team(t, x[10,*] => y, x[*] => y2) + end team +end diff --git a/flang/test/semantics/resolve51.f90 b/flang/test/semantics/resolve51.f90 new file mode 100644 index 0000000..8ed7401 --- /dev/null +++ b/flang/test/semantics/resolve51.f90 @@ -0,0 +1,31 @@ +! 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. + +! Test SELECT TYPE errors: C1157 + +subroutine s1() + type :: t + end type + procedure(f) :: ff + !ERROR: Selector is not a named variable: 'associate-name =>' is required + select type(ff()) + class is(t) + class default + end select +contains + function f() + class(t), pointer :: f + f => null() + end function +end subroutine -- 2.7.4