Skip to content

Commit

Permalink
[flang] Implement checks for test/semantics/call02.f90
Browse files Browse the repository at this point in the history 
Original-commit: flang-compiler/f18@38eaaa7
Reviewed-on: flang-compiler/f18#745
Tree-same-pre-rewrite: false
  • Loading branch information
@klausler
klausler committed Sep 13, 2019
1 parent 5676797 commit 9c3a937
Show file tree
Hide file tree
Showing 13 changed files with 185 additions and 92 deletions.
24 changes: 18 additions & 6 deletions flang/lib/evaluate/call.cc
View file
Expand Up @@ -103,20 +103,32 @@ int ProcedureDesignator::Rank() const {
}
}
}
common::die("ProcedureDesignator::Rank(): no case");
DIE("ProcedureDesignator::Rank(): no case");
return 0;
}

bool ProcedureDesignator::IsElemental() const {
const semantics::Symbol *ProcedureDesignator::GetInterfaceSymbol() const {
if (const Symbol * symbol{GetSymbol()}) {
return symbol->attrs().test(semantics::Attr::ELEMENTAL);
if (const auto *details{
symbol->detailsIf<semantics::ProcEntityDetails>()}) {
return details->interface().symbol();
}
}
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
return nullptr;
}

bool ProcedureDesignator::IsElemental() const {
if (const Symbol * interface{GetInterfaceSymbol()}) {
return interface->attrs().test(semantics::Attr::ELEMENTAL);
} else if (const Symbol * symbol{GetSymbol()}) {
return symbol->attrs().test(semantics::Attr::ELEMENTAL);
} else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
return intrinsic->characteristics.value().attrs.test(
characteristics::Procedure::Attr::Elemental);
} else {
DIE("ProcedureDesignator::IsElemental(): no case");
}
common::die("ProcedureDesignator::IsElemental(): no case");
return 0;
return false;
}

const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const {
Expand Down
2 changes: 2 additions & 0 deletions flang/lib/evaluate/call.h
View file
Expand Up @@ -151,6 +151,8 @@ struct ProcedureDesignator {
// Always null if the procedure is intrinsic.
const Component *GetComponent() const;

const semantics::Symbol *GetInterfaceSymbol() const;

std::string GetName() const;
std::optional<DynamicType> GetType() const;
int Rank() const;
Expand Down
34 changes: 34 additions & 0 deletions flang/lib/evaluate/tools.h
View file
Expand Up @@ -245,6 +245,9 @@ template<typename A> std::optional<NamedEntity> ExtractNamedEntity(const A &x) {
[](Component &&component) -> std::optional<NamedEntity> {
return NamedEntity{std::move(component)};
},
[](CoarrayRef &&co) -> std::optional<NamedEntity> {
return co.GetBase();
},
[](auto &&) { return std::optional<NamedEntity>{}; },
},
std::move(dataRef->u));
Expand All @@ -253,6 +256,37 @@ template<typename A> std::optional<NamedEntity> ExtractNamedEntity(const A &x) {
}
}

struct ExtractCoindexedObjectHelper {
template<typename A> std::optional<CoarrayRef> operator()(const A &) const {
return std::nullopt;
}
std::optional<CoarrayRef> operator()(const CoarrayRef &x) const { return x; }
std::optional<CoarrayRef> operator()(const DataRef &dataRef) const {
return std::visit(*this, dataRef.u);
}
std::optional<CoarrayRef> operator()(const NamedEntity &named) const {
if (const Component * component{named.UnwrapComponent()}) {
return (*this)(*component);
} else {
return std::nullopt;
}
}
std::optional<CoarrayRef> operator()(const Component &component) const {
return (*this)(component.base());
}
std::optional<CoarrayRef> operator()(const ArrayRef &arrayRef) const {
return (*this)(arrayRef.base());
}
};

