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)
TYPE_PARSER(construct<ImageSelectorSpec>(construct<ImageSelectorSpec::Stat>(
"STAT =" >> scalar(integer(indirect(variable))))) ||
construct<ImageSelectorSpec>(
- construct<ImageSelectorSpec::Team>("TEAM =" >> teamValue)) ||
+ construct<TeamValue>("TEAM =" >> teamValue)) ||
construct<ImageSelectorSpec>(construct<ImageSelectorSpec::Team_Number>(
"TEAM_NUMBER =" >> scalarIntExpr)))
using Cosubscript = ScalarIntExpr;
// R1115 team-value -> scalar-expr
-using TeamValue = Scalar<common::Indirection<Expr>>;
+WRAPPER_CLASS(TeamValue, Scalar<common::Indirection<Expr>>);
// R926 image-selector-spec ->
// STAT = stat-variable | TEAM = team-value |
// TEAM_NUMBER = scalar-int-expr
struct ImageSelectorSpec {
WRAPPER_CLASS(Stat, Scalar<Integer<common::Indirection<Variable>>>);
- WRAPPER_CLASS(Team, TeamValue);
WRAPPER_CLASS(Team_Number, ScalarIntExpr);
UNION_CLASS_BOILERPLATE(ImageSelectorSpec);
- std::variant<Stat, Team, Team_Number> u;
+ std::variant<Stat, TeamValue, Team_Number> u;
};
// R924 image-selector ->
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(");
attr.cc
canonicalize-do.cc
check-arithmeticif.cc
+ check-coarray.cc
check-computed-goto.cc
check-deallocate.cc
check-do-concurrent.cc
--- /dev/null
+// Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+
+#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<std::list<parser::CoarrayAssociation>>(x.t));
+ CheckTeamValue(std::get<parser::TeamValue>(x.t));
+}
+
+void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) {
+ CheckTeamValue(std::get<parser::TeamValue>(x.t));
+}
+
+void CoarrayChecker::Leave(const parser::ImageSelectorSpec &x) {
+ if (const auto *team{std::get_if<parser::TeamValue>(&x.u)}) {
+ CheckTeamValue(*team);
+ }
+}
+
+void CoarrayChecker::Leave(const parser::FormTeamStmt &x) {
+ AnalyzeExpr(context_, std::get<parser::ScalarIntExpr>(x.t));
+ const auto &teamVar{std::get<parser::TeamVariable>(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<parser::CoarrayAssociation> &list) {
+ std::set<parser::CharBlock> 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<parser::CodimensionDecl>(assoc.t)};
+ const auto &selector{std::get<parser::Selector>(assoc.t)};
+ const auto &declName{std::get<parser::Name>(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<parser::Variable>(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());
+}
+
+}
--- /dev/null
+// Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+
+#ifndef FORTRAN_SEMANTICS_CHECK_COARRAY_H_
+#define FORTRAN_SEMANTICS_CHECK_COARRAY_H_
+
+#include "semantics.h"
+#include <list>
+
+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<parser::CoarrayAssociation> &);
+ void CheckTeamValue(const parser::TeamValue &);
+ void Say2(const parser::CharBlock &, parser::MessageFixedText &&,
+ const parser::CharBlock &, parser::MessageFixedText &&);
+};
+
+}
+#endif // FORTRAN_SEMANTICS_CHECK_COARRAY_H_
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<Attr> objectDeclAttr_;
void AddSaveName(std::set<SourceName> &, 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
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); }
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); }
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<typename T> bool CheckDef(const T &t) {
Symbol *MakeAssocEntity();
void SetTypeFromAssociation(Symbol &);
void SetAttrsFromAssociation(Symbol &);
+ Selector ResolveSelector(const parser::Selector &);
};
// Walk the parse tree and resolve names to symbols.
std::optional<Symbol::Flag> 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 &);
const auto &name{std::get<parser::Name>(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<parser::ObjectName>(x.t)};
- // TODO: CoarraySpec
Attrs attrs{attrs_ ? HandleSaveName(name.source, *attrs_) : Attrs{}};
Symbol &symbol{DeclareUnknownEntity(name, attrs)};
if (auto &init{std::get<std::optional<parser::Initialization>>(x.t)}) {
}
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) {
}
}
+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<parser::CodimensionDecl>(x.t)};
+ const auto &name{std::get<parser::Name>(decl.t)};
+ if (auto *symbol{FindInScope(currScope(), name)}) {
+ const auto &selector{std::get<parser::Selector>(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<parser::Name> &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<ObjectEntityDetails>()) {
+ Say(association_.selector.source, // C1157
+ "Selector is not a named variable: 'associate-name =>' is required"_err_en_US);
+ association_ = {};
+ }
}
}
"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{});
}
// 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<AssocEntityDetails>()};
// 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};
}
}
+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) {
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<parser::DataRef>(x.t));
+ },
+ },
+ x.u);
}
-const parser::Name *ResolveNamesVisitor::ResolveDataRef(
+const parser::Name *DeclarationVisitor::ResolveDataRef(
const parser::DataRef &x) {
return std::visit(
common::visitors{
[=](const Indirection<parser::StructureComponent> &y) {
return ResolveStructureComponent(y.value());
},
- [=](const Indirection<parser::ArrayElement> &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<parser::Designator> &y) {
+ return ResolveDesignator(y.value());
},
- [=](const Indirection<parser::CoindexedNamedObject> &y) {
- return ResolveCoindexedNamedObject(y.value());
+ [&](const common::Indirection<parser::FunctionReference> &y) {
+ const auto &proc{
+ std::get<parser::ProcedureDesignator>(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);
// 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
// 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;
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<parser::DataRef>(x.t));
- },
- },
- x.u);
+ ResolveDesignator(x);
}
template<typename T>
#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"
};
using StatementSemanticsPass1 = ExprChecker;
-using StatementSemanticsPass2 = SemanticsVisitor<ArithmeticIfStmtChecker,
- AssignmentChecker, ComputedGotoStmtChecker, DeallocateChecker,
- DoConcurrentChecker, IfStmtChecker, NullifyChecker, ReturnStmtChecker>;
+using StatementSemanticsPass2 =
+ SemanticsVisitor<ArithmeticIfStmtChecker, AssignmentChecker, CoarrayChecker,
+ ComputedGotoStmtChecker, DeallocateChecker, DoConcurrentChecker,
+ IfStmtChecker, NullifyChecker, ReturnStmtChecker>;
SemanticsContext::SemanticsContext(
const common::IntrinsicTypeDefaultKinds &defaultKinds,
resolve47.f90
resolve48.f90
resolve49.f90
+ resolve50.f90
+ resolve51.f90
structconst01.f90
structconst02.f90
structconst03.f90
deallocate01.f90
deallocate04.f90
deallocate05.f90
+ coarrays01.f90
+ coarrays02.f90
altreturn01.f90
# Issue 407
# altreturn02.f90
--- /dev/null
+! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! 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
--- /dev/null
+! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! 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
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
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)
!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
--- /dev/null
+! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! 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
--- /dev/null
+! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! 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
projects / platform / upstream / llvm.git / commitdiff