forked from OSchip/llvm-project
[flang] Resolve and check names in equivalence sets
Collect sets of `parser::EquivalenceObject` to process at the end of the specification part. This is so that names mentioned in the EQUIVALENCE statement don't trigger implicit declarations. The `EquivalenceSets` class performs most of the numerous checks on objects that can be in equivalence sets at all and objects that can be in them together. It also merges sets when the same object appears in more than one. Once equivalence sets are checked they are added to the `Scope`. Further checks will be necessary after the size and alignment of variables are computed. Add `FindUltimateComponent` to simplify checks on ultimate components of derived types. Use it to implement `HasCoarrayUltimateComponent` and checks on equivalence objects. Make `ExpressionAnalyzer::Analyze(Designator)` public so that `parser::EquivalenceObject` can be analyzed. Add `GetDefaultKind`, `doublePrecisionKind`, and `quadPrecisionKind` to `SemanticsContext` so that `defaultKinds_` does not need to be accessed directly. Original-commit: flang-compiler/f18@1cc898e5b8 Reviewed-on: https://github.com/flang-compiler/f18/pull/494 Tree-same-pre-rewrite: false
This commit is contained in:
Tim Keith
parent
b387e7139d
commit
9ef62dbb6a
|
|
@ -486,7 +486,7 @@ int AssignmentContext::GetIntegerKind(
|
|||
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);
|
||||
return context_.GetDefaultKind(TypeCategory::Integer);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -118,8 +118,7 @@ void IoChecker::Enter(const parser::IdVariable &spec) {
|
|||
return;
|
||||
}
|
||||
int kind{expr->GetType()->kind()};
|
||||
int defaultKind{
|
||||
context_.defaultKinds().GetDefaultKind(TypeCategory::Integer)};
|
||||
int defaultKind{context_.GetDefaultKind(TypeCategory::Integer)};
|
||||
if (kind < defaultKind) {
|
||||
context_.Say(
|
||||
"ID kind (%d) is smaller than default INTEGER kind (%d)"_err_en_US,
|
||||
|
|
|
|||
|
|
@ -459,16 +459,15 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
|
|||
// letter used in an exponent part (e.g., the 'E' in "6.02214E+23")
|
||||
// should agree. In the absence of an explicit kind parameter, any exponent
|
||||
// letter determines the kind. Otherwise, defaults apply.
|
||||
auto &defaults{context_.defaultKinds()};
|
||||
int defaultKind{defaults.GetDefaultKind(TypeCategory::Real)};
|
||||
int defaultKind{context_.GetDefaultKind(TypeCategory::Real)};
|
||||
const char *end{x.real.source.end()};
|
||||
std::optional<int> letterKind;
|
||||
for (const char *p{x.real.source.begin()}; p < end; ++p) {
|
||||
if (parser::IsLetter(*p)) {
|
||||
switch (*p) {
|
||||
case 'e': letterKind = defaults.GetDefaultKind(TypeCategory::Real); break;
|
||||
case 'd': letterKind = defaults.doublePrecisionKind(); break;
|
||||
case 'q': letterKind = defaults.quadPrecisionKind(); break;
|
||||
case 'e': letterKind = context_.GetDefaultKind(TypeCategory::Real); break;
|
||||
case 'd': letterKind = context_.doublePrecisionKind(); break;
|
||||
case 'q': letterKind = context_.quadPrecisionKind(); break;
|
||||
default: Say("Unknown exponent letter '%c'"_err_en_US, *p);
|
||||
}
|
||||
break;
|
||||
|
|
@ -1947,7 +1946,7 @@ Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(
|
|||
}
|
||||
|
||||
int ExpressionAnalyzer::GetDefaultKind(common::TypeCategory category) {
|
||||
return context_.defaultKinds().GetDefaultKind(category);
|
||||
return context_.GetDefaultKind(category);
|
||||
}
|
||||
|
||||
DynamicType ExpressionAnalyzer::GetDefaultKindOfType(
|
||||
|
|
@ -2012,7 +2011,7 @@ bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
|
|||
parser::ToUpperCaseLetters(type->AsFortran()));
|
||||
return false;
|
||||
} else if (defaultKind) {
|
||||
int kind{context_.defaultKinds().GetDefaultKind(category)};
|
||||
int kind{context_.GetDefaultKind(category)};
|
||||
if (type->kind() != kind) {
|
||||
Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US,
|
||||
kind, parser::ToUpperCaseLetters(EnumToString(category)),
|
||||
|
|
|
|||
|
|
@ -158,6 +158,7 @@ public:
|
|||
|
||||
MaybeExpr Analyze(const parser::Expr &);
|
||||
MaybeExpr Analyze(const parser::Variable &);
|
||||
MaybeExpr Analyze(const parser::Designator &);
|
||||
|
||||
template<typename A> MaybeExpr Analyze(const common::Indirection<A> &x) {
|
||||
return Analyze(x.value());
|
||||
|
|
@ -238,7 +239,6 @@ protected:
|
|||
int IntegerTypeSpecKind(const parser::IntegerTypeSpec &);
|
||||
|
||||
private:
|
||||
MaybeExpr Analyze(const parser::Designator &);
|
||||
MaybeExpr Analyze(const parser::IntLiteralConstant &);
|
||||
MaybeExpr Analyze(const parser::SignedIntLiteralConstant &);
|
||||
MaybeExpr Analyze(const parser::RealLiteralConstant &);
|
||||
|
|
|
|||
|
|
@ -15,7 +15,9 @@
|
|||
#include "resolve-names-utils.h"
|
||||
#include "expression.h"
|
||||
#include "semantics.h"
|
||||
#include "tools.h"
|
||||
#include "../common/idioms.h"
|
||||
#include "../common/indirection.h"
|
||||
#include "../evaluate/fold.h"
|
||||
#include "../evaluate/tools.h"
|
||||
#include "../evaluate/type.h"
|
||||
|
|
@ -286,4 +288,356 @@ Bound ArraySpecAnalyzer::GetBound(const parser::SpecificationExpr &x) {
|
|||
return Bound{std::move(expr)};
|
||||
}
|
||||
|
||||
// If SAVE is set on src, set it on all members of dst
|
||||
static void PropagateSaveAttr(
|
||||
const EquivalenceObject &src, EquivalenceSet &dst) {
|
||||
if (src.symbol.attrs().test(Attr::SAVE)) {
|
||||
for (auto &obj : dst) {
|
||||
obj.symbol.attrs().set(Attr::SAVE);
|
||||
}
|
||||
}
|
||||
}
|
||||
static void PropagateSaveAttr(const EquivalenceSet &src, EquivalenceSet &dst) {
|
||||
if (!src.empty()) {
|
||||
PropagateSaveAttr(src.front(), dst);
|
||||
}
|
||||
}
|
||||
|
||||
void EquivalenceSets::AddToSet(const parser::Designator &designator) {
|
||||
if (CheckDesignator(designator)) {
|
||||
Symbol &symbol{*currObject_.symbol};
|
||||
if (!currSet_.empty()) {
|
||||
// check this symbol against first of set for compatibility
|
||||
Symbol &first{currSet_.front().symbol};
|
||||
CheckCanEquivalence(designator.source, first, symbol) &&
|
||||
CheckCanEquivalence(designator.source, symbol, first);
|
||||
}
|
||||
auto subscripts{currObject_.subscripts};
|
||||
if (subscripts.empty() && symbol.IsObjectArray()) {
|
||||
// record a whole array as its first element
|
||||
for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) {
|
||||
if (auto &lbound{spec.lbound().GetExplicit()}) {
|
||||
if (auto subscript{evaluate::ToInt64(*lbound)}) {
|
||||
subscripts.push_back(*subscript);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
currSet_.emplace_back(symbol, subscripts);
|
||||
PropagateSaveAttr(currSet_.back(), currSet_);
|
||||
}
|
||||
currObject_ = {};
|
||||
}
|
||||
|
||||
void EquivalenceSets::FinishSet(const parser::CharBlock &source) {
|
||||
std::set<std::size_t> existing; // indices of sets intersecting this one
|
||||
for (auto &obj : currSet_) {
|
||||
auto it{objectToSet_.find(obj)};
|
||||
if (it != objectToSet_.end()) {
|
||||
existing.insert(it->second); // symbol already in this set
|
||||
}
|
||||
}
|
||||
if (existing.empty()) {
|
||||
sets_.push_back({}); // create a new equivalence set
|
||||
MergeInto(source, currSet_, sets_.size() - 1);
|
||||
} else {
|
||||
auto it{existing.begin()};
|
||||
std::size_t dstIndex{*it};
|
||||
MergeInto(source, currSet_, dstIndex);
|
||||
while (++it != existing.end()) {
|
||||
MergeInto(source, sets_[*it], dstIndex);
|
||||
}
|
||||
}
|
||||
currSet_.clear();
|
||||
}
|
||||
|
||||
// Report an error if sym1 and sym2 cannot be in the same equivalence set.
|
||||
bool EquivalenceSets::CheckCanEquivalence(
|
||||
const parser::CharBlock &source, const Symbol &sym1, const Symbol &sym2) {
|
||||
parser::MessageFixedText msg{"", 0};
|
||||
const DeclTypeSpec *type1{sym1.GetType()};
|
||||
const DeclTypeSpec *type2{sym2.GetType()};
|
||||
bool isNum1{IsNumericSequenceType(type1)};
|
||||
bool isNum2{IsNumericSequenceType(type2)};
|
||||
bool isChar1{IsCharacterSequenceType(type1)};
|
||||
bool isChar2{IsCharacterSequenceType(type2)};
|
||||
if (sym1.attrs().test(Attr::PROTECTED) &&
|
||||
!sym2.attrs().test(Attr::PROTECTED)) { // C8114
|
||||
msg = "Equivalence set cannot contain '%s'"
|
||||
" with PROTECTED attribute and '%s' without"_err_en_US;
|
||||
} else if (isNum1) {
|
||||
if (!isNum2) { // C8110
|
||||
msg = "Equivalence set cannot contain '%s'"
|
||||
" that is numeric sequence type and '%s' that is not"_err_en_US;
|
||||
}
|
||||
} else if (isChar1) {
|
||||
if (!isChar2) { // C8111
|
||||
msg = "Equivalence set cannot contain '%s'"
|
||||
" that is character sequence type and '%s' that is not"_err_en_US;
|
||||
}
|
||||
} else if (!isNum2 && !isChar2 && *type1 != *type2) { // C8112, C8113
|
||||
msg = "Equivalence set cannot contain '%s' and '%s' with different types"
|
||||
" that are neither numeric nor character sequence types"_err_en_US;
|
||||
}
|
||||
if (!msg.text().empty()) {
|
||||
context_.Say(source, std::move(msg), sym1.name(), sym2.name());
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
|
||||
// Move objects from src to sets_[dstIndex]
|
||||
void EquivalenceSets::MergeInto(const parser::CharBlock &source,
|
||||
EquivalenceSet &src, std::size_t dstIndex) {
|
||||
EquivalenceSet &dst{sets_[dstIndex]};
|
||||
PropagateSaveAttr(dst, src);
|
||||
for (const auto &obj : src) {
|
||||
if (const auto *obj2{Find(dst, obj.symbol)}) {
|
||||
if (obj == *obj2) {
|
||||
continue; // already there
|
||||
}
|
||||
context_.Say(source,
|
||||
"'%s' and '%s' cannot have the same first storage unit"_err_en_US,
|
||||
obj2->AsFortran(), obj.AsFortran());
|
||||
} else {
|
||||
dst.push_back(obj);
|
||||
}
|
||||
objectToSet_[obj] = dstIndex;
|
||||
}
|
||||
PropagateSaveAttr(src, dst);
|
||||
src.clear();
|
||||
}
|
||||
|
||||
// If set has an object with this symbol, return it.
|
||||
const EquivalenceObject *EquivalenceSets::Find(
|
||||
const EquivalenceSet &set, const Symbol &symbol) {
|
||||
for (const auto &obj : set) {
|
||||
if (obj.symbol == symbol) {
|
||||
return &obj;
|
||||
}
|
||||
}
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
bool EquivalenceSets::CheckDesignator(const parser::Designator &designator) {
|
||||
return std::visit(
|
||||
common::visitors{
|
||||
[&](const parser::DataRef &x) {
|
||||
return CheckDataRef(designator.source, x);
|
||||
},
|
||||
[&](const parser::Substring &x) {
|
||||
const auto &dataRef{std::get<parser::DataRef>(x.t)};
|
||||
const auto &range{std::get<parser::SubstringRange>(x.t)};
|
||||
bool ok{CheckDataRef(designator.source, dataRef)};
|
||||
if (const auto &lb{std::get<0>(range.t)}) {
|
||||
ok &= CheckBound(lb->thing.thing.value(), true);
|
||||
}
|
||||
if (const auto &ub{std::get<1>(range.t)}) {
|
||||
ok &= CheckBound(ub->thing.thing.value(), true);
|
||||
}
|
||||
return ok;
|
||||
},
|
||||
},
|
||||
designator.u);
|
||||
}
|
||||
|
||||
bool EquivalenceSets::CheckDataRef(
|
||||
const parser::CharBlock &source, const parser::DataRef &x) {
|
||||
return std::visit(
|
||||
common::visitors{
|
||||
[&](const parser::Name &name) { return CheckObject(name); },
|
||||
[&](const common::Indirection<parser::StructureComponent> &) {
|
||||
context_.Say(source, // C8107
|
||||
"Derived type component '%s' is not allowed in an equivalence set"_err_en_US,
|
||||
source);
|
||||
return false;
|
||||
},
|
||||
[&](const common::Indirection<parser::ArrayElement> &elem) {
|
||||
bool ok{CheckDataRef(source, elem.value().base)};
|
||||
for (const auto &subscript : elem.value().subscripts) {
|
||||
ok &= std::visit(
|
||||
common::visitors{
|
||||
[&](const parser::SubscriptTriplet &y) {
|
||||
context_.Say(source, // C924, R872
|
||||
"Array section '%s' is not allowed in an equivalence set"_err_en_US,
|
||||
source);
|
||||
return false;
|
||||
},
|
||||
[&](const parser::IntExpr &y) {
|
||||
return CheckBound(y.thing.value());
|
||||
},
|
||||
},
|
||||
subscript.u);
|
||||
}
|
||||
return ok;
|
||||
},
|
||||
[&](const common::Indirection<parser::CoindexedNamedObject> &) {
|
||||
context_.Say(source, // C924 (R872)
|
||||
"Coindexed object '%s' is not allowed in an equivalence set"_err_en_US,
|
||||
source);
|
||||
return false;
|
||||
},
|
||||
},
|
||||
x.u);
|
||||
}
|
||||
|
||||
static bool InCommonWithBind(const Symbol &symbol) {
|
||||
if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
|
||||
const Symbol *commonBlock{details->commonBlock()};
|
||||
return commonBlock && commonBlock->attrs().test(Attr::BIND_C);
|
||||
} else {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
// If symbol can't be in equivalence set report error and return false;
|
||||
bool EquivalenceSets::CheckObject(const parser::Name &name) {
|
||||
if (!name.symbol) {
|
||||
return false; // an error has already occurred
|
||||
}
|
||||
currObject_.symbol = name.symbol;
|
||||
parser::MessageFixedText msg{"", 0};
|
||||
const Symbol &symbol{*name.symbol};
|
||||
if (symbol.owner().kind() == Scope::Kind::DerivedType) { // C8107
|
||||
msg = "Derived type component '%s'"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (symbol.IsDummy()) { // C8106
|
||||
msg = "Dummy argument '%s' is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (symbol.IsFuncResult()) { // C8106
|
||||
msg = "Function result '%s' is not allow in an equivalence set"_err_en_US;
|
||||
} else if (IsPointer(symbol)) { // C8106
|
||||
msg = "Pointer '%s' is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (IsAllocatable(symbol)) { // C8106
|
||||
msg = "Allocatable variable '%s'"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (symbol.Corank() > 0) { // C8106
|
||||
msg = "Coarray '%s' is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (symbol.has<UseDetails>()) { // C8115
|
||||
msg = "Use-associated variable '%s'"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (symbol.attrs().test(Attr::BIND_C)) { // C8106
|
||||
msg = "Variable '%s' with BIND attribute"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (symbol.attrs().test(Attr::TARGET)) { // C8108
|
||||
msg = "Variable '%s' with TARGET attribute"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (symbol.attrs().test(Attr::PARAMETER)) { // C8106
|
||||
msg = "Named constant '%s' is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (InCommonWithBind(symbol)) { // C8106
|
||||
msg = "Variable '%s' in common block with BIND attribute"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (const auto *type{symbol.GetType()}) {
|
||||
if (const auto *derived{type->AsDerived()}) {
|
||||
if (const auto *comp{FindUltimateComponent(
|
||||
*derived, IsAllocatableOrPointer)}) { // C8106
|
||||
msg = IsPointer(*comp)
|
||||
? "Derived type object '%s' with pointer ultimate component"
|
||||
" is not allowed in an equivalence set"_err_en_US
|
||||
: "Derived type object '%s' with allocatable ultimate component"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
} else if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {
|
||||
msg = "Nonsequence derived type object '%s'"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
}
|
||||
} else if (symbol.IsObjectArray()) {
|
||||
for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) {
|
||||
auto &lbound{spec.lbound().GetExplicit()};
|
||||
auto &ubound{spec.ubound().GetExplicit()};
|
||||
if ((lbound && !evaluate::ToInt64(*lbound)) ||
|
||||
(ubound && !evaluate::ToInt64(*ubound))) {
|
||||
msg = "Automatic array '%s'"
|
||||
" is not allowed in an equivalence set"_err_en_US;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (!msg.text().empty()) {
|
||||
context_.Say(name.source, std::move(msg), name.source);
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
|
||||
bool EquivalenceSets::CheckBound(const parser::Expr &bound, bool isSubstring) {
|
||||
MaybeExpr expr{
|
||||
evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};
|
||||
if (!expr) {
|
||||
return false;
|
||||
}
|
||||
if (expr->Rank() > 0) {
|
||||
context_.Say(bound.source, // C924, R872
|
||||
"Array with vector subscript '%s' is not allowed in an equivalence set"_err_en_US,
|
||||
bound.source);
|
||||
return false;
|
||||
}
|
||||
auto subscript{evaluate::ToInt64(*expr)};
|
||||
if (!subscript.has_value()) {
|
||||
context_.Say(bound.source, // C8109
|
||||
"%s with nonconstant bound '%s' is not allowed in an equivalence set"_err_en_US,
|
||||
isSubstring ? "Substring" : "Subscript", bound.source);
|
||||
return false;
|
||||
}
|
||||
if (isSubstring && currObject_.subscripts.size() == 1 &&
|
||||
*subscript < currObject_.subscripts.front()) {
|
||||
context_.Say(bound.source, // C8116
|
||||
"Substring with zero length is not allowed in an equivalence set"_err_en_US);
|
||||
return false;
|
||||
}
|
||||
currObject_.subscripts.push_back(*subscript);
|
||||
return true;
|
||||
}
|
||||
|
||||
bool EquivalenceSets::IsCharacterSequenceType(const DeclTypeSpec *type) {
|
||||
return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
|
||||
auto kind{evaluate::ToInt64(type.kind())};
|
||||
return type.category() == TypeCategory::Character && kind.has_value() &&
|
||||
kind.value() == context_.GetDefaultKind(TypeCategory::Character);
|
||||
});
|
||||
}
|
||||
|
||||
// Numeric or logical type of default kind or DOUBLE PRECISION or DOUBLE COMPLEX
|
||||
bool EquivalenceSets::IsDefaultKindNumericType(const IntrinsicTypeSpec &type) {
|
||||
if (auto kind{evaluate::ToInt64(type.kind())}) {
|
||||
auto category{type.category()};
|
||||
auto defaultKind{context_.GetDefaultKind(category)};
|
||||
switch (category) {
|
||||
case TypeCategory::Integer:
|
||||
case TypeCategory::Logical: return *kind == defaultKind;
|
||||
case TypeCategory::Real:
|
||||
case TypeCategory::Complex:
|
||||
return *kind == defaultKind || *kind == context_.doublePrecisionKind();
|
||||
default: return false;
|
||||
}
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
bool EquivalenceSets::IsNumericSequenceType(const DeclTypeSpec *type) {
|
||||
return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
|
||||
return IsDefaultKindNumericType(type);
|
||||
});
|
||||
}
|
||||
|
||||
// Is type an intrinsic type that satisfies predicate or a sequence type
|
||||
// whose components do.
|
||||
bool EquivalenceSets::IsSequenceType(const DeclTypeSpec *type,
|
||||
std::function<bool(const IntrinsicTypeSpec &)> predicate) {
|
||||
if (!type) {
|
||||
return false;
|
||||
} else if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) {
|
||||
return predicate(*intrinsic);
|
||||
} else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
|
||||
for (const auto &pair : *derived->typeSymbol().scope()) {
|
||||
const Symbol &component{*pair.second};
|
||||
if (IsAllocatableOrPointer(component) ||
|
||||
!IsSequenceType(component.GetType(), predicate)) {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
return true;
|
||||
} else {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@
|
|||
|
||||
// Utility functions and class for use in resolve-names.cc.
|
||||
|
||||
#include "scope.h"
|
||||
#include "symbol.h"
|
||||
#include "type.h"
|
||||
#include "../parser/message.h"
|
||||
|
|
@ -24,9 +25,12 @@
|
|||
namespace Fortran::parser {
|
||||
class CharBlock;
|
||||
struct ArraySpec;
|
||||
struct ComponentArraySpec;
|
||||
struct CoarraySpec;
|
||||
struct ComponentArraySpec;
|
||||
struct DataRef;
|
||||
struct DefinedOpName;
|
||||
struct Designator;
|
||||
struct Expr;
|
||||
struct GenericSpec;
|
||||
struct Name;
|
||||
}
|
||||
|
|
@ -76,5 +80,42 @@ ArraySpec AnalyzeArraySpec(
|
|||
ArraySpec AnalyzeCoarraySpec(
|
||||
SemanticsContext &context, const parser::CoarraySpec &);
|
||||
|
||||
// Perform consistency checks on equivalence sets
|
||||
class EquivalenceSets {
|
||||
public:
|
||||
EquivalenceSets(SemanticsContext &context) : context_{context} {}
|
||||
std::vector<EquivalenceSet> &sets() { return sets_; };
|
||||
// Resolve this designator and add to the current equivalence set
|
||||
void AddToSet(const parser::Designator &);
|
||||
// Finish the current equivalence set: determine if it overlaps
|
||||
// with any of the others and perform necessary merges if it does.
|
||||
void FinishSet(const parser::CharBlock &);
|
||||
|
||||
private:
|
||||
bool CheckCanEquivalence(
|
||||
const parser::CharBlock &, const Symbol &, const Symbol &);
|
||||
void MergeInto(const parser::CharBlock &, EquivalenceSet &, std::size_t);
|
||||
const EquivalenceObject *Find(const EquivalenceSet &, const Symbol &);
|
||||
bool CheckDesignator(const parser::Designator &);
|
||||
bool CheckDataRef(const parser::CharBlock &, const parser::DataRef &);
|
||||
bool CheckObject(const parser::Name &);
|
||||
bool CheckBound(const parser::Expr &, bool isSubstring = false);
|
||||
bool IsCharacterSequenceType(const DeclTypeSpec *);
|
||||
bool IsDefaultKindNumericType(const IntrinsicTypeSpec &);
|
||||
bool IsNumericSequenceType(const DeclTypeSpec *);
|
||||
bool IsSequenceType(
|
||||
const DeclTypeSpec *, std::function<bool(const IntrinsicTypeSpec &)>);
|
||||
|
||||
SemanticsContext &context_;
|
||||
std::vector<EquivalenceSet> sets_; // all equivalence sets in this scope
|
||||
// Map object to index of set it is in
|
||||
std::map<EquivalenceObject, std::size_t> objectToSet_;
|
||||
EquivalenceSet currSet_; // equivalence set currently being constructed
|
||||
struct {
|
||||
Symbol *symbol{nullptr};
|
||||
std::vector<ConstantSubscript> subscripts;
|
||||
} currObject_; // equivalence object currently being constructed
|
||||
};
|
||||
|
||||
}
|
||||
#endif // FORTRAN_SEMANTICS_RESOLVE_NAMES_H_
|
||||
|
|
|
|||
|
|
@ -724,6 +724,7 @@ public:
|
|||
void Post(const parser::CommonStmt::Block &);
|
||||
bool Pre(const parser::CommonBlockObject &);
|
||||
void Post(const parser::CommonBlockObject &);
|
||||
bool Pre(const parser::EquivalenceStmt &);
|
||||
bool Pre(const parser::SaveStmt &);
|
||||
|
||||
protected:
|
||||
|
|
@ -744,6 +745,7 @@ protected:
|
|||
bool CheckAccessibleComponent(const SourceName &, const Symbol &);
|
||||
void CheckCommonBlocks();
|
||||
void CheckSaveStmts();
|
||||
void CheckEquivalenceSets();
|
||||
bool CheckNotInBlock(const char *);
|
||||
bool NameIsKnownOrIntrinsic(const parser::Name &);
|
||||
|
||||
|
|
@ -773,6 +775,8 @@ private:
|
|||
bool sequence{false}; // is a sequence type
|
||||
const Symbol *type{nullptr}; // derived type being defined
|
||||
} derivedTypeInfo_;
|
||||
// Collect equivalence sets and process at end of specification part
|
||||
std::vector<const std::list<parser::EquivalenceObject> *> equivalenceSets_;
|
||||
// Info about common blocks in the current scope
|
||||
struct {
|
||||
Symbol *curr{nullptr}; // common block currently being processed
|
||||
|
|
@ -1264,13 +1268,11 @@ void DeclTypeSpecVisitor::Post(const parser::TypeSpec &typeSpec) {
|
|||
|
||||
void DeclTypeSpecVisitor::Post(
|
||||
const parser::IntrinsicTypeSpec::DoublePrecision &) {
|
||||
MakeNumericType(
|
||||
TypeCategory::Real, context().defaultKinds().doublePrecisionKind());
|
||||
MakeNumericType(TypeCategory::Real, context().doublePrecisionKind());
|
||||
}
|
||||
void DeclTypeSpecVisitor::Post(
|
||||
const parser::IntrinsicTypeSpec::DoubleComplex &) {
|
||||
MakeNumericType(
|
||||
TypeCategory::Complex, context().defaultKinds().doublePrecisionKind());
|
||||
MakeNumericType(TypeCategory::Complex, context().doublePrecisionKind());
|
||||
}
|
||||
void DeclTypeSpecVisitor::MakeNumericType(TypeCategory category, int kind) {
|
||||
SetDeclTypeSpec(context().MakeNumericType(category, kind));
|
||||
|
|
@ -2723,8 +2725,8 @@ void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Character &x) {
|
|||
charInfo_.length = ParamValue{1};
|
||||
}
|
||||
if (!charInfo_.kind.has_value()) {
|
||||
charInfo_.kind = KindExpr{
|
||||
context().defaultKinds().GetDefaultKind(TypeCategory::Character)};
|
||||
charInfo_.kind =
|
||||
KindExpr{context().GetDefaultKind(TypeCategory::Character)};
|
||||
}
|
||||
SetDeclTypeSpec(currScope().MakeCharacterType(
|
||||
std::move(*charInfo_.length), std::move(*charInfo_.kind)));
|
||||
|
|
@ -3398,6 +3400,40 @@ void DeclarationVisitor::Post(const parser::CommonBlockObject &x) {
|
|||
details->set_commonBlock(*commonBlockInfo_.curr);
|
||||
}
|
||||
|
||||
bool DeclarationVisitor::Pre(const parser::EquivalenceStmt &x) {
|
||||
// save equivalence sets to be processed after specification part
|
||||
for (const std::list<parser::EquivalenceObject> &set : x.v) {
|
||||
equivalenceSets_.push_back(&set);
|
||||
}
|
||||
return false; // don't implicitly declare names yet
|
||||
}
|
||||
|
||||
void DeclarationVisitor::CheckEquivalenceSets() {
|
||||
EquivalenceSets equivSets{context()};
|
||||
for (const auto *set : equivalenceSets_) {
|
||||
const auto &source{set->front().v.value().source};
|
||||
if (set->size() <= 1) { // R871
|
||||
Say(source, "Equivalence set must have more than one object"_err_en_US);
|
||||
}
|
||||
for (const parser::EquivalenceObject &object : *set) {
|
||||
const auto &designator{object.v.value()};
|
||||
// The designator was not resolved when it was encountered so do it now.
|
||||
// AnalyzeExpr causes array sections to be changed to substrings as needed
|
||||
Walk(designator);
|
||||
if (AnalyzeExpr(context(), designator)) {
|
||||
equivSets.AddToSet(designator);
|
||||
}
|
||||
}
|
||||
equivSets.FinishSet(source);
|
||||
}
|
||||
for (auto &set : equivSets.sets()) {
|
||||
if (!set.empty()) {
|
||||
currScope().add_equivalenceSet(std::move(set));
|
||||
}
|
||||
}
|
||||
equivalenceSets_.clear();
|
||||
}
|
||||
|
||||
bool DeclarationVisitor::Pre(const parser::SaveStmt &x) {
|
||||
if (x.v.empty()) {
|
||||
saveInfo_.saveAll = currStmtSource();
|
||||
|
|
@ -4551,6 +4587,7 @@ void ResolveNamesVisitor::Post(const parser::SpecificationPart &) {
|
|||
}
|
||||
CheckSaveStmts();
|
||||
CheckCommonBlocks();
|
||||
CheckEquivalenceSets();
|
||||
}
|
||||
|
||||
void ResolveNamesVisitor::CheckImports() {
|
||||
|
|
|
|||
|
|
@ -25,6 +25,29 @@ namespace Fortran::semantics {
|
|||
|
||||
Symbols<1024> Scope::allSymbols;
|
||||
|
||||
bool EquivalenceObject::operator==(const EquivalenceObject &that) const {
|
||||
return symbol == that.symbol && subscripts == that.subscripts;
|
||||
}
|
||||
|
||||
bool EquivalenceObject::operator<(const EquivalenceObject &that) const {
|
||||
return &symbol < &that.symbol ||
|
||||
(&symbol == &that.symbol && subscripts < that.subscripts);
|
||||
}
|
||||
|
||||
std::string EquivalenceObject::AsFortran() const {
|
||||
std::stringstream ss;
|
||||
ss << symbol.name().ToString();
|
||||
if (!subscripts.empty()) {
|
||||
char sep{'('};
|
||||
for (auto subscript : subscripts) {
|
||||
ss << sep << subscript;
|
||||
sep = ',';
|
||||
}
|
||||
ss << ')';
|
||||
}
|
||||
return ss.str();
|
||||
}
|
||||
|
||||
bool Scope::IsModule() const {
|
||||
return kind_ == Kind::Module && !symbol_->get<ModuleDetails>().isSubmodule();
|
||||
}
|
||||
|
|
@ -58,6 +81,14 @@ Symbol *Scope::FindSymbol(const SourceName &name) const {
|
|||
return nullptr;
|
||||
}
|
||||
}
|
||||
|
||||
const std::list<EquivalenceSet> &Scope::equivalenceSets() const {
|
||||
return equivalenceSets_;
|
||||
}
|
||||
void Scope::add_equivalenceSet(EquivalenceSet &&set) {
|
||||
equivalenceSets_.emplace_back(std::move(set));
|
||||
}
|
||||
|
||||
Symbol &Scope::MakeCommonBlock(const SourceName &name) {
|
||||
const auto it{commonBlocks_.find(name)};
|
||||
if (it != commonBlocks_.end()) {
|
||||
|
|
@ -225,6 +256,16 @@ std::ostream &operator<<(std::ostream &os, const Scope &scope) {
|
|||
const auto *symbol{pair.second};
|
||||
os << " " << *symbol << '\n';
|
||||
}
|
||||
if (!scope.equivalenceSets_.empty()) {
|
||||
os << " Equivalence Sets:\n";
|
||||
for (const auto &set : scope.equivalenceSets_) {
|
||||
os << " ";
|
||||
for (const auto &object : set) {
|
||||
os << ' ' << object.AsFortran();
|
||||
}
|
||||
os << '\n';
|
||||
}
|
||||
}
|
||||
for (const auto &pair : scope.commonBlocks_) {
|
||||
const auto *symbol{pair.second};
|
||||
os << " " << *symbol << '\n';
|
||||
|
|
@ -298,8 +339,7 @@ const DeclTypeSpec &Scope::InstantiateIntrinsicType(
|
|||
KindExpr copy{intrinsic->kind()};
|
||||
evaluate::FoldingContext &foldingContext{semanticsContext.foldingContext()};
|
||||
copy = evaluate::Fold(foldingContext, std::move(copy));
|
||||
int kind{
|
||||
semanticsContext.defaultKinds().GetDefaultKind(intrinsic->category())};
|
||||
int kind{semanticsContext.GetDefaultKind(intrinsic->category())};
|
||||
if (auto value{evaluate::ToInt64(copy)}) {
|
||||
if (evaluate::IsValidKindOfIntrinsicType(intrinsic->category(), *value)) {
|
||||
kind = *value;
|
||||
|
|
|
|||
|
|
@ -31,6 +31,22 @@ namespace Fortran::semantics {
|
|||
class SemanticsContext;
|
||||
using namespace parser::literals;
|
||||
|
||||
using common::ConstantSubscript;
|
||||
|
||||
// An equivalence object is represented by a symbol for the variable name
|
||||
// and the constant lower bound of a substring or indices of an array element.
|
||||
struct EquivalenceObject {
|
||||
EquivalenceObject(Symbol &symbol, std::vector<ConstantSubscript> subscripts)
|
||||
: symbol{symbol}, subscripts{subscripts} {}
|
||||
bool operator==(const EquivalenceObject &) const;
|
||||
bool operator<(const EquivalenceObject &) const;
|
||||
std::string AsFortran() const;
|
||||
|
||||
Symbol &symbol;
|
||||
std::vector<ConstantSubscript> subscripts; // for array elem or substring
|
||||
};
|
||||
using EquivalenceSet = std::vector<EquivalenceObject>;
|
||||
|
||||
class Scope {
|
||||
using mapType = std::map<SourceName, Symbol *>;
|
||||
|
||||
|
|
@ -122,6 +138,8 @@ public:
|
|||
return symbols_.emplace(name, &symbol);
|
||||
}
|
||||
|
||||
const std::list<EquivalenceSet> &equivalenceSets() const;
|
||||
void add_equivalenceSet(EquivalenceSet &&);
|
||||
mapType &commonBlocks() { return commonBlocks_; }
|
||||
const mapType &commonBlocks() const { return commonBlocks_; }
|
||||
Symbol &MakeCommonBlock(const SourceName &);
|
||||
|
|
@ -207,6 +225,7 @@ private:
|
|||
std::list<Scope> children_;
|
||||
mapType symbols_;
|
||||
mapType commonBlocks_;
|
||||
std::list<EquivalenceSet> equivalenceSets_;
|
||||
std::map<SourceName, Scope *> submodules_;
|
||||
std::list<DeclTypeSpec> declTypeSpecs_;
|
||||
std::string chars_;
|
||||
|
|
|
|||
|
|
@ -105,6 +105,10 @@ SemanticsContext::SemanticsContext(
|
|||
|
||||
SemanticsContext::~SemanticsContext() {}
|
||||
|
||||
int SemanticsContext::GetDefaultKind(TypeCategory category) const {
|
||||
return defaultKinds_.GetDefaultKind(category);
|
||||
}
|
||||
|
||||
bool SemanticsContext::IsEnabled(parser::LanguageFeature feature) const {
|
||||
return languageFeatures_.IsEnabled(feature);
|
||||
}
|
||||
|
|
@ -116,13 +120,13 @@ bool SemanticsContext::ShouldWarn(parser::LanguageFeature feature) const {
|
|||
const DeclTypeSpec &SemanticsContext::MakeNumericType(
|
||||
TypeCategory category, int kind) {
|
||||
if (kind == 0) {
|
||||
kind = defaultKinds_.GetDefaultKind(category);
|
||||
kind = GetDefaultKind(category);
|
||||
}
|
||||
return globalScope_.MakeNumericType(category, KindExpr{kind});
|
||||
}
|
||||
const DeclTypeSpec &SemanticsContext::MakeLogicalType(int kind) {
|
||||
if (kind == 0) {
|
||||
kind = defaultKinds_.GetDefaultKind(TypeCategory::Logical);
|
||||
kind = GetDefaultKind(TypeCategory::Logical);
|
||||
}
|
||||
return globalScope_.MakeLogicalType(KindExpr{kind});
|
||||
}
|
||||
|
|
@ -197,6 +201,20 @@ void DoDumpSymbols(std::ostream &os, const Scope &scope, int indent) {
|
|||
}
|
||||
}
|
||||
}
|
||||
if (!scope.equivalenceSets().empty()) {
|
||||
PutIndent(os, indent);
|
||||
os << "Equivalence Sets:";
|
||||
for (const auto &set : scope.equivalenceSets()) {
|
||||
os << ' ';
|
||||
char sep = '(';
|
||||
for (const auto &object : set) {
|
||||
os << sep << object.AsFortran();
|
||||
sep = ',';
|
||||
}
|
||||
os << ')';
|
||||
}
|
||||
os << '\n';
|
||||
}
|
||||
for (const auto &pair : scope.commonBlocks()) {
|
||||
const auto &symbol{*pair.second};
|
||||
PutIndent(os, indent);
|
||||
|
|
|
|||
|
|
@ -44,9 +44,11 @@ public:
|
|||
const parser::LanguageFeatureControl &, parser::AllSources &);
|
||||
~SemanticsContext();
|
||||
|
||||
const common::IntrinsicTypeDefaultKinds &defaultKinds() const {
|
||||
return defaultKinds_;
|
||||
int GetDefaultKind(TypeCategory) const;
|
||||
int doublePrecisionKind() const {
|
||||
return defaultKinds_.doublePrecisionKind();
|
||||
}
|
||||
int quadPrecisionKind() const { return defaultKinds_.quadPrecisionKind(); }
|
||||
bool IsEnabled(parser::LanguageFeature) const;
|
||||
bool ShouldWarn(parser::LanguageFeature) const;
|
||||
const parser::CharBlock *location() const { return location_; }
|
||||
|
|
|
|||
|
|
@ -276,8 +276,7 @@ bool ExprTypeKindIsDefault(
|
|||
auto dynamicType{expr.GetType()};
|
||||
return dynamicType.has_value() &&
|
||||
dynamicType->category() != common::TypeCategory::Derived &&
|
||||
dynamicType->kind() ==
|
||||
context.defaultKinds().GetDefaultKind(dynamicType->category());
|
||||
dynamicType->kind() == context.GetDefaultKind(dynamicType->category());
|
||||
}
|
||||
|
||||
const Symbol *FindFunctionResult(const Symbol &symbol) {
|
||||
|
|
@ -309,38 +308,11 @@ bool IsTeamType(const DerivedTypeSpec *derived) {
|
|||
return IsDerivedTypeFromModule(derived, "iso_fortran_env", "team_type");
|
||||
}
|
||||
|
||||
bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; }
|
||||
|
||||
const Symbol *HasCoarrayUltimateComponent(
|
||||
const DerivedTypeSpec &derivedTypeSpec) {
|
||||
const Symbol &symbol{derivedTypeSpec.typeSymbol()};
|
||||
// TODO is it guaranteed that derived type symbol have a scope and is it the
|
||||
// right scope to look into?
|
||||
CHECK(symbol.scope());
|
||||
for (const Symbol *componentSymbol :
|
||||
symbol.get<DerivedTypeDetails>().OrderComponents(*symbol.scope())) {
|
||||
CHECK(componentSymbol);
|
||||
const ObjectEntityDetails &objectDetails{
|
||||
componentSymbol->get<ObjectEntityDetails>()};
|
||||
if (objectDetails.IsCoarray()) {
|
||||
// Coarrays are ultimate components because they must be allocatable
|
||||
// according to C746.
|
||||
return componentSymbol;
|
||||
}
|
||||
if (!IsAllocatableOrPointer(*componentSymbol)) {
|
||||
if (const DeclTypeSpec * declTypeSpec{objectDetails.type()}) {
|
||||
if (const DerivedTypeSpec *
|
||||
componentDerivedTypeSpec{declTypeSpec->AsDerived()}) {
|
||||
// Avoid infinite loop, though this should not happen due to C744
|
||||
CHECK(&symbol != &componentDerivedTypeSpec->typeSymbol());
|
||||
if (const Symbol *
|
||||
subcomponent{
|
||||
HasCoarrayUltimateComponent(*componentDerivedTypeSpec)}) {
|
||||
return subcomponent;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return nullptr;
|
||||
return FindUltimateComponent(derivedTypeSpec, IsCoarray);
|
||||
}
|
||||
|
||||
const bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
|
||||
|
|
@ -382,4 +354,26 @@ const Symbol *HasEventOrLockPotentialComponent(
|
|||
}
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
const Symbol *FindUltimateComponent(const DerivedTypeSpec &derivedTypeSpec,
|
||||
std::function<bool(const Symbol &)> predicate) {
|
||||
const auto *scope{derivedTypeSpec.typeSymbol().scope()};
|
||||
CHECK(scope);
|
||||
for (const auto &pair : *scope) {
|
||||
const Symbol &component{*pair.second};
|
||||
const DeclTypeSpec *type{component.GetType()};
|
||||
if (!type) {
|
||||
continue;
|
||||
}
|
||||
const DerivedTypeSpec *derived{type->AsDerived()};
|
||||
bool isUltimate{IsAllocatableOrPointer(component) || !derived};
|
||||
if (const Symbol *
|
||||
result{!isUltimate ? FindUltimateComponent(*derived, predicate)
|
||||
: predicate(component) ? &component : nullptr}) {
|
||||
return result;
|
||||
}
|
||||
}
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@
|
|||
#include "../evaluate/expression.h"
|
||||
#include "../evaluate/variable.h"
|
||||
#include "../parser/parse-tree.h"
|
||||
#include <functional>
|
||||
|
||||
namespace Fortran::semantics {
|
||||
|
||||
|
|
@ -72,6 +73,10 @@ const Symbol *HasCoarrayUltimateComponent(const DerivedTypeSpec &);
|
|||
// ISO_FORTRAN_ENV module.
|
||||
const Symbol *HasEventOrLockPotentialComponent(const DerivedTypeSpec &);
|
||||
|
||||
// Return an ultimate component of type that matches predicate, or nullptr.
|
||||
const Symbol *FindUltimateComponent(
|
||||
const DerivedTypeSpec &type, std::function<bool(const Symbol &)> predicate);
|
||||
|
||||
inline bool IsPointer(const Symbol &symbol) {
|
||||
return symbol.attrs().test(Attr::POINTER);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -135,8 +135,7 @@ class NumericTypeSpec : public IntrinsicTypeSpec {
|
|||
public:
|
||||
NumericTypeSpec(TypeCategory category, KindExpr &&kind)
|
||||
: IntrinsicTypeSpec(category, std::move(kind)) {
|
||||
CHECK(category == TypeCategory::Integer || category == TypeCategory::Real ||
|
||||
category == TypeCategory::Complex);
|
||||
CHECK(common::IsNumericTypeCategory(category));
|
||||
}
|
||||
};
|
||||
|
||||
|
|
|
|||
|
|
@ -127,6 +127,7 @@ set(ERROR_TESTS
|
|||
dosemantics03.f90
|
||||
expr-errors01.f90
|
||||
null01.f90
|
||||
equivalence01.f90
|
||||
)
|
||||
|
||||
# These test files have expected symbols in the source
|
||||
|
|
@ -142,6 +143,7 @@ set(SYMBOL_TESTS
|
|||
symbol09.f90
|
||||
symbol10.f90
|
||||
symbol11.f90
|
||||
symbol12.f90
|
||||
kinds01.f90
|
||||
kinds03.f90
|
||||
procinterface01.f90
|
||||
|
|
|
|||
|
|
@ -0,0 +1,186 @@
|
|||
! 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.
|
||||
|
||||
subroutine s1
|
||||
integer i, j
|
||||
real r(2)
|
||||
!ERROR: Equivalence set must have more than one object
|
||||
equivalence(i, j),(r(1))
|
||||
end
|
||||
|
||||
subroutine s2
|
||||
integer i
|
||||
type t
|
||||
integer :: a
|
||||
integer :: b(10)
|
||||
end type
|
||||
type(t) :: x
|
||||
!ERROR: Derived type component 'x%a' is not allowed in an equivalence set
|
||||
equivalence(x%a, i)
|
||||
!ERROR: Derived type component 'x%b(2)' is not allowed in an equivalence set
|
||||
equivalence(i, x%b(2))
|
||||
end
|
||||
|
||||
integer function f3(x)
|
||||
real x
|
||||
!ERROR: Dummy argument 'x' is not allowed in an equivalence set
|
||||
equivalence(i, x)
|
||||
!ERROR: Function result 'f3' is not allow in an equivalence set
|
||||
equivalence(f3, i)
|
||||
end
|
||||
|
||||
subroutine s4
|
||||
integer :: y
|
||||
!ERROR: Pointer 'x' is not allowed in an equivalence set
|
||||
!ERROR: Allocatable variable 'y' is not allowed in an equivalence set
|
||||
equivalence(x, y)
|
||||
real, pointer :: x
|
||||
allocatable :: y
|
||||
end
|
||||
|
||||
subroutine s5
|
||||
integer, parameter :: k = 123
|
||||
real :: x(10)
|
||||
real, save :: y[1:*]
|
||||
!ERROR: Coarray 'y' is not allowed in an equivalence set
|
||||
equivalence(x, y)
|
||||
!ERROR: Variable 'z' with BIND attribute is not allowed in an equivalence set
|
||||
equivalence(x, z)
|
||||
!ERROR: Variable 'z' with BIND attribute is not allowed in an equivalence set
|
||||
equivalence(x(2), z(3))
|
||||
real, bind(C) :: z(10)
|
||||
!ERROR: Named constant 'k' is not allowed in an equivalence set
|
||||
equivalence(x(2), k)
|
||||
!ERROR: Variable 'w' in common block with BIND attribute is not allowed in an equivalence set
|
||||
equivalence(x(10), w)
|
||||
logical :: w(10)
|
||||
bind(C, name="c") /c/
|
||||
common /c/ w
|
||||
integer, target :: u
|
||||
!ERROR: Variable 'u' with TARGET attribute is not allowed in an equivalence set
|
||||
equivalence(x(1), u)
|
||||
end
|
||||
|
||||
subroutine s6
|
||||
type t1
|
||||
sequence
|
||||
real, pointer :: p
|
||||
end type
|
||||
type :: t2
|
||||
sequence
|
||||
type(t1) :: b
|
||||
end type
|
||||
real :: x0
|
||||
type(t1) :: x1
|
||||
type(t2) :: x2
|
||||
!ERROR: Derived type object 'x1' with pointer ultimate component is not allowed in an equivalence set
|
||||
equivalence(x0, x1)
|
||||
!ERROR: Derived type object 'x2' with pointer ultimate component is not allowed in an equivalence set
|
||||
equivalence(x0, x2)
|
||||
end
|
||||
|
||||
subroutine s7
|
||||
type t1
|
||||
end type
|
||||
real :: x0
|
||||
type(t1) :: x1
|
||||
!ERROR: Nonsequence derived type object 'x1' is not allowed in an equivalence set
|
||||
equivalence(x0, x1)
|
||||
end
|
||||
|
||||
module m8
|
||||
real :: x
|
||||
real :: y(10)
|
||||
end
|
||||
subroutine s8
|
||||
use m8
|
||||
!ERROR: Use-associated variable 'x' is not allowed in an equivalence set
|
||||
equivalence(x, z)
|
||||
!ERROR: Use-associated variable 'y' is not allowed in an equivalence set
|
||||
equivalence(y(1), z)
|
||||
end
|
||||
|
||||
subroutine s9
|
||||
character(10) :: c
|
||||
real :: d(10)
|
||||
integer, parameter :: n = 2
|
||||
integer :: i, j
|
||||
!ERROR: Substring with nonconstant bound 'n+j' is not allowed in an equivalence set
|
||||
equivalence(c(n+1:n+j), i)
|
||||
!ERROR: Substring with zero length is not allowed in an equivalence set
|
||||
equivalence(c(n:1), i)
|
||||
!ERROR: Subscript with nonconstant bound 'j-1' is not allowed in an equivalence set
|
||||
equivalence(d(j-1), i)
|
||||
!ERROR: Array section 'd(1:n)' is not allowed in an equivalence set
|
||||
equivalence(d(1:n), i)
|
||||
end
|
||||
|
||||
subroutine s10
|
||||
integer, parameter :: i(4) = [1, 2, 3, 4]
|
||||
real :: x(10)
|
||||
real :: y(4)
|
||||
!ERROR: Array with vector subscript 'i' is not allowed in an equivalence set
|
||||
equivalence(x(i), y)
|
||||
end
|
||||
|
||||
subroutine s11(n)
|
||||
integer :: n
|
||||
real :: x(n), y
|
||||
!ERROR: Automatic array 'x' is not allowed in an equivalence set
|
||||
equivalence(x(1), y)
|
||||
end
|
||||
|
||||
module s12
|
||||
real, protected :: a
|
||||
integer :: b
|
||||
!ERROR: Equivalence set cannot contain 'a' with PROTECTED attribute and 'b' without
|
||||
equivalence(a, b)
|
||||
!ERROR: Equivalence set cannot contain 'a' with PROTECTED attribute and 'b' without
|
||||
equivalence(b, a)
|
||||
end
|
||||
|
||||
module s13
|
||||
logical(8) :: a
|
||||
character(4) :: b
|
||||
type :: t1
|
||||
sequence
|
||||
complex :: z
|
||||
end type
|
||||
type :: t2
|
||||
sequence
|
||||
type(t1) :: w
|
||||
end type
|
||||
type(t2) :: c
|
||||
!ERROR: Equivalence set cannot contain 'b' that is character sequence type and 'a' that is not
|
||||
equivalence(a, b)
|
||||
!ERROR: Equivalence set cannot contain 'c' that is numeric sequence type and 'a' that is not
|
||||
equivalence(c, a)
|
||||
double precision :: d
|
||||
double complex :: e
|
||||
!OK: d and e are considered to be a default kind numeric type
|
||||
equivalence(c, d, e)
|
||||
end
|
||||
|
||||
module s14
|
||||
real :: a(10), b, c, d
|
||||
!ERROR: 'a(1)' and 'a(2)' cannot have the same first storage unit
|
||||
equivalence(a(1), a(2))
|
||||
equivalence(b, a(3))
|
||||
!ERROR: 'a(3)' and 'a(4)' cannot have the same first storage unit
|
||||
equivalence(a(4), b)
|
||||
equivalence(c, a(5))
|
||||
equivalence(a(6), d)
|
||||
!ERROR: 'a(5)' and 'a(6)' cannot have the same first storage unit
|
||||
equivalence(c, d)
|
||||
end
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
! 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.
|
||||
|
||||
! Verify that SAVE attribute is propagated by EQUIVALENCE
|
||||
|
||||
!DEF: /s1 Subprogram
|
||||
subroutine s1
|
||||
!DEF: /s1/a SAVE ObjectEntity REAL(4)
|
||||
!DEF: /s1/b SAVE ObjectEntity REAL(4)
|
||||
!DEF: /s1/c SAVE ObjectEntity REAL(4)
|
||||
!DEF: /s1/d SAVE ObjectEntity REAL(4)
|
||||
real a, b, c, d
|
||||
!REF: /s1/d
|
||||
save :: d
|
||||
!REF: /s1/a
|
||||
!REF: /s1/b
|
||||
equivalence(a, b)
|
||||
!REF: /s1/b
|
||||
!REF: /s1/c
|
||||
equivalence(b, c)
|
||||
!REF: /s1/c
|
||||
!REF: /s1/d
|
||||
equivalence(c, d)
|
||||
!DEF: /s1/e ObjectEntity INTEGER(4)
|
||||
!DEF: /s1/f ObjectEntity INTEGER(4)
|
||||
equivalence(e, f)
|
||||
!REF: /s1/e
|
||||
!REF: /s1/f
|
||||
integer e, f
|
||||
end subroutine
|
||||
Loading…
Reference in New Issue