template<typename A> std::optional<CoarrayRef> ExtractCoarrayRef(const A &x) {
if (auto dataRef{ExtractDataRef(x)}) {
return ExtractCoindexedObjectHelper{}(*dataRef);
} else {
return std::nullopt;
}
}

// If an expression is simply a whole symbol data designator,
// extract and return that symbol, else null.
template<typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {
Expand Down
118 changes: 90 additions & 28 deletions flang/lib/semantics/expression.cc
View file
Expand Up @@ -909,8 +909,57 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
return std::nullopt;
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &) {
Say("TODO: CoindexedNamedObject unimplemented"_err_en_US);
MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {
if (auto dataRef{ExtractDataRef(Analyze(x.base))}) {
std::vector<Subscript> subscripts;
std::vector<const Symbol *> reversed;
if (auto *aRef{std::get_if<ArrayRef>(&dataRef->u)}) {
subscripts = std::move(aRef->subscript());
reversed.push_back(&aRef->GetLastSymbol());
if (Component * component{aRef->base().UnwrapComponent()}) {
*dataRef = std::move(component->base());
} else {
dataRef.reset();
}
}
if (dataRef.has_value()) {
while (auto *component{std::get_if<Component>(&dataRef->u)}) {
reversed.push_back(&component->GetLastSymbol());
*dataRef = std::move(component->base());
}
if (auto *baseSym{std::get_if<const Symbol *>(&dataRef->u)}) {
reversed.push_back(*baseSym);
} else {
Say("Base of coindexed named object has subscripts or cosubscripts"_err_en_US);
}
}
std::vector<Expr<SubscriptInteger>> cosubscripts;
bool cosubsOk{true};
for (const auto &cosub :
std::get<std::list<parser::Cosubscript>>(x.imageSelector.t)) {
MaybeExpr coex{Analyze(cosub)};
if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(coex)}) {
cosubscripts.push_back(
ConvertToType<SubscriptInteger>(std::move(*intExpr)));
} else {
cosubsOk = false;
}
}
if (cosubsOk && !reversed.empty()) {
int numCosubscripts{static_cast<int>(cosubscripts.size())};
const Symbol &symbol{*reversed.front()};
if (numCosubscripts != symbol.Corank()) {
Say("'%s' has corank %d, but coindexed reference has %d cosubscripts"_err_en_US,
symbol.name(), symbol.Corank(), numCosubscripts);
}
}
// TODO: stat=/team=/team_number=
// Reverse the chain of symbols so that the base is first and coarray
// ultimate component is last.
return Designate(DataRef{CoarrayRef{
std::vector<const Symbol *>{reversed.crbegin(), reversed.crend()},
std::move(subscripts), std::move(cosubscripts)}});
}
return std::nullopt;
}

Expand Down Expand Up @@ -1515,18 +1564,31 @@ std::optional<ActualArgument> ExpressionAnalyzer::AnalyzeActualArgument(
if (const Symbol * assumedTypeDummy{AssumedTypeDummy(expr)}) {
return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
} else if (MaybeExpr argExpr{Analyze(expr)}) {
return ActualArgument{Fold(GetFoldingContext(), std::move(*argExpr))};
} else {
return std::nullopt;
}
}

