caio/clang-p2996
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[flang] Check procedure pointer initializations; clean up ELEMENTAL

Browse Source 
Implements compatibility checking for initializers in procedure pointer
declarations.  This work exposed some inconsistency in how ELEMENTAL
interfaces were handled and checked, from both unrestricted intrinsic
functions and others, and some refinements needed for function result
compatbility checking; these have also been ironed out.  Some new
warnings are now emitted, and this affected a dozen or so tests.

Differential Revision: https://reviews.llvm.org/D159026
This commit is contained in:
Peter Klausler
2023-08-11 14:29:44 -07:00
parent 4c62e943b7
commit 0c0b2ea988
26 changed files with 407 additions and 257 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
flang/include/flang/Evaluate/characteristics.h
View File

@@ -81,23 +81,24 @@ public:
bool operator!=(const TypeAndShape &that) const { return !(*this == that); }
static std::optional<TypeAndShape> Characterize(
const semantics::Symbol &, FoldingContext &);
const semantics::Symbol &, FoldingContext &, bool invariantOnly = false);
static std::optional<TypeAndShape> Characterize(
const semantics::DeclTypeSpec &, FoldingContext &);
const semantics::DeclTypeSpec &, FoldingContext &,
bool invariantOnly = false);
static std::optional<TypeAndShape> Characterize(
const ActualArgument &, FoldingContext &);
const ActualArgument &, FoldingContext &, bool invariantOnly = false);
// General case for Expr<T>, ActualArgument, &c.
template <typename A>
static std::optional<TypeAndShape> Characterize(
const A &x, FoldingContext &context) {
const A &x, FoldingContext &context, bool invariantOnly = false) {
if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) {
if (auto result{Characterize(*symbol, context)}) {
if (auto result{Characterize(*symbol, context, invariantOnly)}) {
return result;
}
}
if (auto type{x.GetType()}) {
TypeAndShape result{*type, GetShape(context, x)};
TypeAndShape result{*type, GetShape(context, x, invariantOnly)};
if (type->category() == TypeCategory::Character) {
if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
if (auto length{chExpr->LEN()}) {
@@ -114,14 +115,14 @@ public:
template <int KIND>
static std::optional<TypeAndShape> Characterize(
const Designator<Type<TypeCategory::Character, KIND>> &x,
FoldingContext &context) {
FoldingContext &context, bool invariantOnly = true) {
if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) {
if (auto result{Characterize(*symbol, context)}) {
if (auto result{Characterize(*symbol, context, invariantOnly)}) {
return result;
}
}
if (auto type{x.GetType()}) {
TypeAndShape result{*type, GetShape(context, x)};
TypeAndShape result{*type, GetShape(context, x, invariantOnly)};
if (auto length{x.LEN()}) {
result.set_LEN(std::move(*length));
}
@@ -131,19 +132,19 @@ public:
}
template <typename A>
static std::optional<TypeAndShape> Characterize(
const std::optional<A> &x, FoldingContext &context) {
static std::optional<TypeAndShape> Characterize(const std::optional<A> &x,
FoldingContext &context, bool invariantOnly = false) {
if (x) {
return Characterize(*x, context);
return Characterize(*x, context, invariantOnly);
} else {
return std::nullopt;
}
}
template <typename A>
static std::optional<TypeAndShape> Characterize(
A *ptr, FoldingContext &context) {
A *ptr, FoldingContext &context, bool invariantOnly = false) {
if (ptr) {
return Characterize(std::as_const(*ptr), context);
return Characterize(std::as_const(*ptr), context, invariantOnly);
} else {
return std::nullopt;
}
@@ -181,7 +182,8 @@ public:
private:
static std::optional<TypeAndShape> Characterize(
const semantics::AssocEntityDetails &, FoldingContext &);
const semantics::AssocEntityDetails &, FoldingContext &,
bool invariantOnly = true);
static std::optional<TypeAndShape> Characterize(
const semantics::ProcEntityDetails &, FoldingContext &);
void AcquireAttrs(const semantics::Symbol &);

100
flang/include/flang/Evaluate/shape.h
View File

@@ -54,9 +54,14 @@ inline int GetRank(const Shape &s) { return static_cast<int>(s.size()); }
Shape Fold(FoldingContext &, Shape &&);
std::optional<Shape> Fold(FoldingContext &, std::optional<Shape> &&);
// Computes shapes in terms of expressions that are scope-invariant, by
// default, which is nearly always what one wants outside of procedure
// characterization.
template <typename A>
std::optional<Shape> GetShape(FoldingContext &, const A &);
template <typename A> std::optional<Shape> GetShape(const A &);
std::optional<Shape> GetShape(
FoldingContext &, const A &, bool invariantOnly = true);
template <typename A>
std::optional<Shape> GetShape(const A &, bool invariantOnly = true);
// The dimension argument to these inquiries is zero-based,
// unlike the DIM= arguments to many intrinsics.
@@ -68,31 +73,42 @@ template <typename A> std::optional<Shape> GetShape(const A &);
// in those circumstances.
// Similarly, GetUBOUND result will be forced to 0 on an empty dimension,
// but will fail if the extent is not a compile time constant.
ExtentExpr GetRawLowerBound(const NamedEntity &, int dimension);
ExtentExpr GetRawLowerBound(
FoldingContext &, const NamedEntity &, int dimension);
MaybeExtentExpr GetLBOUND(const NamedEntity &, int dimension);
MaybeExtentExpr GetLBOUND(FoldingContext &, const NamedEntity &, int dimension);
MaybeExtentExpr GetRawUpperBound(const NamedEntity &, int dimension);
const NamedEntity &, int dimension, bool invariantOnly = true);
ExtentExpr GetRawLowerBound(FoldingContext &, const NamedEntity &,
int dimension, bool invariantOnly = true);
MaybeExtentExpr GetLBOUND(
const NamedEntity &, int dimension, bool invariantOnly = true);
MaybeExtentExpr GetLBOUND(FoldingContext &, const NamedEntity &, int dimension,
bool invariantOnly = true);
MaybeExtentExpr GetRawUpperBound(
FoldingContext &, const NamedEntity &, int dimension);
MaybeExtentExpr GetUBOUND(const NamedEntity &, int dimension);
MaybeExtentExpr GetUBOUND(FoldingContext &, const NamedEntity &, int dimension);
const NamedEntity &, int dimension, bool invariantOnly = true);
MaybeExtentExpr GetRawUpperBound(FoldingContext &, const NamedEntity &,
int dimension, bool invariantOnly = true);
MaybeExtentExpr GetUBOUND(
const NamedEntity &, int dimension, bool invariantOnly = true);
MaybeExtentExpr GetUBOUND(FoldingContext &, const NamedEntity &, int dimension,
bool invariantOnly = true);
MaybeExtentExpr ComputeUpperBound(ExtentExpr &&lower, MaybeExtentExpr &&extent);
MaybeExtentExpr ComputeUpperBound(
FoldingContext &, ExtentExpr &&lower, MaybeExtentExpr &&extent);
Shape GetRawLowerBounds(const NamedEntity &);
Shape GetRawLowerBounds(FoldingContext &, const NamedEntity &);
Shape GetLBOUNDs(const NamedEntity &);
Shape GetLBOUNDs(FoldingContext &, const NamedEntity &);
Shape GetUBOUNDs(const NamedEntity &);
Shape GetUBOUNDs(FoldingContext &, const NamedEntity &);
MaybeExtentExpr GetExtent(const NamedEntity &, int dimension);
MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension);
Shape GetRawLowerBounds(const NamedEntity &, bool invariantOnly = true);
Shape GetRawLowerBounds(
FoldingContext &, const NamedEntity &, bool invariantOnly = true);
Shape GetLBOUNDs(const NamedEntity &, bool invariantOnly = true);
Shape GetLBOUNDs(
FoldingContext &, const NamedEntity &, bool invariantOnly = true);
Shape GetUBOUNDs(const NamedEntity &, bool invariantOnly = true);
Shape GetUBOUNDs(
FoldingContext &, const NamedEntity &, bool invariantOnly = true);
MaybeExtentExpr GetExtent(
const Subscript &, const NamedEntity &, int dimension);
MaybeExtentExpr GetExtent(
FoldingContext &, const Subscript &, const NamedEntity &, int dimension);
const NamedEntity &, int dimension, bool invariantOnly = true);
MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension,
bool invariantOnly = true);
MaybeExtentExpr GetExtent(const Subscript &, const NamedEntity &, int dimension,
bool invariantOnly = true);
MaybeExtentExpr GetExtent(FoldingContext &, const Subscript &,
const NamedEntity &, int dimension, bool invariantOnly = true);
// Compute an element count for a triplet or trip count for a DO.
ExtentExpr CountTrips(
@@ -115,11 +131,14 @@ public:
using Result = std::optional<Shape>;
using Base = AnyTraverse<GetShapeHelper, Result>;
using Base::operator();
GetShapeHelper() : Base{*this} {}
explicit GetShapeHelper(FoldingContext &c) : Base{*this}, context_{&c} {}
explicit GetShapeHelper(FoldingContext &c, bool useResultSymbolShape)
: Base{*this}, context_{&c}, useResultSymbolShape_{useResultSymbolShape} {
}
explicit GetShapeHelper(bool invariantOnly)
: Base{*this}, invariantOnly_{invariantOnly} {}
explicit GetShapeHelper(FoldingContext &c, bool invariantOnly)
: Base{*this}, context_{&c}, invariantOnly_{invariantOnly} {}
explicit GetShapeHelper(
FoldingContext &c, bool useResultSymbolShape, bool invariantOnly)
: Base{*this}, context_{&c}, useResultSymbolShape_{useResultSymbolShape},
invariantOnly_{invariantOnly} {}
Result operator()(const ImpliedDoIndex &) const { return ScalarShape(); }
Result operator()(const DescriptorInquiry &) const { return ScalarShape(); }
@@ -160,7 +179,7 @@ private:
static Result ScalarShape() { return Shape{}; }
static Shape ConstantShape(const Constant<ExtentType> &);
Result AsShapeResult(ExtentExpr &&) const;
static Shape CreateShape(int rank, NamedEntity &);
Shape CreateShape(int rank, NamedEntity &) const;
template <typename T>
MaybeExtentExpr GetArrayConstructorValueExtent(
@@ -215,34 +234,40 @@ private:
FoldingContext *context_{nullptr};
bool useResultSymbolShape_{true};
// When invariantOnly=false, the returned shape need not be invariant
// in its scope; in particular, it may contain references to dummy arguments.
bool invariantOnly_{true};
};
template <typename A>
std::optional<Shape> GetShape(FoldingContext &context, const A &x) {
if (auto shape{GetShapeHelper{context}(x)}) {
std::optional<Shape> GetShape(
FoldingContext &context, const A &x, bool invariantOnly) {
if (auto shape{GetShapeHelper{context, invariantOnly}(x)}) {
return Fold(context, std::move(shape));
} else {
return std::nullopt;
}
}
template <typename A> std::optional<Shape> GetShape(const A &x) {
return GetShapeHelper{}(x);
template <typename A>
std::optional<Shape> GetShape(const A &x, bool invariantOnly) {
return GetShapeHelper{invariantOnly}(x);
}
template <typename A>
std::optional<Shape> GetShape(FoldingContext *context, const A &x) {
std::optional<Shape> GetShape(
FoldingContext *context, const A &x, bool invariantOnly = true) {
if (context) {
return GetShape(*context, x);
return GetShape(*context, x, invariantOnly);
} else {
return GetShapeHelper{}(x);
return GetShapeHelper{invariantOnly}(x);
}
}
template <typename A>
std::optional<Constant<ExtentType>> GetConstantShape(
FoldingContext &context, const A &x) {
if (auto shape{GetShape(context, x)}) {
if (auto shape{GetShape(context, x, /*invariantonly=*/true)}) {
return AsConstantShape(context, *shape);
} else {
return std::nullopt;
@@ -252,7 +277,7 @@ std::optional<Constant<ExtentType>> GetConstantShape(
template <typename A>
std::optional<ConstantSubscripts> GetConstantExtents(
FoldingContext &context, const A &x) {
if (auto shape{GetShape(context, x)}) {
if (auto shape{GetShape(context, x, /*invariantOnly=*/true)}) {
return AsConstantExtents(context, *shape);
} else {
return std::nullopt;
@@ -265,7 +290,8 @@ std::optional<ConstantSubscripts> GetConstantExtents(
// arguments).
template <typename A>
std::optional<Shape> GetContextFreeShape(FoldingContext &context, const A &x) {
return GetShapeHelper{context, false}(x);
return GetShapeHelper{
context, /*useResultSymbolShape=*/false, /*invariantOnly=*/true}(x);
}
// Compilation-time shape conformance checking, when corresponding extents

1
flang/include/flang/Evaluate/tools.h
View File

@@ -1184,6 +1184,7 @@ const Symbol *GetMainEntry(const Symbol *);
bool IsVariableName(const Symbol &);
bool IsPureProcedure(const Symbol &);
bool IsPureProcedure(const Scope &);
bool IsExplicitlyImpureProcedure(const Symbol &);
bool IsElementalProcedure(const Symbol &);
bool IsFunction(const Symbol &);
bool IsFunction(const Scope &);

150
flang/lib/Evaluate/characteristics.cpp
View File

@@ -73,24 +73,26 @@ TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) {
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const semantics::Symbol &symbol, FoldingContext &context) {
const semantics::Symbol &symbol, FoldingContext &context,
bool invariantOnly) {
const auto &ultimate{symbol.GetUltimate()};
return common::visit(
common::visitors{
[&](const semantics::ProcEntityDetails &proc) {
if (proc.procInterface()) {
return Characterize(*proc.procInterface(), context);
return Characterize(
*proc.procInterface(), context, invariantOnly);
} else if (proc.type()) {
return Characterize(*proc.type(), context);
return Characterize(*proc.type(), context, invariantOnly);
} else {
return std::optional<TypeAndShape>{};
}
},
[&](const semantics::AssocEntityDetails &assoc) {
return Characterize(assoc, context);
return Characterize(assoc, context, invariantOnly);
},
[&](const semantics::ProcBindingDetails &binding) {
return Characterize(binding.symbol(), context);
return Characterize(binding.symbol(), context, invariantOnly);
},
[&](const auto &x) -> std::optional<TypeAndShape> {
using Ty = std::decay_t<decltype(x)>;
@@ -99,8 +101,8 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
std::is_same_v<Ty, semantics::TypeParamDetails>) {
if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
if (auto dyType{DynamicType::From(*type)}) {
TypeAndShape result{
std::move(*dyType), GetShape(context, ultimate)};
TypeAndShape result{std::move(*dyType),
GetShape(context, ultimate, invariantOnly)};
result.AcquireAttrs(ultimate);
result.AcquireLEN(ultimate);
return std::move(result.Rewrite(context));
@@ -117,14 +119,15 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
const semantics::AssocEntityDetails &assoc, FoldingContext &context,
bool invariantOnly) {
std::optional<TypeAndShape> result;
if (auto type{DynamicType::From(assoc.type())}) {
if (auto rank{assoc.rank()}) {
if (*rank >= 0 && *rank <= common::maxRank) {
result = TypeAndShape{std::move(*type), Shape(*rank)};
}
} else if (auto shape{GetShape(context, assoc.expr())}) {
} else if (auto shape{GetShape(context, assoc.expr(), invariantOnly)}) {
result = TypeAndShape{std::move(*type), std::move(*shape)};
}
if (result && type->category() == TypeCategory::Character) {
@@ -139,7 +142,8 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const semantics::DeclTypeSpec &spec, FoldingContext &context) {
const semantics::DeclTypeSpec &spec, FoldingContext &context,
bool /*invariantOnly=*/) {
if (auto type{DynamicType::From(spec)}) {
return Fold(context, TypeAndShape{std::move(*type)});
} else {
@@ -148,11 +152,11 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const ActualArgument &arg, FoldingContext &context) {
const ActualArgument &arg, FoldingContext &context, bool invariantOnly) {
if (const auto *expr{arg.UnwrapExpr()}) {
return Characterize(*expr, context);
return Characterize(*expr, context, invariantOnly);
} else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
return Characterize(*assumed, context);
return Characterize(*assumed, context, invariantOnly);
} else {
return std::nullopt;
}
@@ -386,7 +390,8 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
const semantics::Symbol &symbol, FoldingContext &context) {
if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
object || symbol.has<semantics::EntityDetails>()) {
if (auto type{TypeAndShape::Characterize(symbol, context)}) {
if (auto type{TypeAndShape::Characterize(
symbol, context, /*invariantOnly=*/false)}) {
std::optional<DummyDataObject> result{std::move(*type)};
using semantics::Attr;
CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
@@ -525,7 +530,6 @@ static std::optional<FunctionResult> CharacterizeFunctionResult(
static std::optional<Procedure> CharacterizeProcedure(
const semantics::Symbol &original, FoldingContext &context,
semantics::UnorderedSymbolSet seenProcs) {
Procedure result;
const auto &symbol{ResolveAssociations(original)};
if (seenProcs.find(symbol) != seenProcs.end()) {
std::string procsList{GetSeenProcs(seenProcs)};
@@ -536,22 +540,11 @@ static std::optional<Procedure> CharacterizeProcedure(
return std::nullopt;
}
seenProcs.insert(symbol);
if (IsElementalProcedure(symbol)) {
result.attrs.set(Procedure::Attr::Elemental);
}
CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
{
{semantics::Attr::BIND_C, Procedure::Attr::BindC},
});
if (IsPureProcedure(symbol) || // works for ENTRY too
(!symbol.attrs().test(semantics::Attr::IMPURE) &&
result.attrs.test(Procedure::Attr::Elemental))) {
result.attrs.set(Procedure::Attr::Pure);
}
return common::visit(
auto result{common::visit(
common::visitors{
[&](const semantics::SubprogramDetails &subp)
-> std::optional<Procedure> {
Procedure result;
if (subp.isFunction()) {
if (auto fr{CharacterizeFunctionResult(
subp.result(), context, seenProcs)}) {
@@ -578,7 +571,7 @@ static std::optional<Procedure> CharacterizeProcedure(
}
}
result.cudaSubprogramAttrs = subp.cudaSubprogramAttrs();
return result;
return std::move(result);
},
[&](const semantics::ProcEntityDetails &proc)
-> std::optional<Procedure> {
@@ -597,14 +590,17 @@ static std::optional<Procedure> CharacterizeProcedure(
}
if (const semantics::Symbol *
interfaceSymbol{proc.procInterface()}) {
auto interface {
CharacterizeProcedure(*interfaceSymbol, context, seenProcs)
};
if (interface && IsPointer(symbol)) {
interface->attrs.reset(Procedure::Attr::Elemental);
auto result{
CharacterizeProcedure(*interfaceSymbol, context, seenProcs)};
if (result && (IsDummy(symbol) || IsPointer(symbol))) {
// Dummy procedures and procedure pointers may not be
// ELEMENTAL, but we do accept the use of elemental intrinsic
// functions as their interfaces.
result->attrs.reset(Procedure::Attr::Elemental);
}
return interface;
return result;
} else {
Procedure result;
result.attrs.set(Procedure::Attr::ImplicitInterface);
const semantics::DeclTypeSpec *type{proc.type()};
if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
@@ -624,7 +620,7 @@ static std::optional<Procedure> CharacterizeProcedure(
return std::nullopt;
}
// The PASS name, if any, is not a characteristic.
return result;
return std::move(result);
}
},
[&](const semantics::ProcBindingDetails &binding) {
@@ -683,7 +679,20 @@ static std::optional<Procedure> CharacterizeProcedure(
return std::optional<Procedure>{};
},
},
symbol.details());
symbol.details())};
if (result && !symbol.has<semantics::ProcBindingDetails>()) {
CopyAttrs<Procedure, Procedure::Attr>(DEREF(GetMainEntry(&symbol)), *result,
{
{semantics::Attr::BIND_C, Procedure::Attr::BindC},
{semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
});
if (IsPureProcedure(symbol) || // works for ENTRY too
(!IsExplicitlyImpureProcedure(symbol) &&
result->attrs.test(Procedure::Attr::Elemental))) {
result->attrs.set(Procedure::Attr::Pure);
}
}
return result;
}
static std::optional<DummyProcedure> CharacterizeDummyProcedure(
@@ -918,7 +927,8 @@ static std::optional<FunctionResult> CharacterizeFunctionResult(
const semantics::Symbol &symbol, FoldingContext &context,
semantics::UnorderedSymbolSet seenProcs) {
if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
if (auto type{TypeAndShape::Characterize(symbol, context)}) {
if (auto type{TypeAndShape::Characterize(
symbol, context, /*invariantOnly=*/false)}) {
FunctionResult result{std::move(*type)};
CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
{
@@ -996,21 +1006,18 @@ bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
}
}
static bool AreCompatibleFunctionResultShapes(const Shape &x, const Shape &y) {
static std::optional<std::string> AreIncompatibleFunctionResultShapes(
const Shape &x, const Shape &y) {
int rank{GetRank(x)};
if (GetRank(y) != rank) {
return false;
if (int yrank{GetRank(y)}; yrank != rank) {
return "rank "s + std::to_string(rank) + " vs " + std::to_string(yrank);
}
for (int j{0}; j < rank; ++j) {
if (auto xDim{ToInt64(x[j])}) {
if (auto yDim{ToInt64(y[j])}) {
if (*xDim != *yDim) {
return false;
}
}
if (x[j] && y[j] && !(*x[j] == *y[j])) {
return x[j]->AsFortran() + " vs " + y[j]->AsFortran();
}
}
return true;
return std::nullopt;
}
bool FunctionResult::IsCompatibleWith(
@@ -1029,38 +1036,45 @@ bool FunctionResult::IsCompatibleWith(
}
} else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
std::optional<std::string> details;
if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) {
if (whyNot) {
*whyNot = "function results have distinct ranks";
}
} else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
!AreCompatibleFunctionResultShapes(
ifaceTypeShape->shape(), actualTypeShape->shape())) {
(details = AreIncompatibleFunctionResultShapes(
ifaceTypeShape->shape(), actualTypeShape->shape()))) {
if (whyNot) {
*whyNot = "function results have distinct constant extents";
*whyNot = "function results have distinct extents (" + *details + ')';
}
} else if (ifaceTypeShape->type() != actualTypeShape->type()) {
if (ifaceTypeShape->type().category() ==
if (ifaceTypeShape->type().category() !=
actualTypeShape->type().category()) {
if (ifaceTypeShape->type().category() == TypeCategory::Character) {
if (ifaceTypeShape->type().kind() ==
actualTypeShape->type().kind()) {
auto ifaceLen{ifaceTypeShape->type().knownLength()};
auto actualLen{actualTypeShape->type().knownLength()};
if (!ifaceLen || !actualLen || *ifaceLen == *actualLen) {
} else if (ifaceTypeShape->type().category() ==
TypeCategory::Character) {
if (ifaceTypeShape->type().kind() == actualTypeShape->type().kind()) {
if (IsAssumedLengthCharacter() ||
actual.IsAssumedLengthCharacter()) {
return true;
} else {
const auto *ifaceLenParam{
ifaceTypeShape->type().charLengthParamValue()};
const auto *actualLenParam{
actualTypeShape->type().charLengthParamValue()};
if (ifaceLenParam && actualLenParam &&
*ifaceLenParam == *actualLenParam) {
return true;
}
}
} else if (ifaceTypeShape->type().category() ==
TypeCategory::Derived) {
if (ifaceTypeShape->type().IsPolymorphic() ==
actualTypeShape->type().IsPolymorphic() &&
!ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
!actualTypeShape->type().IsUnlimitedPolymorphic() &&
AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
actualTypeShape->type().GetDerivedTypeSpec())) {
return true;
}
}
} else if (ifaceTypeShape->type().category() == TypeCategory::Derived) {
if (ifaceTypeShape->type().IsPolymorphic() ==
actualTypeShape->type().IsPolymorphic() &&
!ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
!actualTypeShape->type().IsUnlimitedPolymorphic() &&
AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
actualTypeShape->type().GetDerivedTypeSpec())) {
return true;
}
}
if (whyNot) {

2
flang/lib/Evaluate/intrinsics.cpp
View File

@@ -3025,7 +3025,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
}
if (!ok) {
context.messages().Say(at,
"Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional"_err_en_US);
"Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
} else if (data[0]->attrs.test(characteristics::DummyDataObject::
Attr::Asynchronous) !=
data[1]->attrs.test(

148
flang/lib/Evaluate/shape.cpp
View File

@@ -76,10 +76,10 @@ auto GetShapeHelper::AsShapeResult(ExtentExpr &&arrayExpr) const -> Result {
}
}
Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) {
Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) const {
Shape shape;
for (int dimension{0}; dimension < rank; ++dimension) {
shape.emplace_back(GetExtent(base, dimension));
shape.emplace_back(GetExtent(base, dimension, invariantOnly_));
}
return shape;
}
@@ -236,8 +236,10 @@ public:
using Result = RESULT;
using Base = Traverse<GetLowerBoundHelper, RESULT>;
using Base::operator();
explicit GetLowerBoundHelper(int d, FoldingContext *context)
: Base{*this}, dimension_{d}, context_{context} {}
explicit GetLowerBoundHelper(
int d, FoldingContext *context, bool invariantOnly)
: Base{*this}, dimension_{d}, context_{context},
invariantOnly_{invariantOnly} {}
static Result Default() { return Result{1}; }
static Result Combine(Result &&, Result &&) {
// Operator results and array references always have lower bounds == 1
@@ -259,7 +261,7 @@ public:
if (dimension_ == rank - 1 && details->IsAssumedSize()) {
// last dimension of assumed-size dummy array: don't worry
// about handling an empty dimension
ok = IsScopeInvariantExpr(*lbound);
ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);
} else if (lbValue.value_or(0) == 1) {
// Lower bound is 1, regardless of extent
ok = true;
@@ -371,60 +373,69 @@ public:
private:
int dimension_; // zero-based
FoldingContext *context_{nullptr};
bool invariantOnly_{false};
};
ExtentExpr GetRawLowerBound(const NamedEntity &base, int dimension) {
return GetLowerBoundHelper<ExtentExpr, false>{dimension, nullptr}(base);
}
ExtentExpr GetRawLowerBound(
FoldingContext &context, const NamedEntity &base, int dimension) {
return Fold(context,
GetLowerBoundHelper<ExtentExpr, false>{dimension, &context}(base));
const NamedEntity &base, int dimension, bool invariantOnly) {
return GetLowerBoundHelper<ExtentExpr, false>{
dimension, nullptr, invariantOnly}(base);
}
MaybeExtentExpr GetLBOUND(const NamedEntity &base, int dimension) {
return GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, nullptr}(base);
ExtentExpr GetRawLowerBound(FoldingContext &context, const NamedEntity &base,
int dimension, bool invariantOnly) {
return Fold(context,
GetLowerBoundHelper<ExtentExpr, false>{
dimension, &context, invariantOnly}(base));
}
MaybeExtentExpr GetLBOUND(
FoldingContext &context, const NamedEntity &base, int dimension) {
const NamedEntity &base, int dimension, bool invariantOnly) {
return GetLowerBoundHelper<MaybeExtentExpr, true>{
dimension, nullptr, invariantOnly}(base);
}
MaybeExtentExpr GetLBOUND(FoldingContext &context, const NamedEntity &base,
int dimension, bool invariantOnly) {
return Fold(context,
GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, &context}(base));
GetLowerBoundHelper<MaybeExtentExpr, true>{
dimension, &context, invariantOnly}(base));
}
Shape GetRawLowerBounds(const NamedEntity &base) {
Shape GetRawLowerBounds(const NamedEntity &base, bool invariantOnly) {
Shape result;
int rank{base.Rank()};
for (int dim{0}; dim < rank; ++dim) {
result.emplace_back(GetRawLowerBound(base, dim));
result.emplace_back(GetRawLowerBound(base, dim, invariantOnly));
}
return result;
}
Shape GetRawLowerBounds(FoldingContext &context, const NamedEntity &base) {
Shape GetRawLowerBounds(
FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
Shape result;
int rank{base.Rank()};
for (int dim{0}; dim < rank; ++dim) {
result.emplace_back(GetRawLowerBound(context, base, dim));
result.emplace_back(GetRawLowerBound(context, base, dim, invariantOnly));
}
return result;
}
Shape GetLBOUNDs(const NamedEntity &base) {
Shape GetLBOUNDs(const NamedEntity &base, bool invariantOnly) {
Shape result;
int rank{base.Rank()};
for (int dim{0}; dim < rank; ++dim) {
result.emplace_back(GetLBOUND(base, dim));
result.emplace_back(GetLBOUND(base, dim, invariantOnly));
}
return result;
}
Shape GetLBOUNDs(FoldingContext &context, const NamedEntity &base) {
Shape GetLBOUNDs(
FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
Shape result;
int rank{base.Rank()};
for (int dim{0}; dim < rank; ++dim) {
result.emplace_back(GetLBOUND(context, base, dim));
result.emplace_back(GetLBOUND(context, base, dim, invariantOnly));
}
return result;
}
@@ -433,7 +444,7 @@ Shape GetLBOUNDs(FoldingContext &context, const NamedEntity &base) {
// the extent. In particular, if the upper bound is less than the lower bound,
// return zero.
static MaybeExtentExpr GetNonNegativeExtent(
const semantics::ShapeSpec &shapeSpec) {
const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
const auto &ubound{shapeSpec.ubound().GetExplicit()};
const auto &lbound{shapeSpec.lbound().GetExplicit()};
std::optional<ConstantSubscript> uval{ToInt64(ubound)};
@@ -444,8 +455,9 @@ static MaybeExtentExpr GetNonNegativeExtent(
} else {
return ExtentExpr{*uval - *lval + 1};
}
} else if (lbound && ubound && IsScopeInvariantExpr(*lbound) &&
IsScopeInvariantExpr(*ubound)) {
} else if (lbound && ubound &&
(!invariantOnly ||
(IsScopeInvariantExpr(*lbound) && IsScopeInvariantExpr(*ubound)))) {
// Apply effective IDIM (MAX calculation with 0) so thet the
// result is never negative
if (lval.value_or(0) == 1) {
@@ -481,7 +493,8 @@ MaybeExtentExpr GetAssociatedExtent(const NamedEntity &base,
return std::nullopt;
}
MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
MaybeExtentExpr GetExtent(
const NamedEntity &base, int dimension, bool invariantOnly) {
CHECK(dimension >= 0);
const Symbol &last{base.GetLastSymbol()};
const Symbol &symbol{ResolveAssociationsExceptSelectRank(last)};
@@ -506,7 +519,7 @@ MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
int j{0};
for (const auto &shapeSpec : details->shape()) {
if (j++ == dimension) {
if (auto extent{GetNonNegativeExtent(shapeSpec)}) {
if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
return extent;
} else if (details->IsAssumedSize() && j == symbol.Rank()) {
return std::nullopt;
@@ -523,23 +536,23 @@ MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
return std::nullopt;
}
MaybeExtentExpr GetExtent(
FoldingContext &context, const NamedEntity &base, int dimension) {
return Fold(context, GetExtent(base, dimension));
MaybeExtentExpr GetExtent(FoldingContext &context, const NamedEntity &base,
int dimension, bool invariantOnly) {
return Fold(context, GetExtent(base, dimension, invariantOnly));
}
MaybeExtentExpr GetExtent(
const Subscript &subscript, const NamedEntity &base, int dimension) {
MaybeExtentExpr GetExtent(const Subscript &subscript, const NamedEntity &base,
int dimension, bool invariantOnly) {
return common::visit(
common::visitors{
[&](const Triplet &triplet) -> MaybeExtentExpr {
MaybeExtentExpr upper{triplet.upper()};
if (!upper) {
upper = GetUBOUND(base, dimension);
upper = GetUBOUND(base, dimension, invariantOnly);
}
MaybeExtentExpr lower{triplet.lower()};
if (!lower) {
lower = GetLBOUND(base, dimension);
lower = GetLBOUND(base, dimension, invariantOnly);
}
return CountTrips(std::move(lower), std::move(upper),
MaybeExtentExpr{triplet.stride()});
@@ -558,8 +571,8 @@ MaybeExtentExpr GetExtent(
}
MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
const NamedEntity &base, int dimension) {
return Fold(context, GetExtent(subscript, base, dimension));
const NamedEntity &base, int dimension, bool invariantOnly) {
return Fold(context, GetExtent(subscript, base, dimension, invariantOnly));
}
MaybeExtentExpr ComputeUpperBound(
@@ -580,14 +593,15 @@ MaybeExtentExpr ComputeUpperBound(
return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));
}
MaybeExtentExpr GetRawUpperBound(const NamedEntity &base, int dimension) {
MaybeExtentExpr GetRawUpperBound(
const NamedEntity &base, int dimension, bool invariantOnly) {
const Symbol &symbol{
ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
int rank{details->shape().Rank()};
if (dimension < rank) {
const auto &bound{details->shape()[dimension].ubound().GetExplicit()};
if (bound && IsScopeInvariantExpr(*bound)) {
if (bound && (!invariantOnly || IsScopeInvariantExpr(*bound))) {
return *bound;
} else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
return std::nullopt;
@@ -606,16 +620,16 @@ MaybeExtentExpr GetRawUpperBound(const NamedEntity &base, int dimension) {
return std::nullopt;
}
MaybeExtentExpr GetRawUpperBound(
FoldingContext &context, const NamedEntity &base, int dimension) {
return Fold(context, GetRawUpperBound(base, dimension));
MaybeExtentExpr GetRawUpperBound(FoldingContext &context,
const NamedEntity &base, int dimension, bool invariantOnly) {
return Fold(context, GetRawUpperBound(base, dimension, invariantOnly));
}
static MaybeExtentExpr GetExplicitUBOUND(
FoldingContext *context, const semantics::ShapeSpec &shapeSpec) {
static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,
const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
const auto &ubound{shapeSpec.ubound().GetExplicit()};
if (ubound && IsScopeInvariantExpr(*ubound)) {
if (auto extent{GetNonNegativeExtent(shapeSpec)}) {
if (ubound && (!invariantOnly || IsScopeInvariantExpr(*ubound))) {
if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
if (auto cstExtent{ToInt64(
context ? Fold(*context, std::move(*extent)) : *extent)}) {
if (cstExtent > 0) {
@@ -629,20 +643,21 @@ static MaybeExtentExpr GetExplicitUBOUND(
return std::nullopt;
}
static MaybeExtentExpr GetUBOUND(
FoldingContext *context, const NamedEntity &base, int dimension) {
static MaybeExtentExpr GetUBOUND(FoldingContext *context,
const NamedEntity &base, int dimension, bool invariantOnly) {
const Symbol &symbol{
ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
int rank{details->shape().Rank()};
if (dimension < rank) {
const semantics::ShapeSpec &shapeSpec{details->shape()[dimension]};
if (auto ubound{GetExplicitUBOUND(context, shapeSpec)}) {
if (auto ubound{GetExplicitUBOUND(context, shapeSpec, invariantOnly)}) {
return *ubound;
} else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
return std::nullopt; // UBOUND() folding replaces with -1
} else if (auto lb{GetLBOUND(base, dimension)}) {
return ComputeUpperBound(std::move(*lb), GetExtent(base, dimension));
} else if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
return ComputeUpperBound(
std::move(*lb), GetExtent(base, dimension, invariantOnly));
}
}
} else if (const auto *assoc{
@@ -658,7 +673,7 @@ static MaybeExtentExpr GetUBOUND(
}
} else if (assoc->expr()) {
if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
if (auto lb{GetLBOUND(base, dimension)}) {
if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
return ComputeUpperBound(std::move(*lb), std::move(extent));
}
}
@@ -667,29 +682,34 @@ static MaybeExtentExpr GetUBOUND(
return std::nullopt;
}
MaybeExtentExpr GetUBOUND(const NamedEntity &base, int dimension) {
return GetUBOUND(nullptr, base, dimension);
}
MaybeExtentExpr GetUBOUND(
FoldingContext &context, const NamedEntity &base, int dimension) {
return Fold(context, GetUBOUND(&context, base, dimension));
const NamedEntity &base, int dimension, bool invariantOnly) {
return GetUBOUND(nullptr, base, dimension, invariantOnly);
}
static Shape GetUBOUNDs(FoldingContext *context, const NamedEntity &base) {
MaybeExtentExpr GetUBOUND(FoldingContext &context, const NamedEntity &base,
int dimension, bool invariantOnly) {
return Fold(context, GetUBOUND(&context, base, dimension, invariantOnly));
}
static Shape GetUBOUNDs(
FoldingContext *context, const NamedEntity &base, bool invariantOnly) {
Shape result;
int rank{base.Rank()};
for (int dim{0}; dim < rank; ++dim) {
result.emplace_back(GetUBOUND(context, base, dim));
result.emplace_back(GetUBOUND(context, base, dim, invariantOnly));
}
return result;
}
Shape GetUBOUNDs(FoldingContext &context, const NamedEntity &base) {
return Fold(context, GetUBOUNDs(&context, base));
Shape GetUBOUNDs(
FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
return Fold(context, GetUBOUNDs(&context, base, invariantOnly));
}
Shape GetUBOUNDs(const NamedEntity &base) { return GetUBOUNDs(nullptr, base); }
Shape GetUBOUNDs(const NamedEntity &base, bool invariantOnly) {
return GetUBOUNDs(nullptr, base, invariantOnly);
}
auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
return common::visit(

27
flang/lib/Evaluate/tools.cpp
View File

@@ -1324,23 +1324,26 @@ bool IsPureProcedure(const Scope &scope) {
return symbol && IsPureProcedure(*symbol);
}
bool IsExplicitlyImpureProcedure(const Symbol &original) {
// An ENTRY is IMPURE if its containing subprogram is so
return DEREF(GetMainEntry(&original.GetUltimate()))
.attrs()
.test(Attr::IMPURE);
}
bool IsElementalProcedure(const Symbol &original) {
// An ENTRY is elemental if its containing subprogram is
const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
if (const Symbol * procInterface{procDetails->procInterface()}) {
// procedure with an elemental interface, ignoring the elemental
// aspect of intrinsic functions
return !procInterface->attrs().test(Attr::INTRINSIC) &&
IsElementalProcedure(*procInterface);
}
} else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
return !details->symbol().attrs().test(Attr::INTRINSIC) &&
IsElementalProcedure(details->symbol());
} else if (!IsProcedure(symbol)) {
if (IsProcedure(symbol)) {
auto &foldingContext{symbol.owner().context().foldingContext()};
auto restorer{foldingContext.messages().DiscardMessages()};
auto proc{evaluate::characteristics::Procedure::Characterize(
symbol, foldingContext)};
return proc &&
proc->attrs.test(evaluate::characteristics::Procedure::Attr::Elemental);
} else {
return false;
}
return symbol.attrs().test(Attr::ELEMENTAL);
}
bool IsFunction(const Symbol &symbol) {

28
flang/lib/Evaluate/variable.cpp
View File

@@ -639,16 +639,32 @@ NamedEntity CoarrayRef::GetBase() const { return AsNamedEntity(base_); }
// For the purposes of comparing type parameter expressions while
// testing the compatibility of procedure characteristics, two
// object dummy arguments with the same name are considered equal.
// dummy arguments with the same position are considered equal.
static std::optional<int> GetDummyArgPosition(const Symbol &original) {
const Symbol &symbol(original.GetUltimate());
if (IsDummy(symbol)) {
if (const Symbol * proc{symbol.owner().symbol()}) {
if (const auto *subp{proc->detailsIf<semantics::SubprogramDetails>()}) {
int j{0};
for (const Symbol *arg : subp->dummyArgs()) {
if (arg == &symbol) {
return j;
}
++j;
}
}
}
}
return std::nullopt;
}
static bool AreSameSymbol(const Symbol &x, const Symbol &y) {
if (&x == &y) {
return true;
}
if (x.name() == y.name()) {
if (const auto *xObject{x.detailsIf<semantics::ObjectEntityDetails>()}) {
if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
return xObject->isDummy() && yObject->isDummy();
}
if (auto xPos{GetDummyArgPosition(x)}) {
if (auto yPos{GetDummyArgPosition(y)}) {
return *xPos == *yPos;
}
}
return false;

4
flang/lib/Lower/ConvertType.cpp
View File

@@ -276,8 +276,8 @@ struct TypeBuilderImpl {
Fortran::semantics::IsUnlimitedPolymorphic(symbol)) &&
!Fortran::semantics::IsAssumedType(symbol);
if (ultimate.IsObjectArray()) {
auto shapeExpr = Fortran::evaluate::GetShapeHelper{
converter.getFoldingContext()}(ultimate);
auto shapeExpr =
Fortran::evaluate::GetShape(converter.getFoldingContext(), ultimate);
if (!shapeExpr)
TODO(loc, "assumed rank symbol type");
fir::SequenceType::Shape shape;

80
flang/lib/Semantics/check-declarations.cpp
View File

@@ -1024,7 +1024,7 @@ void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
if (auto designator{evaluate::AsGenericExpr(symbol)}) {
auto restorer{messages_.SetLocation(symbol.name())};
context_.set_location(symbol.name());
CheckInitialTarget(
CheckInitialDataPointerTarget(
context_, *designator, *object->init(), DEREF(scope_));
}
}
@@ -1033,28 +1033,36 @@ void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
// C1519 - must be nonelemental external or module procedure,
// or an unrestricted specific intrinsic function.
const Symbol &ultimate{(*proc->init())->GetUltimate()};
bool checkTarget{true};
if (ultimate.attrs().test(Attr::INTRINSIC)) {
if (const auto intrinsic{
context_.intrinsics().IsSpecificIntrinsicFunction(
ultimate.name().ToString())};
if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
ultimate.name().ToString())};
!intrinsic || intrinsic->isRestrictedSpecific) { // C1030
context_.Say(
"Intrinsic procedure '%s' is not an unrestricted specific "
"intrinsic permitted for use as the initializer for procedure "
"pointer '%s'"_err_en_US,
ultimate.name(), symbol.name());
checkTarget = false;
}
} else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
ultimate.owner().kind() != Scope::Kind::Module) {
} else if ((!ultimate.attrs().test(Attr::EXTERNAL) &&
ultimate.owner().kind() != Scope::Kind::Module) ||
IsDummy(ultimate) || IsPointer(ultimate)) {
context_.Say("Procedure pointer '%s' initializer '%s' is neither "
"an external nor a module procedure"_err_en_US,
symbol.name(), ultimate.name());
checkTarget = false;
} else if (IsElementalProcedure(ultimate)) {
context_.Say("Procedure pointer '%s' cannot be initialized with the "
"elemental procedure '%s"_err_en_US,
"elemental procedure '%s'"_err_en_US,
symbol.name(), ultimate.name());
} else {
// TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
checkTarget = false;
}
if (checkTarget) {
SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
CheckPointerAssignment(context_, lhs, rhs,
GetProgramUnitOrBlockConstructContaining(symbol));
}
}
}
@@ -1148,6 +1156,9 @@ void CheckHelper::CheckArraySpec(
void CheckHelper::CheckProcEntity(
const Symbol &symbol, const ProcEntityDetails &details) {
CheckSymbolType(symbol);
const Symbol *interface {
details.procInterface() ? &details.procInterface()->GetUltimate() : nullptr
};
if (details.isDummy()) {
if (!symbol.attrs().test(Attr::POINTER) && // C843
(symbol.attrs().test(Attr::INTENT_IN) ||
@@ -1160,20 +1171,19 @@ void CheckHelper::CheckProcEntity(
messages_.Say(
"An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
}
const Symbol *interface {
details.procInterface()
};
if (!symbol.attrs().test(Attr::INTRINSIC) &&
(IsElementalProcedure(symbol) ||
(interface && !interface->attrs().test(Attr::INTRINSIC) &&
IsElementalProcedure(*interface)))) {
if (interface && IsElementalProcedure(*interface)) {
// There's no explicit constraint or "shall" that we can find in the
// standard for this check, but it seems to be implied in multiple
// sites, and ELEMENTAL non-intrinsic actual arguments *are*
// explicitly forbidden. But we allow "PROCEDURE(SIN)::dummy"
// because it is explicitly legal to *pass* the specific intrinsic
// function SIN as an actual argument.
messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
if (interface->attrs().test(Attr::INTRINSIC)) {
messages_.Say(
"A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
} else {
messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
}
}
} else if (symbol.attrs().test(Attr::INTENT_IN) ||
symbol.attrs().test(Attr::INTENT_OUT) ||
@@ -1183,35 +1193,35 @@ void CheckHelper::CheckProcEntity(
} else if (IsOptional(symbol)) {
messages_.Say("OPTIONAL attribute may apply only to a dummy "
"argument"_err_en_US); // C849
} else if (symbol.owner().IsDerivedType()) {
if (!symbol.attrs().test(Attr::POINTER)) { // C756
const auto &name{symbol.name()};
messages_.Say(name,
"Procedure component '%s' must have POINTER attribute"_err_en_US,
name);
}
CheckPassArg(symbol, details.procInterface(), details);
}
if (IsPointer(symbol)) {
} else if (IsPointer(symbol)) {
CheckPointerInitialization(symbol);
if (const Symbol * interface{details.procInterface()}) {
const Symbol &ultimate{interface->GetUltimate()};
if (ultimate.attrs().test(Attr::INTRINSIC)) {
if (const auto intrinsic{
context_.intrinsics().IsSpecificIntrinsicFunction(
ultimate.name().ToString())};
!intrinsic || intrinsic->isRestrictedSpecific) { // C1515
if (interface) {
if (interface->attrs().test(Attr::INTRINSIC)) {
auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
interface->name().ToString())};
if (!intrinsic || intrinsic->isRestrictedSpecific) { // C1515
messages_.Say(
"Intrinsic procedure '%s' is not an unrestricted specific "
"intrinsic permitted for use as the definition of the interface "
"to procedure pointer '%s'"_err_en_US,
ultimate.name(), symbol.name());
interface->name(), symbol.name());
} else if (IsElementalProcedure(*interface)) {
messages_.Say(
"Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
symbol.name()); // C1517
}
} else if (IsElementalProcedure(*interface)) {
messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
symbol.name()); // C1517
}
}
if (symbol.owner().IsDerivedType()) {
CheckPassArg(symbol, interface, details);
}
} else if (symbol.owner().IsDerivedType()) {
const auto &name{symbol.name()};
messages_.Say(name,
"Procedure component '%s' must have POINTER attribute"_err_en_US, name);
}
CheckExternal(symbol);
}

2
flang/lib/Semantics/data-to-inits.cpp
View File

@@ -406,7 +406,7 @@ bool DataInitializationCompiler<DSV>::InitElement(
exprAnalyzer_.Say(
"Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US,
expr->AsFortran(), DescribeElement());
} else if (CheckInitialTarget(
} else if (CheckInitialDataPointerTarget(
exprAnalyzer_.context(), designator, *expr, DEREF(scope_))) {
GetImage().AddPointer(offsetSymbol.offset(), *expr);
return true;

11
flang/lib/Semantics/pointer-assignment.cpp
View File

@@ -360,7 +360,8 @@ bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
}
bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
if (const Symbol * symbol{d.GetSymbol()}) {
const Symbol *symbol{d.GetSymbol()};
if (symbol) {
if (const auto *subp{
symbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
if (subp->stmtFunction()) {
@@ -377,6 +378,10 @@ bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
}
}
if (auto chars{Procedure::Characterize(d, foldingContext_)}) {
// Disregard the elemental attribute of RHS intrinsics.
if (symbol && symbol->GetUltimate().attrs().test(Attr::INTRINSIC)) {
chars->attrs.reset(Procedure::Attr::Elemental);
}
return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic());
} else {
return Check(d.GetName(), false);
@@ -517,8 +522,8 @@ bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
.Check(rhs);
}
bool CheckInitialTarget(SemanticsContext &context, const SomeExpr &pointer,
const SomeExpr &init, const Scope &scope) {
bool CheckInitialDataPointerTarget(SemanticsContext &context,
const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) {
return evaluate::IsInitialDataTarget(
init, &context.foldingContext().messages()) &&
CheckPointerAssignment(context, pointer, init, scope);

7
flang/lib/Semantics/pointer-assignment.h
View File

@@ -27,16 +27,17 @@ bool CheckPointerAssignment(
SemanticsContext &, const evaluate::Assignment &, const Scope &);
bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs,
const SomeExpr &rhs, const Scope &, bool isBoundsRemapping = false);
bool CheckStructConstructorPointerComponent(
SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source,
const std::string &description,
const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs,
const Scope &);
bool CheckStructConstructorPointerComponent(
SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
// Checks whether an expression is a valid static initializer for a
// particular pointer designator.
bool CheckInitialTarget(SemanticsContext &, const SomeExpr &pointer,
bool CheckInitialDataPointerTarget(SemanticsContext &, const SomeExpr &pointer,
const SomeExpr &init, const Scope &);
} // namespace Fortran::semantics

1
flang/test/Semantics/block-data01.f90
View File

@@ -7,6 +7,7 @@ block data foo
!ERROR: An initialized variable in BLOCK DATA must be in a COMMON block
integer :: notInCommon = 1
integer :: uninitialized ! ok
!PORTABILITY: Procedure pointer 'q' should not have an ELEMENTAL intrinsic as its interface
!ERROR: 'q' may not appear in a BLOCK DATA subprogram
procedure(sin), pointer :: q => cos
!ERROR: 'p' may not be a procedure as it is in a COMMON block

1
flang/test/Semantics/c_loc01.f90
View File

@@ -11,6 +11,7 @@ module m
type(c_ptr) cp
type(c_funptr) cfp
real notATarget
!PORTABILITY: Procedure pointer 'pptr' should not have an ELEMENTAL intrinsic as its interface
procedure(sin), pointer :: pptr
real, target :: arr(3)
type(hasLen(1)), target :: clen

3
flang/test/Semantics/call02.f90
View File

@@ -8,6 +8,7 @@ subroutine s01(elem, subr)
real, intent(in), value :: x
end function
subroutine subr(dummy)
!PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
procedure(sin) :: dummy
end subroutine
subroutine badsubr(dummy)
@@ -16,9 +17,11 @@ subroutine s01(elem, subr)
procedure(elem) :: dummy
end subroutine
subroutine optionalsubr(dummy)
!PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
procedure(sin), optional :: dummy
end subroutine
subroutine ptrsubr(dummy)
!PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
procedure(sin), pointer, intent(in) :: dummy
end subroutine
end interface

1
flang/test/Semantics/call09.f90
View File

@@ -37,6 +37,7 @@ module m
end subroutine
subroutine selemental1(p)
!PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
procedure(cos) :: p ! ok
end subroutine

3
flang/test/Semantics/io11.f90
View File

@@ -80,9 +80,10 @@ module m4
contains
!ERROR: Dummy argument 0 of 'formattedreadproc' must be a data object
!ERROR: Cannot use an alternate return as the passed-object dummy argument
subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg)
subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg)
!ERROR: Dummy argument 'unit' must be a data object
!ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute
!PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
procedure(sin), intent(in) :: unit
character(len=*), intent(in) :: iotype
integer, intent(in) :: vlist(:)

13
flang/test/Semantics/modfile49.f90
View File

@@ -4,7 +4,11 @@
module m
type :: t
end type
procedure(sin) :: ext
abstract interface
subroutine iface
end
end interface
procedure(iface) :: ext
interface
subroutine subr(p1,p2)
import ext, t
@@ -22,8 +26,11 @@ end module
!module m
!type::t
!end type
!intrinsic::sin
!procedure(sin)::ext
!abstract interface
!subroutine iface()
!end
!end interface
!procedure(iface)::ext
!interface
!subroutine subr(p1,p2)
!import::ext

4
flang/test/Semantics/procinterface01.f90
View File

@@ -48,7 +48,7 @@ module module1
type :: derived1
!REF: /module1/abstract1
!DEF: /module1/derived1/p1 NOPASS, POINTER (Function) ProcEntity REAL(4)
!DEF: /module1/nested1 PUBLIC (Function) Subprogram REAL(4)
!DEF: /module1/nested1 PUBLIC, PURE (Function) Subprogram REAL(4)
procedure(abstract1), pointer, nopass :: p1 => nested1
!REF: /module1/explicit1
!DEF: /module1/derived1/p2 NOPASS, POINTER (Function) ProcEntity REAL(4)
@@ -81,7 +81,7 @@ contains
!REF: /module1/nested1
!DEF: /module1/nested1/x INTENT(IN) ObjectEntity REAL(4)
real function nested1(x)
pure real function nested1(x)
!REF: /module1/nested1/x
real, intent(in) :: x
!DEF: /module1/nested1/nested1 ObjectEntity REAL(4)

1
flang/test/Semantics/procinterface02.f90
View File

@@ -12,6 +12,7 @@ subroutine foo(A, B, P)
end function
end interface
real :: A(:), B(:)
!PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
procedure(sqrt), pointer :: P
!ERROR: Rank of dummy argument is 0, but actual argument has rank 1
A = P(B)

24
flang/test/Semantics/procinterface04.f90 Normal file
View File

@@ -0,0 +1,24 @@
! RUN: %python %S/test_errors.py %s %flang_fc1
subroutine test(dp1, dp2)
intrinsic sin
interface
elemental real function elemental(x)
real, intent(in) :: x
end
pure real function nonelemental(x)
real, intent(in) :: x
end
end interface
!PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
procedure(sin) :: dp1
!ERROR: A dummy procedure may not be ELEMENTAL
procedure(elemental) :: dp2
!PORTABILITY: Procedure pointer 'pp1' should not have an ELEMENTAL intrinsic as its interface
procedure(sin), pointer :: pp1
!ERROR: Procedure pointer 'pp2' may not be ELEMENTAL
procedure(elemental), pointer :: pp2
procedure(elemental) :: pp3 ! ok, external
procedure(nonelemental), pointer :: pp4 => sin ! ok, special case
!ERROR: Procedure pointer 'pp5' cannot be initialized with the elemental procedure 'elemental'
procedure(nonelemental), pointer :: pp5 => elemental
end

8
flang/test/Semantics/reduce01.f90
View File

@@ -70,13 +70,13 @@ module m
b = reduce(a, f4)
!ERROR: OPERATION= argument of REDUCE() must have the same type as ARRAY=
b = reduce(a, f5)
!ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
!ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
b = reduce(a, f6)
!ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
!ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
b = reduce(a, f7)
!ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
!ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
b = reduce(a, f8)
!ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
!ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
b = reduce(a, f9)
!ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute
b = reduce(a, f10)

10
flang/test/Semantics/resolve114.f90
View File

@@ -34,7 +34,9 @@ end module m2
subroutine s2a
use m1
use m2
!PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
procedure(sin), pointer :: p1 => sin
!PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
procedure(iabs), pointer :: p2 => iabs
procedure(ext1), pointer :: p3 => ext1
procedure(ext2), pointer :: p4 => ext2
@@ -44,7 +46,9 @@ subroutine s2b
use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
use m2, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
!PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
procedure(iface1), pointer :: p1 => x1
!PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
procedure(iface2), pointer :: p2 => x2
procedure(iface3), pointer :: p3 => x3
procedure(iface4), pointer :: p4 => x4
@@ -56,7 +60,9 @@ module m3
end module
subroutine s3
use m3
!PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
procedure(sin), pointer :: p1 => sin
!PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
procedure(iabs), pointer :: p2 => iabs
procedure(ext1), pointer :: p3 => ext1
procedure(ext2), pointer :: p4 => ext2
@@ -69,7 +75,9 @@ end module
subroutine s4
use m4
use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
!PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
procedure(iface1), pointer :: p1 => x1
!PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
procedure(iface2), pointer :: p2 => x2
procedure(iface3), pointer :: p3 => x3
procedure(iface4), pointer :: p4 => x4
@@ -79,8 +87,10 @@ subroutine s5
use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
use m2, only: x1 => tan, x2 => idim, x3 => ext2, x4 => ext1
use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
!PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
!ERROR: Reference to 'x1' is ambiguous
procedure(iface1), pointer :: p1 => x1
!PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
!ERROR: Reference to 'x2' is ambiguous
procedure(iface2), pointer :: p2 => x2
!ERROR: Reference to 'x3' is ambiguous

2
flang/test/Semantics/resolve46.f90
View File

@@ -20,6 +20,7 @@ program main
end function chrcmp
end interface
!PORTABILITY: Procedure pointer 'p' should not have an ELEMENTAL intrinsic as its interface
procedure(sin), pointer :: p => cos
!ERROR: Intrinsic procedure 'amin0' is not an unrestricted specific intrinsic permitted for use as the definition of the interface to procedure pointer 'q'
procedure(amin0), pointer :: q
@@ -28,6 +29,7 @@ program main
!ERROR: Intrinsic procedure 'llt' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 's'
procedure(chrcmp), pointer :: s => llt
!ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 't'
!PORTABILITY: Procedure pointer 't' should not have an ELEMENTAL intrinsic as its interface
procedure(cos), pointer :: t => bessel_j0
procedure(chrcmp), pointer :: u
p => alog ! valid use of an unrestricted specific intrinsic

1
flang/test/Semantics/resolve59.f90
View File

@@ -114,6 +114,7 @@ contains
end function
function f5(x) result(r)
real :: x
!PORTABILITY: Procedure pointer 'r' should not have an ELEMENTAL intrinsic as its interface
procedure(acos), pointer :: r
r => acos
!ERROR: Actual argument for 'x=' may not be a procedure