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

[flang] Enable and pass test call07.f90 

Remove a std::move()

Final tweaks after testing and review

Original-commit: flang-compiler/f18@b3fe97b1a0
Reviewed-on: https://github.com/flang-compiler/f18/pull/806
This commit is contained in:
peter klausler 2019-11-01 13:08:16 -07:00
parent e91e7e4d95
commit c14c2b9573
15 changed files with 368 additions and 288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
flang/lib/common/indirection.h
View File

@ -33,7 +33,7 @@
namespace Fortran::common {
// The default case does not support (deep) copy construction and assignment.
// The default case does not support (deep) copy construction or assignment.
template<typename A, bool COPY = false> class Indirection {
public:
using element_type = A;

6
flang/lib/common/restorer.h
View File

@ -42,5 +42,11 @@ common::IfNoLvalue<Restorer<A>, B> ScopedSet(A &to, B &&from) {
to = std::move(from);
return result;
}
template<typename A, typename B>
common::IfNoLvalue<Restorer<A>, B> ScopedSet(A &to, const B &from) {
Restorer<A> result{to};
to = from;
return result;
}
}
#endif // FORTRAN_COMMON_RESTORER_H_

20
flang/lib/evaluate/characteristics.cc
View File

@ -218,9 +218,9 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
const semantics::Symbol &symbol) {
if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
if (auto type{TypeAndShape::Characterize(*obj)}) {
DummyDataObject result{*type};
std::optional<DummyDataObject> result{std::move(*type)};
using semantics::Attr;
CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, result,
CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
{
{Attr::OPTIONAL, DummyDataObject::Attr::Optional},
{Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable},
@ -232,15 +232,15 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
{Attr::TARGET, DummyDataObject::Attr::Target},
});
if (symbol.attrs().test(semantics::Attr::INTENT_IN)) {
result.intent = common::Intent::In;
result->intent = common::Intent::In;
}
if (symbol.attrs().test(semantics::Attr::INTENT_OUT)) {
CHECK(result.intent == common::Intent::Default);
result.intent = common::Intent::Out;
CHECK(result->intent == common::Intent::Default);
result->intent = common::Intent::Out;
}
if (symbol.attrs().test(semantics::Attr::INTENT_INOUT)) {
CHECK(result.intent == common::Intent::Default);
result.intent = common::Intent::InOut;
CHECK(result->intent == common::Intent::Default);
result->intent = common::Intent::InOut;
}
return result;
}
@ -316,6 +316,8 @@ std::ostream &DummyProcedure::Dump(std::ostream &o) const {
std::ostream &AlternateReturn::Dump(std::ostream &o) const { return o << '*'; }
DummyArgument::~DummyArgument() {}
bool DummyArgument::operator==(const DummyArgument &that) const {
return u == that.u;
}
@ -428,7 +430,7 @@ std::ostream &DummyArgument::Dump(std::ostream &o) const {
FunctionResult::FunctionResult(DynamicType t) : u{TypeAndShape{t}} {}
FunctionResult::FunctionResult(TypeAndShape &&t) : u{std::move(t)} {}
FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {}
FunctionResult::~FunctionResult() = default;
FunctionResult::~FunctionResult() {}
bool FunctionResult::operator==(const FunctionResult &that) const {
return attrs == that.attrs && u == that.u;
@ -519,7 +521,7 @@ Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
: functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {}
Procedure::Procedure(DummyArguments &&args, Attrs a)
: dummyArguments{std::move(args)}, attrs{a} {}
Procedure::~Procedure() = default;
Procedure::~Procedure() {}
bool Procedure::operator==(const Procedure &that) const {
return attrs == that.attrs && dummyArguments == that.dummyArguments &&

1
flang/lib/evaluate/characteristics.h
View File

@ -169,6 +169,7 @@ struct DummyArgument {
DummyArgument(std::string &&name, DummyProcedure &&x)
: name{std::move(name)}, u{std::move(x)} {}
explicit DummyArgument(AlternateReturn &&x) : u{std::move(x)} {}
~DummyArgument();
bool operator==(const DummyArgument &) const;
static std::optional<DummyArgument> Characterize(
const semantics::Symbol &, const IntrinsicProcTable &);

60
flang/lib/evaluate/tools.cc
View File

@ -676,24 +676,30 @@ bool IsNullPointer(const Expr<SomeType> &expr) {
return IsNullPointerHelper{}(expr);
}
// GetLastTarget()
auto GetLastTargetHelper::operator()(const Symbol &x) const -> Result {
if (x.attrs().HasAny({semantics::Attr::POINTER, semantics::Attr::TARGET})) {
return &x;
} else {
return nullptr;
}
// GetSymbolVector()
auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
return {x};
}
auto GetLastTargetHelper::operator()(const Component &x) const -> Result {
const Symbol &symbol{x.GetLastSymbol()};
if (symbol.attrs().HasAny(
{semantics::Attr::POINTER, semantics::Attr::TARGET})) {
return &symbol;
} else if (symbol.attrs().test(semantics::Attr::ALLOCATABLE)) {
return nullptr;
} else {
return std::nullopt;
}
auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
Result result{(*this)(x.base())};
result.emplace_back(x.GetLastSymbol());
return result;
}
auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
return GetSymbolVector(x.base());
}
auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {
return x.base();
}
const Symbol *GetLastTarget(const SymbolVector &symbols) {
auto end{std::crend(symbols)};
// N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.
auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {
return x.attrs().HasAny(
{semantics::Attr::POINTER, semantics::Attr::TARGET});
})};
return iter == end ? nullptr : &**iter;
}
const Symbol &ResolveAssociations(const Symbol &symbol) {
@ -737,4 +743,24 @@ struct HasVectorSubscriptHelper : public AnyTraverse<HasVectorSubscriptHelper> {
bool HasVectorSubscript(const Expr<SomeType> &expr) {
return HasVectorSubscriptHelper{}(expr);
}
parser::Message *AttachDeclaration(
parser::Message *message, const Symbol *symbol) {
if (message && symbol) {
const Symbol *unhosted{symbol};
while (
const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
unhosted = &assoc->symbol();
}
if (const auto *use{symbol->detailsIf<semantics::UseDetails>()}) {
message->Attach(use->location(),
"'%s' is USE-associated with '%s' in module '%s'"_en_US,
symbol->name(), unhosted->name(), use->module().name());
} else {
message->Attach(
unhosted->name(), "Declaration of '%s'"_en_US, symbol->name());
}
}
return message;
}
}

47
flang/lib/evaluate/tools.h
View File

@ -765,27 +765,34 @@ template<typename A> bool IsAllocatableOrPointer(const A &x) {
bool IsProcedurePointer(const Expr<SomeType> &);
bool IsNullPointer(const Expr<SomeType> &);
// GetLastTarget() returns the rightmost symbol in an object
// designator (which has perhaps been wrapped in an Expr<>) that has the
// POINTER or TARGET attribute, or a null pointer when none is found.
struct GetLastTargetHelper
: public AnyTraverse<GetLastTargetHelper, std::optional<const Symbol *>> {
using Result = std::optional<const Symbol *>;
using Base = AnyTraverse<GetLastTargetHelper, Result>;
GetLastTargetHelper() : Base{*this} {}
// Extracts the chain of symbols from a designator, which has perhaps been
// wrapped in an Expr<>, removing all of the (co)subscripts. The
// base object will be the first symbol in the result vector.
struct GetSymbolVectorHelper
: public Traverse<GetSymbolVectorHelper, SymbolVector> {
using Result = SymbolVector;
using Base = Traverse<GetSymbolVectorHelper, Result>;
using Base::operator();
GetSymbolVectorHelper() : Base{*this} {}
Result Default() { return {}; }
Result Combine(Result &&a, Result &&b) {
a.insert(a.end(), b.begin(), b.end());
return std::move(a);
}
Result operator()(const Symbol &) const;
Result operator()(const Component &) const;
Result operator()(const ArrayRef &) const;
Result operator()(const CoarrayRef &) const;
};
template<typename A> const Symbol *GetLastTarget(const A &x) {
if (auto known{GetLastTargetHelper{}(x)}) {
return *known;
} else {
return nullptr;
}
template<typename A> SymbolVector GetSymbolVector(const A &x) {
return GetSymbolVectorHelper{}(x);
}
// GetLastTarget() returns the rightmost symbol in an object designator's
// SymbolVector that has the POINTER or TARGET attribute, or a null pointer
// when none is found.
const Symbol *GetLastTarget(const SymbolVector &);
// Resolves any whole ASSOCIATE(B=>A) associations
const Symbol &ResolveAssociations(const Symbol &);
@ -798,5 +805,15 @@ extern template semantics::SymbolSet CollectSymbols(
// Predicate: does a variable contain a vector-valued subscript (not a triplet)?
bool HasVectorSubscript(const Expr<SomeType> &);
// Utilities for attaching the location of the declaration of a symbol
// of interest to a message, if both pointers are non-null. Handles
// the case of USE association gracefully.
parser::Message *AttachDeclaration(parser::Message *, const Symbol *);
template<typename... A>
parser::Message *SayWithDeclaration(
parser::ContextualMessages &messages, const Symbol *symbol, A &&... x) {
return AttachDeclaration(messages.Say(std::forward<A>(x)...), symbol);
}
}
#endif // FORTRAN_EVALUATE_TOOLS_H_

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

@ -38,8 +38,6 @@
// expression leaf nodes. They invoke the visitor's operator() for the
// subtrees of interior nodes, and the visitor's Combine() to merge their
// results together.
// - The default operator() inherited into each visitor just reflects right
// back into Traverse<> to descend into subtrees.
// - Overloads of operator() in each visitor handle the cases of interest.
#include "expression.h"

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

@ -17,6 +17,7 @@
#include "symbol.h"
#include "tools.h"
#include "../common/idioms.h"
#include "../common/restorer.h"
#include "../evaluate/characteristics.h"
#include "../evaluate/expression.h"
#include "../evaluate/fold.h"
@ -26,197 +27,198 @@
#include "../parser/parse-tree.h"
#include <optional>
#include <set>
#include <string>
#include <type_traits>
using namespace Fortran::parser::literals;
namespace Fortran::evaluate {
template<typename A>
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &, const Symbol &symbol, const A &) {
// Default catch-all when RHS of pointer assignment isn't recognized
messages.Say("Pointer target assigned to '%s' must be a designator or "
"a call to a pointer-valued function"_err_en_US,
symbol.name());
}
class PointerAssignmentChecker {
public:
PointerAssignmentChecker(const Symbol *pointer, parser::CharBlock source,
const std::string &description, const characteristics::TypeAndShape *type,
parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics,
const std::optional<characteristics::Procedure> &procedure,
bool isContiguous)
: pointer_{pointer}, source_{source}, description_{description},
type_{type}, messages_{messages}, intrinsics_{intrinsics},
procedure_{procedure}, isContiguous_{isContiguous} {}
void CheckPointerAssignment(parser::ContextualMessages &,
const IntrinsicProcTable &, const Symbol &, const NullPointer &) {
// LHS = NULL() without MOLD=; this is always fine
}
template<typename T>
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, const Symbol &lhs,
const FunctionRef<T> &f) {
const Symbol *ultimate{nullptr};
std::string funcName;
if (const auto *symbol{f.proc().GetSymbol()}) {
funcName = symbol->name().ToString();
ultimate = &symbol->GetUltimate();
} else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
funcName = intrinsic->name;
template<typename A> void Check(const A &) {
// Catch-all case for really bad target expression
Say("Target associated with %s must be a designator or a call to a pointer-valued function"_err_en_US,
description_);
}
if (auto proc{
characteristics::Procedure::Characterize(f.proc(), intrinsics)}) {
std::optional<parser::MessageFixedText> error;
if (const auto &funcResult{proc->functionResult}) {
const auto *frProc{funcResult->IsProcedurePointer()};
if (IsProcedurePointer(lhs)) {
// Shouldn't be here in this function unless lhs
// is an object pointer.
error = "Procedure pointer '%s' was assigned the result of "
"a reference to function '%s' that does not return a "
"procedure pointer"_err_en_US;
} else if (frProc != nullptr) {
error = "Object pointer '%s' was assigned the result of a "
"reference to function '%s' that is a procedure "
"pointer"_err_en_US;
} else if (!funcResult->attrs.test(
characteristics::FunctionResult::Attr::Pointer)) {
error = "Pointer '%s' was assigned the result of a "
"reference to function '%s' that is a not a "
"pointer"_err_en_US;
} else if (lhs.attrs().test(semantics::Attr::CONTIGUOUS) &&
!funcResult->attrs.test(
characteristics::FunctionResult::Attr::Contiguous)) {
error = "Contiguous pointer '%s' was assigned the result of "
"reference to function '%s' that is not "
"contiguous"_err_en_US;
} else if (auto lhsTypeAndShape{
characteristics::TypeAndShape::Characterize(lhs)}) {
const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
CHECK(frTypeAndShape != nullptr);
if (!lhsTypeAndShape->IsCompatibleWith(messages, *frTypeAndShape)) {
error = "Pointer '%s' was assigned the result of a reference to "
"function '%s' whose pointer result has an "
"incompatible type or shape"_err_en_US;
template<typename T> void Check(const Expr<T> &x) {
std::visit([&](const auto &x) { Check(x); }, x.u);
}
void Check(const Expr<SomeType> &);
void Check(const NullPointer &) {} // P => NULL() without MOLD=; always OK
template<typename T> void Check(const FunctionRef<T> &f) {
std::string funcName;
const auto *symbol{f.proc().GetSymbol()};
if (symbol) {
funcName = symbol->name().ToString();
} else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
funcName = intrinsic->name;
}
if (auto proc{
characteristics::Procedure::Characterize(f.proc(), intrinsics_)}) {
std::optional<parser::MessageFixedText> error;
if (const auto &funcResult{proc->functionResult}) { // C1025
const auto *frProc{funcResult->IsProcedurePointer()};
if (procedure_.has_value()) {
// Shouldn't be here in this function unless lhs
// is an object pointer.
error =
"Procedure %s is associated with the result of a reference to function '%s' that does not return a procedure pointer"_err_en_US;
} else if (frProc != nullptr) {
error =
"Object %s is associated with the result of a reference to function '%s' that is a procedure pointer"_err_en_US;
} else if (!funcResult->attrs.test(
characteristics::FunctionResult::Attr::Pointer)) {
error =
"%s is associated with the result of a reference to function '%s' that is a not a pointer"_err_en_US;
} else if (isContiguous_ &&
!funcResult->attrs.test(
characteristics::FunctionResult::Attr::Contiguous)) {
error =
"CONTIGUOUS %s is associated with the result of reference to function '%s' that is not contiguous"_err_en_US;
} else if (type_) {
const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
CHECK(frTypeAndShape != nullptr);
if (!type_->IsCompatibleWith(messages_, *frTypeAndShape)) {
error =
"%s is associated with the result of a reference to function '%s' whose pointer result has an incompatible type or shape"_err_en_US;
}
}
} else {
error =
"%s is associated with the non-existent result of reference to procedure"_err_en_US;
}
if (error.has_value()) {
auto save{common::ScopedSet(pointer_, symbol)};
Say(*error, description_, funcName);
}
}
}
template<typename T> void Check(const Designator<T> &d) {
const Symbol *last{d.GetLastSymbol()};
const Symbol *base{d.GetBaseObject().symbol()};
if (last != nullptr && base != nullptr) {
std::optional<parser::MessageFixedText> error;
if (procedure_.has_value()) {
// Shouldn't be here in this function unless lhs is an
// object pointer.
error =
"In assignment to procedure %s, the target is not a procedure or procedure pointer"_err_en_US;
} else if (GetLastTarget(GetSymbolVector(d)) == nullptr) { // C1025
error =
"In assignment to object %s, the target '%s' is not an object with POINTER or TARGET attributes"_err_en_US;
} else if (auto rhsTypeAndShape{
characteristics::TypeAndShape::Characterize(*last)}) {
if (!type_ || !type_->IsCompatibleWith(messages_, *rhsTypeAndShape)) {
error =
"%s associated with object '%s' with incompatible type or shape"_err_en_US;
}
}
if (error.has_value()) {
auto save{common::ScopedSet(pointer_, last)};
Say(*error, description_, last->name());
}
} else {
error = "Pointer was assigned the non-existent "
"result of reference to procedure"_err_en_US;
}
if (error.has_value()) {
if (auto *msg{messages.Say(*error, lhs.name(), funcName)}) {
msg->Attach(lhs.name(), "Declaration of pointer"_en_US);
if (ultimate != nullptr) {
msg->Attach(ultimate->name(), "Declaration of function"_en_US);
}
}
// P => "character literal"(1:3)
messages_.Say("Pointer target is not a named entity"_err_en_US);
}
}
}
template<typename T>
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &, const Symbol &lhs, const Designator<T> &d) {
const Symbol *last{d.GetLastSymbol()};
const Symbol *base{d.GetBaseObject().symbol()};
if (last != nullptr && base != nullptr) {
std::optional<parser::MessageFixedText> error;
if (IsProcedurePointer(lhs)) {
// Shouldn't be here in this function unless lhs is an
// object pointer.
error = "In assignment to procedure pointer '%s', the "
"target is not a procedure or procedure pointer"_err_en_US;
} else if (GetLastTarget(d) == nullptr) {
error = "In assignment to object pointer '%s', the target '%s' "
"is not an object with POINTER or TARGET attributes"_err_en_US;
} else if (auto rhsTypeAndShape{
characteristics::TypeAndShape::Characterize(last)}) {
if (auto lhsTypeAndShape{
characteristics::TypeAndShape::Characterize(lhs)}) {
if (!lhsTypeAndShape->IsCompatibleWith(messages, *rhsTypeAndShape)) {
error = "Pointer '%s' assigned to object '%s' with "
"incompatible type or shape"_err_en_US;
}
}
}
if (error.has_value()) {
if (auto *msg{messages.Say(*error, lhs.name(), last->name())}) {
msg->Attach(lhs.name(), "Declaration of pointer being assigned"_en_US)
.Attach(last->name(), "Declaration of pointer target"_en_US);
}
void Check(const ProcedureDesignator &);
void Check(const ProcedureRef &);
private:
// Target is a procedure
void Check(parser::CharBlock rhsName, bool isCall,
const characteristics::Procedure * = nullptr);
template<typename... A> parser::Message *Say(A &&... x) {
auto *msg{messages_.Say(std::forward<A>(x)...)};
if (pointer_) {
return AttachDeclaration(msg, pointer_);
} else if (!source_.empty()) {
msg->Attach(source_, "Declaration of %s"_en_US, description_);
}
return msg;
}
const Symbol *pointer_{nullptr};
const parser::CharBlock source_;
const std::string &description_;
const characteristics::TypeAndShape *type_{nullptr};
parser::ContextualMessages &messages_;
const IntrinsicProcTable &intrinsics_;
const std::optional<characteristics::Procedure> &procedure_;
bool isContiguous_{false};
};
void PointerAssignmentChecker::Check(const Expr<SomeType> &rhs) {
if (HasVectorSubscript(rhs)) { // C1025
Say("An array section with a vector subscript may not be a pointer target"_err_en_US);
} else if (ExtractCoarrayRef(rhs)) { // C1026
Say("A coindexed object may not be a pointer target"_err_en_US);
} else {
// P => "character literal"(1:3)
messages.Say("Pointer target is not a named entity"_err_en_US);
std::visit([&](const auto &x) { Check(x); }, rhs.u);
}
}
// Common handling for procedure pointer right-hand sides
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, const Symbol &lhs,
parser::CharBlock rhsName, bool isCall,
std::optional<characteristics::Procedure> &&targetChars) {
std::optional<parser::MessageFixedText> error;
if (IsProcedurePointer(lhs)) {
if (auto ptrProc{
characteristics::Procedure::Characterize(lhs, intrinsics)}) {
if (targetChars.has_value()) {
if (!(*ptrProc == *targetChars)) {
if (isCall) {
error = "Procedure pointer '%s' assigned with result of "
"reference to function '%s' that is an incompatible "
"procedure pointer"_err_en_US;
} else {
error = "Procedure pointer '%s' assigned to incompatible "
"procedure designator '%s'"_err_en_US;
}
void PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
const characteristics::Procedure *targetChars) {
if (procedure_.has_value()) {
if (targetChars != nullptr) {
if (!(*procedure_ == *targetChars)) {
if (isCall) {
Say("Procedure %s associated with result of reference to function '%s' that is an incompatible procedure pointer"_err_en_US,
description_, rhsName);
} else {
Say("Procedure %s associated with incompatible procedure designator '%s'"_err_en_US,
description_, rhsName);
}
} else {
error = "In assignment to procedure pointer '%s', the "
"characteristics of the target procedure '%s' could "
"not be determined"_err_en_US;
}
} else {
error = "In assignment to procedure pointer '%s', its "
"characteristics could not be determined"_err_en_US;
Say("In assignment to procedure %s, the characteristics of the target procedure '%s' could not be determined"_err_en_US,
description_, rhsName);
}
} else {
error = "In assignment to object pointer '%s', the target '%s' "
"is a procedure designator"_err_en_US;
}
if (error.has_value()) {
if (auto *msg{messages.Say(*error, lhs.name(), rhsName)}) {
msg->Attach(lhs.name(), "Declaration of pointer being assigned"_en_US);
}
Say("In assignment to object %s, the target '%s' is a procedure designator"_err_en_US,
description_, rhsName);
}
}
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, const Symbol &lhs,
const ProcedureDesignator &d) {
CheckPointerAssignment(messages, intrinsics, lhs, d.GetName(), false,
characteristics::Procedure::Characterize(d, intrinsics));
void PointerAssignmentChecker::Check(const ProcedureDesignator &d) {
if (auto chars{characteristics::Procedure::Characterize(d, intrinsics_)}) {
Check(d.GetName(), false, &*chars);
} else {
Check(d.GetName(), false);
}
}
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, const Symbol &lhs,
const ProcedureRef &ref) {
auto chars{characteristics::Procedure::Characterize(ref, intrinsics)};
void PointerAssignmentChecker::Check(const ProcedureRef &ref) {
const characteristics::Procedure *procedure{nullptr};
auto chars{characteristics::Procedure::Characterize(ref, intrinsics_)};
if (chars.has_value()) {
procedure = &*chars;
if (chars->functionResult.has_value()) {
if (const auto *proc{chars->functionResult->IsProcedurePointer()}) {
characteristics::Procedure rChars{std::move(*proc)};
chars = std::move(rChars);
procedure = proc;
}
}
}
CheckPointerAssignment(
messages, intrinsics, lhs, ref.proc().GetName(), true, std::move(chars));
}
template<typename T>
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, const Symbol &lhs, const Expr<T> &x) {
std::visit(
[&](const auto &x) {
CheckPointerAssignment(messages, intrinsics, lhs, x);
},
x.u);
Check(ref.proc().GetName(), true, procedure);
}
void CheckPointerAssignment(parser::ContextualMessages &messages,
@ -224,12 +226,29 @@ void CheckPointerAssignment(parser::ContextualMessages &messages,
const evaluate::Expr<evaluate::SomeType> &rhs) {
// TODO: Acquire values of deferred type parameters &/or array bounds
// from the RHS.
const Symbol &ultimate{lhs.GetUltimate()};
std::visit(
[&](const auto &x) {
CheckPointerAssignment(messages, intrinsics, ultimate, x);
},
rhs.u);
if (!IsPointer(lhs)) {
SayWithDeclaration(
messages, &lhs, "'%s' is not a pointer"_err_en_US, lhs.name());
} else {
auto type{characteristics::TypeAndShape::Characterize(lhs)};
auto proc{characteristics::Procedure::Characterize(lhs, intrinsics)};
std::string description{"pointer '"s + lhs.name().ToString() + '\''};
PointerAssignmentChecker{&lhs, lhs.name(), description,
type ? &*type : nullptr, messages, intrinsics, proc,
lhs.attrs().test(semantics::Attr::CONTIGUOUS)}
.Check(rhs);
}
}
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, parser::CharBlock source,
const std::string &description, const characteristics::DummyDataObject &lhs,
const evaluate::Expr<evaluate::SomeType> &rhs) {
std::optional<characteristics::Procedure> proc;
PointerAssignmentChecker{nullptr, source, description, &lhs.type, messages,
intrinsics, proc,
lhs.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}
.Check(rhs);
}
}
@ -334,10 +353,6 @@ private:
ForallContext *forall_{nullptr};
};
} // namespace Fortran::semantics
namespace Fortran::semantics {
void AssignmentContext::Analyze(const parser::AssignmentStmt &) {
if (forall_ != nullptr) {
// TODO: Warn if some name in forall_->activeNames or its outer

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

@ -18,6 +18,7 @@
#include "semantics.h"
#include "../common/indirection.h"
#include "../evaluate/expression.h"
#include <string>
namespace Fortran::parser {
template<typename> struct Statement;
@ -32,11 +33,18 @@ struct ForallStmt;
struct ForallConstruct;
}
namespace Fortran::evaluate::characteristics {
struct DummyDataObject;
}
namespace Fortran::evaluate {
class IntrinsicProcTable;
void CheckPointerAssignment(parser::ContextualMessages &,
const IntrinsicProcTable &, const Symbol &lhs,
const evaluate::Expr<evaluate::SomeType> &rhs);
const IntrinsicProcTable &, const Symbol &lhs, const Expr<SomeType> &rhs);
void CheckPointerAssignment(parser::ContextualMessages &,
const IntrinsicProcTable &, parser::CharBlock source,
const std::string &description, const characteristics::DummyDataObject &,
const Expr<SomeType> &rhs);
}
namespace Fortran::semantics {

71
flang/lib/semantics/check-call.cc
View File

@ -13,9 +13,11 @@
// limitations under the License.
#include "check-call.h"
#include "assignment.h"
#include "scope.h"
#include "tools.h"
#include "../evaluate/characteristics.h"
#include "../evaluate/check-expression.h"
#include "../evaluate/shape.h"
#include "../evaluate/tools.h"
#include "../parser/characters.h"
@ -168,22 +170,17 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
tbp{FindImmediateComponent(derived, [](const Symbol &symbol) {
return symbol.has<ProcBindingDetails>();
})}) { // 15.5.2.4(2)
if (auto *msg{messages.Say(
"Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
dummyName, tbp->name())}) {
msg->Attach(tbp->name(), "Declaration of type-bound procedure"_en_US);
}
evaluate::SayWithDeclaration(messages, tbp,
"Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
dummyName, tbp->name());
}
if (const Symbol *
finalizer{FindImmediateComponent(derived, [](const Symbol &symbol) {
return symbol.has<FinalProcDetails>();
})}) { // 15.5.2.4(2)
if (auto *msg{messages.Say(
"Actual argument associated with TYPE(*) %s may not have FINAL subroutine '%s'"_err_en_US,
dummyName, finalizer->name())}) {
msg->Attach(
finalizer->name(), "Declaration of FINAL subroutine"_en_US);
}
evaluate::SayWithDeclaration(messages, finalizer,
"Actual argument associated with TYPE(*) %s may not have FINAL subroutine '%s'"_err_en_US,
dummyName, finalizer->name());
}
}
UltimateComponentIterator ultimates{derived};
@ -193,12 +190,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
ultimates.begin(), ultimates.end(), [](const Symbol &component) {
return IsAllocatable(component);
})}) { // 15.5.2.4(6)
if (auto *msg{messages.Say(
"Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
iter.BuildResultDesignatorName(), dummyName)}) {
msg->Attach(
iter->name(), "Declaration of ALLOCATABLE component"_en_US);
}
evaluate::SayWithDeclaration(messages, &*iter,
"Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
iter.BuildResultDesignatorName(), dummyName);
}
}
if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
@ -207,11 +201,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
const auto *object{component.detailsIf<ObjectEntityDetails>()};
return object && object->IsCoarray();
})}) {
if (auto *msg{messages.Say(
"VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
dummyName, iter.BuildResultDesignatorName())}) {
msg->Attach(iter->name(), "Declaration of coarray component"_en_US);
}
evaluate::SayWithDeclaration(messages, &*iter,
"VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
dummyName, iter.BuildResultDesignatorName());
}
}
}
@ -235,12 +227,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummyName);
}
if (actualIsAssumedSize) {
if (auto *msg{messages.Say(
"Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
dummyName)}) {
msg->Attach(actualLastSymbol->name(),
"Declaration of assumed-size array actual argument"_en_US);
}
evaluate::SayWithDeclaration(messages, actualLastSymbol,
"Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
dummyName);
}
} else if (actualRank == 0 && dummy.type.Rank() > 0) {
// Actual is scalar, dummy is an array. 15.5.2.4(14), 15.5.2.11
@ -306,6 +295,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// Cases when temporaries might be needed but must not be permitted.
bool dummyIsPointer{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
bool dummyIsContiguous{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
bool actualIsContiguous{IsSimplyContiguous(actual, context.intrinsics())};
if ((actualIsAsynchronous || actualIsVolatile) &&
(dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
if (actualIsCoindexed) { // C1538
@ -313,9 +305,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
"Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
dummyName);
}
if (actualRank > 0 && !IsSimplyContiguous(actual, context.intrinsics())) {
bool dummyIsContiguous{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
if (actualRank > 0 && !actualIsContiguous) {
bool dummyIsAssumedRank{dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank)};
bool dummyIsAssumedShape{dummy.type.attrs().test(
@ -355,6 +345,25 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
}
}
// 15.5.2.7 -- dummy is POINTER
if (dummyIsPointer) {
if (dummyIsContiguous && !actualIsContiguous) {
messages.Say(
"Actual argument associated with CONTIGUOUS POINTER %s must be simply contiguous"_err_en_US,
dummyName);
}
if (!actualIsPointer) {
if (dummy.intent == common::Intent::In) {
CheckPointerAssignment(messages, context.intrinsics(),
parser::CharBlock{}, dummyName, dummy, actual);
} else {
messages.Say(
"Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
dummyName);
}
}
}
// 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE
if ((actualIsPointer && dummyIsPointer) ||
(actualIsAllocatable && dummyIsAllocatable)) {

6
flang/lib/semantics/check-declarations.cc
View File

@ -138,7 +138,7 @@ void CheckHelper::Check(const Symbol &symbol) {
"An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
}
if (const Symbol * result{FindFunctionResult(symbol)}) {
if (result->attrs().test(Attr::POINTER)) {
if (IsPointer(*result)) {
messages_.Say(
"An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
}
@ -176,6 +176,10 @@ void CheckHelper::Check(const Symbol &symbol) {
if (symbol.attrs().test(Attr::VALUE)) {
CheckValue(symbol, derived);
}
if (symbol.attrs().test(Attr::CONTIGUOUS) && IsPointer(symbol) &&
symbol.Rank() == 0) { // C830
messages_.Say("CONTIGUOUS POINTER must be an array"_err_en_US);
}
}
void CheckHelper::CheckValue(

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

@ -1257,13 +1257,11 @@ MaybeExpr ExpressionAnalyzer::Analyze(
const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};
if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796
if (auto *msg{Say(typeName,
"ABSTRACT derived type '%s' may not be used in a "
"structure constructor"_err_en_US,
typeName)}) {
msg->Attach(
typeSymbol.name(), "Declaration of ABSTRACT derived type"_en_US);
}
AttachDeclaration(Say(typeName,
"ABSTRACT derived type '%s' may not be used in a "
"structure constructor"_err_en_US,
typeName),
&typeSymbol);
}
// This iterator traverses all of the components in the derived type and its
@ -1419,20 +1417,20 @@ MaybeExpr ExpressionAnalyzer::Analyze(
// NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE
} else if (auto symType{DynamicType::From(symbol)}) {
if (valueType.has_value()) {
if (auto *msg{Say(expr.source,
AttachDeclaration(
Say(expr.source,
"Value in structure constructor of type %s is "
"incompatible with component '%s' of type %s"_err_en_US,
valueType->AsFortran(), symbol->name(),
symType->AsFortran())}) {
msg->Attach(symbol->name(), "Component declaration"_en_US);
}
symType->AsFortran()),
symbol);
} else {
if (auto *msg{Say(expr.source,
AttachDeclaration(
Say(expr.source,
"Value in structure constructor is incompatible with "
" component '%s' of type %s"_err_en_US,
symbol->name(), symType->AsFortran())}) {
msg->Attach(symbol->name(), "Component declaration"_en_US);
}
symbol->name(), symType->AsFortran()),
symbol);
}
}
}
@ -1449,12 +1447,11 @@ MaybeExpr ExpressionAnalyzer::Analyze(
if (details->init().has_value()) {
result.Add(symbol, common::Clone(*details->init()));
} else { // C799
if (auto *msg{Say(typeName,
"Structure constructor lacks a value for "
"component '%s'"_err_en_US,
symbol.name())}) {
msg->Attach(symbol.name(), "Absent component"_en_US);
}
AttachDeclaration(Say(typeName,
"Structure constructor lacks a value for "
"component '%s'"_err_en_US,
symbol.name()),
&symbol);
}
}
}
@ -1676,9 +1673,7 @@ void ExpressionAnalyzer::CheckForBadRecursion(
"Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,
callSite);
}
if (msg != nullptr) {
msg->Attach(proc.name(), "definition of '%s'"_en_US, callSite);
}
AttachDeclaration(msg, &proc);
}
}
}
@ -2076,8 +2071,7 @@ static void CheckFuncRefToArrayElementRefHasSubscripts(
"A result variable must be declared with RESULT to allow recursive "
"function calls"_en_US);
} else {
msg.Attach(
name->symbol->name(), "'%s' was declared here"_en_US, name->source);
AttachDeclaration(&msg, name->symbol);
}
}
}
@ -2422,13 +2416,11 @@ std::optional<ActualArgument> ArgumentAnalyzer::Analyze(
if (const semantics::DeclTypeSpec * type{coarray.GetType()}) {
if (const semantics::DerivedTypeSpec * derived{type->AsDerived()}) {
if (auto ptr{semantics::FindPointerUltimateComponent(*derived)}) {
if (auto *msg{context_.Say(expr.source,
AttachDeclaration(
context_.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());
}
coarray.name(), ptr->name()),
&*ptr);
}
}
}

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

@ -178,6 +178,7 @@ set(ERROR_TESTS
call04.f90
call05.f90
call06.f90
call07.f90
call13.f90
call14.f90
misc-declarations.f90

19
flang/test/semantics/call07.f90
View File

@ -15,6 +15,7 @@
! Test 15.5.2.7 constraints and restrictions for POINTER dummy arguments.
module m
real :: coarray(10)[*]
contains
subroutine s01(p)
@ -28,27 +29,27 @@ module m
end subroutine
subroutine test
!ERROR: CONTIGUOUS pointer must be an array
!ERROR: CONTIGUOUS POINTER must be an array
real, pointer, contiguous :: a01 ! C830
real, pointer :: a02(:)
real, target :: a03(10)
real :: a04(10) ! not TARGET
call s01(a03) ! ok
!ERROR: Effective argument associated with CONTIGUOUS POINTER dummy argument must be simply contiguous
!ERROR: Actual argument associated with CONTIGUOUS POINTER dummy argument 'p=' must be simply contiguous
call s01(a02)
!ERROR: Effective argument associated with CONTIGUOUS POINTER dummy argument must be simply contiguous
!ERROR: Actual argument associated with CONTIGUOUS POINTER dummy argument 'p=' must be simply contiguous
call s01(a03(::2))
!ERROR: Effective argument associated with CONTIGUOUS POINTER dummy argument must be simply contiguous
call s01(a03([1,2,4]))
call s02(a02) ! ok
call s03(a03) ! ok
!ERROR: Effective argument associated with POINTER dummy argument must be POINTER unless INTENT(IN)
!ERROR: Actual argument associated with POINTER dummy argument 'p=' must also be POINTER unless INTENT(IN)
call s02(a03)
!ERROR: Effective argument associated with POINTER INTENT(IN) dummy argument must be a valid target if not a POINTER
!ERROR: An array section with a vector subscript may not be a pointer target
call s03(a03([1,2,4]))
!ERROR: Effective argument associated with POINTER INTENT(IN) dummy argument must be a valid target if not a POINTER
!ERROR: A coindexed object may not be a pointer target
call s03(coarray(:)[1])
!ERROR: Target associated with dummy argument 'p=' must be a designator or a call to a pointer-valued function
call s03([1.])
!ERROR: Effective argument associated with POINTER INTENT(IN) dummy argument must be a valid target if not a POINTER
!ERROR: In assignment to object dummy argument 'p=', the target 'a04' is not an object with POINTER or TARGET attributes
call s03(a04)
end subroutine
end module

8
flang/test/semantics/null01.f90
View File

@ -75,16 +75,16 @@ subroutine test
dt0x = dt0(ip0=null(ip0))
dt0x = dt0(ip0=null(mold=ip0))
!ERROR: TARGET type 'Real(4)' is not compatible with POINTER type 'Integer(4)'
!ERROR: Pointer 'ip0' was assigned the result of a reference to function 'null' whose pointer result has an incompatible type or shape
!ERROR: pointer 'ip0' is associated with the result of a reference to function 'null' whose pointer result has an incompatible type or shape
dt0x = dt0(ip0=null(mold=rp0))
!ERROR: TARGET type 'Real(4)' is not compatible with POINTER type 'Integer(4)'
!ERROR: Pointer 'ip1' was assigned the result of a reference to function 'null' whose pointer result has an incompatible type or shape
!ERROR: pointer 'ip1' is associated with the result of a reference to function 'null' whose pointer result has an incompatible type or shape
dt1x = dt1(ip1=null(mold=rp1))
dt2x = dt2(pps0=null())
dt2x = dt2(pps0=null(mold=dt2x%pps0))
!ERROR: Procedure pointer 'pps0' assigned with result of reference to function 'null' that is an incompatible procedure pointer
!ERROR: Procedure pointer 'pps0' associated with result of reference to function 'null' that is an incompatible procedure pointer
dt2x = dt2(pps0=null(mold=dt3x%pps1))
!ERROR: Procedure pointer 'pps1' assigned with result of reference to function 'null' that is an incompatible procedure pointer
!ERROR: Procedure pointer 'pps1' associated with result of reference to function 'null' that is an incompatible procedure pointer
dt3x = dt3(pps1=null(mold=dt2x%pps0))
dt3x = dt3(pps1=null(mold=dt3x%pps1))
end subroutine test