std::optional<ActualArgument> ExpressionAnalyzer::AnalyzeActualArgument(
const parser::Variable &var) {
if (const Symbol * assumedTypeDummy{AssumedTypeDummy(var)}) {
return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
} else if (MaybeExpr argExpr{Analyze(var)}) {
return ActualArgument{std::move(*argExpr)};
Expr<SomeType> x{Fold(GetFoldingContext(), std::move(*argExpr))};
if (const auto *proc{std::get_if<ProcedureDesignator>(&x.u)}) {
if (!std::holds_alternative<SpecificIntrinsic>(proc->u) &&
proc->IsElemental()) { // C1533
Say(expr.source,
"Non-intrinsic ELEMENTAL procedure cannot be passed as argument."_err_en_US);
}
}
if (auto coarrayRef{ExtractCoarrayRef(x)}) {
const Symbol &coarray{coarrayRef->GetLastSymbol()};
if (const semantics::DeclTypeSpec * type{coarray.GetType()}) {
if (const semantics::DerivedTypeSpec * derived{type->AsDerived()}) {
if (auto ptr{semantics::FindPointerUltimateComponent(*derived)}) {
if (auto *msg{Say(expr.source,
"Coindexed object '%s' with POINTER ultimate component '%s' cannot be passed as argument."_err_en_US,
coarray.name(), (*ptr)->name())}) {
msg->Attach((*ptr)->name(),
"Declaration of POINTER '%s' component of %s"_en_US,
(*ptr)->name(), type->AsFortran());
}
}
}
}
}
return ActualArgument{std::move(x)};
} else {
return std::nullopt;
}
Expand Down Expand Up @@ -1686,15 +1748,19 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
// Represent %LOC() exactly as if it had been a call to the LOC() extension
// intrinsic function.
// Use the actual source for the name of the call for error reporting.
if (std::optional<ActualArgument> arg{AnalyzeActualArgument(x.v.value())}) {
parser::CharBlock at{GetContextualMessages().at()};
CHECK(at.size() >= 4);
parser::CharBlock loc{at.begin() + 1, 3};
CHECK(loc == "loc");
return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
std::optional<ActualArgument> arg;
if (const Symbol * assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {
arg = ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
} else if (MaybeExpr argExpr{Analyze(x.v.value())}) {
arg = ActualArgument{std::move(*argExpr)};
} else {
return std::nullopt;
}
parser::CharBlock at{GetContextualMessages().at()};
CHECK(at.size() >= 4);
parser::CharBlock loc{at.begin() + 1, 3};
CHECK(loc == "loc");
return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
}

MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &) {
Expand Down Expand Up @@ -2192,18 +2258,14 @@ evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
return analyzer.AnalyzeKindSelector(category, selector);
}

void AnalyzeCallStmt(SemanticsContext &context, const parser::CallStmt &call) {
evaluate::ExpressionAnalyzer{context}.Analyze(call);
}

ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}

bool ExprChecker::Walk(const parser::Program &program) {
parser::Walk(program, *this);
return !context_.AnyFatalError();
}

CallChecker::CallChecker(SemanticsContext &context) : analyzer_{context} {}

void CallChecker::Enter(const parser::CallStmt &call) {
analyzer_.Analyze(call);
}

