[flang-commits] [flang] 0c0b2ea - [flang] Check procedure pointer initializations; clean up ELEMENTAL
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Tue Aug 29 15:08:35 PDT 2023
Author: Peter Klausler
Date: 2023-08-29T15:08:23-07:00
New Revision: 0c0b2ea98816067aea43f38892e5901c74271d40
URL: https://github.com/llvm/llvm-project/commit/0c0b2ea98816067aea43f38892e5901c74271d40
DIFF: https://github.com/llvm/llvm-project/commit/0c0b2ea98816067aea43f38892e5901c74271d40.diff
LOG: [flang] Check procedure pointer initializations; clean up ELEMENTAL
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
Added:
flang/test/Semantics/procinterface04.f90
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Evaluate/shape.h
flang/include/flang/Evaluate/tools.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/shape.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Evaluate/variable.cpp
flang/lib/Lower/ConvertType.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/data-to-inits.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/lib/Semantics/pointer-assignment.h
flang/test/Semantics/block-data01.f90
flang/test/Semantics/c_loc01.f90
flang/test/Semantics/call02.f90
flang/test/Semantics/call09.f90
flang/test/Semantics/io11.f90
flang/test/Semantics/modfile49.f90
flang/test/Semantics/procinterface01.f90
flang/test/Semantics/procinterface02.f90
flang/test/Semantics/reduce01.f90
flang/test/Semantics/resolve114.f90
flang/test/Semantics/resolve46.f90
flang/test/Semantics/resolve59.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 8f87868441b02c..932f3220c2bcbb 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -81,23 +81,24 @@ class TypeAndShape {
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 @@ class TypeAndShape {
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 @@ class TypeAndShape {
}
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 @@ class TypeAndShape {
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 &);
diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h
index dce24b7cb052b5..5acc7f13d27da5 100644
--- a/flang/include/flang/Evaluate/shape.h
+++ b/flang/include/flang/Evaluate/shape.h
@@ -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);
-MaybeExtentExpr GetExtent(
- const Subscript &, 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(
- 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 @@ class GetShapeHelper
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 @@ class GetShapeHelper
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 @@ class GetShapeHelper
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
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 0a9e7ce87be38e..b3f8f4a67a7b5d 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -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 &);
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 694f6a1abf4cb4..8d52eabc16d502 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -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) {
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 45c54b37dd1d55..fd549dd8165599 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -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(
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index c86498fa413f43..ada26ac46af836 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -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 @@ class GetLowerBoundHelper
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 @@ class GetLowerBoundHelper
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 @@ class GetLowerBoundHelper
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(
+ const NamedEntity &base, int dimension, bool invariantOnly) {
+ return GetLowerBoundHelper<ExtentExpr, false>{
+ dimension, nullptr, invariantOnly}(base);
}
-ExtentExpr GetRawLowerBound(
- FoldingContext &context, const NamedEntity &base, int dimension) {
+ExtentExpr GetRawLowerBound(FoldingContext &context, const NamedEntity &base,
+ int dimension, bool invariantOnly) {
return Fold(context,
- GetLowerBoundHelper<ExtentExpr, false>{dimension, &context}(base));
+ GetLowerBoundHelper<ExtentExpr, false>{
+ dimension, &context, invariantOnly}(base));
}
-MaybeExtentExpr GetLBOUND(const NamedEntity &base, int dimension) {
- return GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, nullptr}(base);
+MaybeExtentExpr GetLBOUND(
+ const NamedEntity &base, int dimension, bool invariantOnly) {
+ return GetLowerBoundHelper<MaybeExtentExpr, true>{
+ dimension, nullptr, invariantOnly}(base);
}
-MaybeExtentExpr GetLBOUND(
- FoldingContext &context, const NamedEntity &base, int dimension) {
+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(
+ const NamedEntity &base, int dimension, bool invariantOnly) {
+ return GetUBOUND(nullptr, base, dimension, invariantOnly);
}
-MaybeExtentExpr GetUBOUND(
- FoldingContext &context, const NamedEntity &base, int dimension) {
- return Fold(context, GetUBOUND(&context, base, dimension));
+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) {
+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(
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 86777ac44745ef..d2fa5c9b5f36be 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -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) {
diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp
index 083b6bae575895..29483b103054c8 100644
--- a/flang/lib/Evaluate/variable.cpp
+++ b/flang/lib/Evaluate/variable.cpp
@@ -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;
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index 9dfe982a650489..e8179b43afc7d1 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -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;
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 62efd8b49d385d..e7e091ed024c48 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -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);
}
diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp
index 04088f915efc54..6fbe044aa4618d 100644
--- a/flang/lib/Semantics/data-to-inits.cpp
+++ b/flang/lib/Semantics/data-to-inits.cpp
@@ -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;
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index ba63159cee97cf..e75e9366942115 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -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);
diff --git a/flang/lib/Semantics/pointer-assignment.h b/flang/lib/Semantics/pointer-assignment.h
index c6f89c4949146c..5ac258d03a0a26 100644
--- a/flang/lib/Semantics/pointer-assignment.h
+++ b/flang/lib/Semantics/pointer-assignment.h
@@ -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
diff --git a/flang/test/Semantics/block-data01.f90 b/flang/test/Semantics/block-data01.f90
index 4c8b8b7bf8bb7e..7065bff75ddf75 100644
--- a/flang/test/Semantics/block-data01.f90
+++ b/flang/test/Semantics/block-data01.f90
@@ -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
diff --git a/flang/test/Semantics/c_loc01.f90 b/flang/test/Semantics/c_loc01.f90
index 21fd1eb14e6df2..774ebc2f382e92 100644
--- a/flang/test/Semantics/c_loc01.f90
+++ b/flang/test/Semantics/c_loc01.f90
@@ -11,6 +11,7 @@ subroutine test(assumedType, poly, nclen)
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
diff --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90
index 264a79f8983a55..902b8883b723c2 100644
--- a/flang/test/Semantics/call02.f90
+++ b/flang/test/Semantics/call02.f90
@@ -8,6 +8,7 @@ elemental real function elem(x)
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 badsubr(dummy)
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
diff --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90
index a4b2b64f0f4eb1..463f03bc62ff48 100644
--- a/flang/test/Semantics/call09.f90
+++ b/flang/test/Semantics/call09.f90
@@ -37,6 +37,7 @@ subroutine s05(p)
end subroutine
subroutine selemental1(p)
+ !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
procedure(cos) :: p ! ok
end subroutine
diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90
index 413283cdfc72bd..6c002e4db41da0 100644
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -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(:)
diff --git a/flang/test/Semantics/modfile49.f90 b/flang/test/Semantics/modfile49.f90
index 9c48c8a480128d..2069d21aad92b2 100644
--- a/flang/test/Semantics/modfile49.f90
+++ b/flang/test/Semantics/modfile49.f90
@@ -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 @@ function fun() result(res)
!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
diff --git a/flang/test/Semantics/procinterface01.f90 b/flang/test/Semantics/procinterface01.f90
index 3363fbc69ccc0f..73040b0987bd0e 100644
--- a/flang/test/Semantics/procinterface01.f90
+++ b/flang/test/Semantics/procinterface01.f90
@@ -48,7 +48,7 @@ end function tan
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 @@ end function tan
!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)
diff --git a/flang/test/Semantics/procinterface02.f90 b/flang/test/Semantics/procinterface02.f90
index 3f73e2e75f8db5..ca0c62c150d44e 100644
--- a/flang/test/Semantics/procinterface02.f90
+++ b/flang/test/Semantics/procinterface02.f90
@@ -12,6 +12,7 @@ real function foo_nonelemental(x)
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)
diff --git a/flang/test/Semantics/procinterface04.f90 b/flang/test/Semantics/procinterface04.f90
new file mode 100644
index 00000000000000..5bc5413375d90e
--- /dev/null
+++ b/flang/test/Semantics/procinterface04.f90
@@ -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
diff --git a/flang/test/Semantics/reduce01.f90 b/flang/test/Semantics/reduce01.f90
index fe58004ff30af5..8c5a46312ec0a5 100644
--- a/flang/test/Semantics/reduce01.f90
+++ b/flang/test/Semantics/reduce01.f90
@@ -70,13 +70,13 @@ subroutine errors
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)
diff --git a/flang/test/Semantics/resolve114.f90 b/flang/test/Semantics/resolve114.f90
index d7022e697e1109..02923e32a2a148 100644
--- a/flang/test/Semantics/resolve114.f90
+++ b/flang/test/Semantics/resolve114.f90
@@ -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 @@ module m4
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
diff --git a/flang/test/Semantics/resolve46.f90 b/flang/test/Semantics/resolve46.f90
index 0f8d3b1c423c2b..784ffa427031c8 100644
--- a/flang/test/Semantics/resolve46.f90
+++ b/flang/test/Semantics/resolve46.f90
@@ -20,6 +20,7 @@ logical function chrcmp(a,b)
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 @@ end function chrcmp
!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
diff --git a/flang/test/Semantics/resolve59.f90 b/flang/test/Semantics/resolve59.f90
index 7458710c52d9c5..aae0aff5f072e4 100644
--- a/flang/test/Semantics/resolve59.f90
+++ b/flang/test/Semantics/resolve59.f90
@@ -114,6 +114,7 @@ function f4() result(r)
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
More information about the flang-commits
mailing list