void CallChecker::Leave(const parser::CallStmt &) {}
}
20 changes: 6 additions & 14 deletions flang/lib/semantics/expression.h
View file
Expand Up @@ -313,7 +313,6 @@ class ExpressionAnalyzer {
std::optional<ProcedureDesignator> AnalyzeProcedureComponentRef(
const parser::ProcComponentRef &);
std::optional<ActualArgument> AnalyzeActualArgument(const parser::Expr &);
std::optional<ActualArgument> AnalyzeActualArgument(const parser::Variable &);

struct CalleeAndArguments {
ProcedureDesignator procedureDesignator;
Expand Down Expand Up @@ -375,6 +374,8 @@ evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
SemanticsContext &, common::TypeCategory,
const std::optional<parser::KindSelector> &);

void AnalyzeCallStmt(SemanticsContext &, const parser::CallStmt &);

// Semantic analysis of all expressions in a parse tree, which becomes
// decorated with typed representations for top-level expressions.
class ExprChecker {
Expand All @@ -393,6 +394,10 @@ class ExprChecker {
AnalyzeExpr(context_, x);
return false;
}
bool Pre(const parser::CallStmt &x) {
AnalyzeCallStmt(context_, x);
return false;
}

template<typename A> bool Pre(const parser::Scalar<A> &x) {
AnalyzeExpr(context_, x);
Expand All @@ -418,18 +423,5 @@ class ExprChecker {
private:
SemanticsContext &context_;
};

// Semantic analysis of all CALL statements in a parse tree.
// (Function references are processed as primary expressions.)
class CallChecker {
public:
explicit CallChecker(SemanticsContext &);
void Enter(const parser::CallStmt &);
void Leave(const parser::CallStmt &);

private:
evaluate::ExpressionAnalyzer analyzer_;
};

} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_EXPRESSION_H_
4 changes: 2 additions & 2 deletions flang/lib/semantics/resolve-names.cc
View file
Expand Up @@ -4058,8 +4058,8 @@ bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
.has_value()) {
// Unrestricted specific intrinsic function names (e.g., "cos")
// are acceptable as procedure interfaces.
Symbol &symbol{
MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC})};
Symbol &symbol{MakeSymbol(InclusiveScope(), name.source,
Attrs{Attr::INTRINSIC, Attr::ELEMENTAL})};
symbol.set_details(ProcEntityDetails{});
Resolve(name, symbol);
return true;
Expand Down
2 changes: 1 addition & 1 deletion flang/lib/semantics/semantics.cc
View file
Expand Up @@ -115,7 +115,7 @@ template<typename... C> class SemanticsVisitor : public virtual C... {

using StatementSemanticsPass1 = ExprChecker;
using StatementSemanticsPass2 = SemanticsVisitor<AllocateChecker,
ArithmeticIfStmtChecker, AssignmentChecker, CallChecker, CoarrayChecker,
ArithmeticIfStmtChecker, AssignmentChecker, CoarrayChecker,
DeallocateChecker, DoChecker, IfStmtChecker, IoChecker, NullifyChecker,
OmpStructureChecker, ReturnStmtChecker, StopChecker>;

Expand Down
7 changes: 7 additions & 0 deletions flang/lib/semantics/tools.cc
View file
Expand Up @@ -962,6 +962,13 @@ UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
[](const Symbol *component) { return DEREF(component).Corank() > 0; });
}

UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
const DerivedTypeSpec &derived) {
UltimateComponentIterator ultimates{derived};
return std::find_if(ultimates.begin(), ultimates.end(),
[](const Symbol *component) { return IsPointer(DEREF(component)); });
}

PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
const DerivedTypeSpec &derived) {
PotentialComponentIterator potentials{derived};
Expand Down
10 changes: 2 additions & 8 deletions flang/lib/semantics/tools.h
View file
Expand Up @@ -73,14 +73,6 @@ bool IsTeamType(const DerivedTypeSpec *);
// Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING
bool IsIsoCType(const DerivedTypeSpec *);
bool IsEventTypeOrLockType(const DerivedTypeSpec *);
// Returns an ultimate component symbol that is a
// coarray or nullptr if there are no such component.
// There is no guarantee regarding which ultimate coarray
// component is returned in case there are several because this
// does not really matter for the checks where it is needed.
const Symbol *HasCoarrayUltimateComponent(const DerivedTypeSpec &);
// Same logic as HasCoarrayUltimateComponent, but looking for
const Symbol *HasEventOrLockPotentialComponent(const DerivedTypeSpec &);
bool IsOrContainsEventOrLockComponent(const Symbol &);
// Has an explicit or implied SAVE attribute
bool IsSaved(const Symbol &);
Expand Down Expand Up @@ -369,5 +361,7 @@ PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
const DerivedTypeSpec &);
UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
const DerivedTypeSpec &);
UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
const DerivedTypeSpec &);
}
#endif // FORTRAN_SEMANTICS_TOOLS_H_
1 change: 1 addition & 0 deletions flang/test/semantics/CMakeLists.txt
View file
Expand Up @@ -163,6 +163,7 @@ set(ERROR_TESTS
blockconstruct02.f90
blockconstruct03.f90
call01.f90
call02.f90
)

# These test files have expected symbols in the source
Expand Down

0 comments on commit 9c3a937

Please sign in to comment.