[flang-commits] [flang] 864cb2a - [flang] Semantics for !DIR$ IGNORE_TKR
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Apr 19 09:39:48 PDT 2023
Author: Peter Klausler
Date: 2023-04-19T09:39:37-07:00
New Revision: 864cb2aa451480b6d1907fd7bc4262c72b537a7c
URL: https://github.com/llvm/llvm-project/commit/864cb2aa451480b6d1907fd7bc4262c72b537a7c
DIFF: https://github.com/llvm/llvm-project/commit/864cb2aa451480b6d1907fd7bc4262c72b537a7c.diff
LOG: [flang] Semantics for !DIR$ IGNORE_TKR
Implement semantics for the IGNORE_TKR directive as it is interpreted
by the PGI / NVFORTRAN compiler.
Differential Revision: https://reviews.llvm.org/D148643
Added:
flang/test/Semantics/ignore_tkr01.f90
Modified:
flang/docs/Directives.md
flang/include/flang/Common/Fortran-features.h
flang/include/flang/Common/Fortran.h
flang/include/flang/Common/enum-class.h
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Evaluate/tools.h
flang/include/flang/Evaluate/type.h
flang/include/flang/Parser/parse-tree-visitor.h
flang/include/flang/Parser/parse-tree.h
flang/include/flang/Semantics/symbol.h
flang/lib/Common/Fortran.cpp
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Evaluate/type.cpp
flang/lib/Parser/Fortran-parsers.cpp
flang/lib/Parser/unparse.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/mod-file.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/symbol.cpp
Removed:
################################################################################
diff --git a/flang/docs/Directives.md b/flang/docs/Directives.md
index a1a99b674cef2..c8a2c087dfad1 100644
--- a/flang/docs/Directives.md
+++ b/flang/docs/Directives.md
@@ -12,4 +12,20 @@ A list of non-standard directives supported by Flang
* `!dir$ fixed` and `!dir$ free` select Fortran source forms. Their effect
persists to the end of the current source file.
-* `!dir$ ignore_tkr (tkr) var-list` omits checks on type, kind, and/or rank.
+* `!dir$ ignore_tkr [[(TKRDMAC)] dummy-arg-name]...` in an interface definition
+ disables some semantic checks at call sites for the actual arguments that
+ correspond to some named dummy arguments (or all of them, by default).
+ The directive allow actual arguments that would otherwise be diagnosed
+ as incompatible in type (T), kind (K), rank (R), CUDA device (D), or
+ managed (M) status. The letter (A) is a shorthand for all of these,
+ and is the default when no letters appear. The letter (C) is a legacy
+ no-op. For example, if one wanted to call a "set all bytes to zero"
+ utility that could be applied to arrays of any type or rank:
+```
+ interface
+ subroutine clear(arr,bytes)
+!dir$ ignore_tkr arr
+ integer(1), intent(out) :: arr(bytes)
+ end
+ end interface
+```
diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h
index 6cf90f518b91e..390a971859233 100644
--- a/flang/include/flang/Common/Fortran-features.h
+++ b/flang/include/flang/Common/Fortran-features.h
@@ -12,6 +12,7 @@
#include "flang/Common/Fortran.h"
#include "flang/Common/enum-set.h"
#include "flang/Common/idioms.h"
+#include <vector>
namespace Fortran::common {
diff --git a/flang/include/flang/Common/Fortran.h b/flang/include/flang/Common/Fortran.h
index 92d2b48f71242..49235cda89633 100644
--- a/flang/include/flang/Common/Fortran.h
+++ b/flang/include/flang/Common/Fortran.h
@@ -12,9 +12,10 @@
// Fortran language concepts that are used in many phases are defined
// once here to avoid redundancy and needless translation.
+#include "enum-set.h"
#include "idioms.h"
#include <cinttypes>
-#include <vector>
+#include <string>
namespace Fortran::common {
@@ -81,5 +82,21 @@ static constexpr int maxRank{15};
// Fortran names may have up to 63 characters (See Fortran 2018 C601).
static constexpr int maxNameLen{63};
+// !DIR$ IGNORE_TKR [[(letters) name] ... letters
+// "A" expands to all of TKRDM
+ENUM_CLASS(IgnoreTKR,
+ Type, // T - don't check type category
+ Kind, // K - don't check kind
+ Rank, // R - don't check ranks
+ Device, // D - don't check host/device residence
+ Managed, // M - don't check managed storage
+ Contiguous) // C - legacy; disabled NVFORTRAN's convention that leading
+ // dimension of assumed-shape was contiguous
+using IgnoreTKRSet = EnumSet<IgnoreTKR, 8>;
+// IGNORE_TKR(A) = IGNORE_TKR(TKRDM)
+static constexpr IgnoreTKRSet ignoreTKRAll{IgnoreTKR::Type, IgnoreTKR::Kind,
+ IgnoreTKR::Rank, IgnoreTKR::Device, IgnoreTKR::Managed};
+std::string AsFortran(IgnoreTKRSet);
+
} // namespace Fortran::common
#endif // FORTRAN_COMMON_FORTRAN_H_
diff --git a/flang/include/flang/Common/enum-class.h b/flang/include/flang/Common/enum-class.h
index 8077520938b31..bb1fcfa6274c6 100644
--- a/flang/include/flang/Common/enum-class.h
+++ b/flang/include/flang/Common/enum-class.h
@@ -12,7 +12,7 @@
// enum class className { enum1, enum2, ... , enumN };
// as well as the introspective utilities
// static constexpr std::size_t className_enumSize{N};
-// static inline const std::string &EnumToString(className);
+// static inline const std::string_view EnumToString(className);
#ifndef FORTRAN_COMMON_ENUM_CLASS_H_
#define FORTRAN_COMMON_ENUM_CLASS_H_
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index b6447135084fe..46cc6f23bddc0 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -219,6 +219,7 @@ struct DummyDataObject {
std::vector<Expr<SubscriptInteger>> coshape;
common::Intent intent{common::Intent::Default};
Attrs attrs;
+ common::IgnoreTKRSet ignoreTKR;
};
// 15.3.2.3
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index fa525197f00e9..dfc811fa28564 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1235,6 +1235,8 @@ const Symbol *FindFunctionResult(const Symbol &);
// but identical derived types.
bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
+common::IgnoreTKRSet GetIgnoreTKR(const Symbol &);
+
} // namespace Fortran::semantics
#endif // FORTRAN_EVALUATE_TOOLS_H_
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index c8baa635ea6ef..4b13a3155ab00 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -37,7 +37,12 @@ class DeclTypeSpec;
class DerivedTypeSpec;
class ParamValue;
class Symbol;
+// IsDescriptor() is true when an object requires the use of a descriptor
+// in memory when "at rest". IsPassedViaDescriptor() is sometimes false
+// when IsDescriptor() is true, including the cases of CHARACTER dummy
+// arguments and explicit & assumed-size dummy arrays.
bool IsDescriptor(const Symbol &);
+bool IsPassedViaDescriptor(const Symbol &);
} // namespace Fortran::semantics
namespace Fortran::evaluate {
@@ -190,6 +195,7 @@ class DynamicType {
// relation. Kind type parameters must match, but CHARACTER lengths
// need not do so.
bool IsTkCompatibleWith(const DynamicType &) const;
+ bool IsTkCompatibleWith(const DynamicType &, common::IgnoreTKRSet) const;
// A stronger compatibility check that does not allow distinct known
// values for CHARACTER lengths for e.g. MOVE_ALLOC().
diff --git a/flang/include/flang/Parser/parse-tree-visitor.h b/flang/include/flang/Parser/parse-tree-visitor.h
index 75466e6c621e3..073e71c6487b3 100644
--- a/flang/include/flang/Parser/parse-tree-visitor.h
+++ b/flang/include/flang/Parser/parse-tree-visitor.h
@@ -60,17 +60,6 @@ template <typename V> void Walk(const format::IntrinsicTypeDataEditDesc &, V &);
template <typename M> void Walk(format::IntrinsicTypeDataEditDesc &, M &);
// Traversal of needed STL template classes (optional, list, tuple, variant)
-template <typename T, typename V>
-void Walk(const std::optional<T> &x, V &visitor) {
- if (x) {
- Walk(*x, visitor);
- }
-}
-template <typename T, typename M> void Walk(std::optional<T> &x, M &mutator) {
- if (x) {
- Walk(*x, mutator);
- }
-}
// For most lists, just traverse the elements; but when a list constitutes
// a Block (i.e., std::list<ExecutionPartConstruct>), also invoke the
// visitor/mutator on the list itself.
@@ -100,6 +89,17 @@ template <typename M> void Walk(Block &x, M &mutator) {
mutator.Post(x);
}
}
+template <typename T, typename V>
+void Walk(const std::optional<T> &x, V &visitor) {
+ if (x) {
+ Walk(*x, visitor);
+ }
+}
+template <typename T, typename M> void Walk(std::optional<T> &x, M &mutator) {
+ if (x) {
+ Walk(*x, mutator);
+ }
+}
template <std::size_t I = 0, typename Func, typename T>
void ForEachInTuple(const T &tuple, Func func) {
func(std::get<I>(tuple));
diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index 60c7f695ad66c..d729f444ef959 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -3230,14 +3230,14 @@ struct StmtFunctionStmt {
};
// Compiler directives
-// !DIR$ IGNORE_TKR [ [(tkr...)] name ]...
+// !DIR$ IGNORE_TKR [ [(tkrdmac...)] name ]...
// !DIR$ LOOP COUNT (n1[, n2]...)
// !DIR$ name...
struct CompilerDirective {
UNION_CLASS_BOILERPLATE(CompilerDirective);
struct IgnoreTKR {
TUPLE_CLASS_BOILERPLATE(IgnoreTKR);
- std::tuple<std::list<const char *>, Name> t;
+ std::tuple<std::optional<std::list<const char *>>, Name> t;
};
struct LoopCount {
WRAPPER_CLASS_BOILERPLATE(LoopCount, std::list<std::uint64_t>);
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 281c1903ad397..ddeb73f09af15 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -112,6 +112,8 @@ class SubprogramDetails : public WithBindName {
CHECK(result_ != nullptr);
result_ = &result;
}
+ bool defaultIgnoreTKR() const { return defaultIgnoreTKR_; }
+ void set_defaultIgnoreTKR(bool yes) { defaultIgnoreTKR_ = yes; }
private:
bool isInterface_{false}; // true if this represents an interface-body
@@ -124,6 +126,7 @@ class SubprogramDetails : public WithBindName {
// interface. For MODULE PROCEDURE, this is the declared interface if it
// appeared in an ancestor (sub)module.
Symbol *moduleInterface_{nullptr};
+ bool defaultIgnoreTKR_{false};
friend llvm::raw_ostream &operator<<(
llvm::raw_ostream &, const SubprogramDetails &);
@@ -216,6 +219,8 @@ class ObjectEntityDetails : public EntityDetails {
void set_commonBlock(const Symbol &commonBlock) {
commonBlock_ = &commonBlock;
}
+ common::IgnoreTKRSet ignoreTKR() const { return ignoreTKR_; }
+ void set_ignoreTKR(common::IgnoreTKRSet set) { ignoreTKR_ = set; }
bool IsArray() const { return !shape_.empty(); }
bool IsCoarray() const { return !coshape_.empty(); }
bool CanBeAssumedShape() const {
@@ -230,6 +235,7 @@ class ObjectEntityDetails : public EntityDetails {
const parser::Expr *unanalyzedPDTComponentInit_{nullptr};
ArraySpec shape_;
ArraySpec coshape_;
+ common::IgnoreTKRSet ignoreTKR_;
const Symbol *commonBlock_{nullptr}; // common block this object is in
friend llvm::raw_ostream &operator<<(
llvm::raw_ostream &, const ObjectEntityDetails &);
diff --git a/flang/lib/Common/Fortran.cpp b/flang/lib/Common/Fortran.cpp
index 42c27c9eb53f2..e8d8fef9c49db 100644
--- a/flang/lib/Common/Fortran.cpp
+++ b/flang/lib/Common/Fortran.cpp
@@ -74,4 +74,27 @@ const char *AsFortran(DefinedIo x) {
}
}
+std::string AsFortran(IgnoreTKRSet tkr) {
+ std::string result;
+ if (tkr.test(IgnoreTKR::Type)) {
+ result += 'T';
+ }
+ if (tkr.test(IgnoreTKR::Kind)) {
+ result += 'K';
+ }
+ if (tkr.test(IgnoreTKR::Rank)) {
+ result += 'R';
+ }
+ if (tkr.test(IgnoreTKR::Device)) {
+ result += 'D';
+ }
+ if (tkr.test(IgnoreTKR::Managed)) {
+ result += 'M';
+ }
+ if (tkr.test(IgnoreTKR::Contiguous)) {
+ result += 'C';
+ }
+ return result;
+}
+
} // namespace Fortran::common
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 1906f5a446083..b8cb822866dbf 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -314,6 +314,11 @@ bool DummyDataObject::IsCompatibleWith(
}
return false;
}
+ if (ignoreTKR != actual.ignoreTKR) {
+ if (whyNot) {
+ *whyNot = "incompatible !DIR$ IGNORE_TKR directives";
+ }
+ }
return true;
}
@@ -331,8 +336,8 @@ static common::Intent GetIntent(const semantics::Attrs &attrs) {
std::optional<DummyDataObject> DummyDataObject::Characterize(
const semantics::Symbol &symbol, FoldingContext &context) {
- if (symbol.has<semantics::ObjectEntityDetails>() ||
- symbol.has<semantics::EntityDetails>()) {
+ if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
+ object || symbol.has<semantics::EntityDetails>()) {
if (auto type{TypeAndShape::Characterize(symbol, context)}) {
std::optional<DummyDataObject> result{std::move(*type)};
using semantics::Attr;
@@ -348,6 +353,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
{Attr::TARGET, DummyDataObject::Attr::Target},
});
result->intent = GetIntent(symbol.attrs());
+ result->ignoreTKR = GetIgnoreTKR(symbol);
return result;
}
}
@@ -1254,9 +1260,10 @@ class DistinguishUtils {
bool Distinguishable(const DummyDataObject &, const DummyDataObject &) const;
bool Distinguishable(const DummyProcedure &, const DummyProcedure &) const;
bool Distinguishable(const FunctionResult &, const FunctionResult &) const;
- bool Distinguishable(const TypeAndShape &, const TypeAndShape &) const;
+ bool Distinguishable(
+ const TypeAndShape &, const TypeAndShape &, common::IgnoreTKRSet) const;
bool IsTkrCompatible(const DummyArgument &, const DummyArgument &) const;
- bool IsTkrCompatible(const TypeAndShape &, const TypeAndShape &) const;
+ bool IsTkCompatible(const DummyDataObject &, const DummyDataObject &) const;
const DummyArgument *GetAtEffectivePosition(
const DummyArguments &, int) const;
const DummyArgument *GetPassArg(const Procedure &) const;
@@ -1432,7 +1439,7 @@ bool DistinguishUtils::Distinguishable(
bool DistinguishUtils::Distinguishable(
const DummyDataObject &x, const DummyDataObject &y) const {
using Attr = DummyDataObject::Attr;
- if (Distinguishable(x.type, y.type)) {
+ if (Distinguishable(x.type, y.type, x.ignoreTKR | y.ignoreTKR)) {
return true;
} else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
y.intent != common::Intent::In) {
@@ -1481,7 +1488,8 @@ bool DistinguishUtils::Distinguishable(
return common::visit(
common::visitors{
[&](const TypeAndShape &z) {
- return Distinguishable(z, std::get<TypeAndShape>(y.u));
+ return Distinguishable(
+ z, std::get<TypeAndShape>(y.u), common::IgnoreTKRSet{});
},
[&](const CopyableIndirection<Procedure> &z) {
return Distinguishable(z.value(),
@@ -1491,24 +1499,39 @@ bool DistinguishUtils::Distinguishable(
x.u);
}
-bool DistinguishUtils::Distinguishable(
- const TypeAndShape &x, const TypeAndShape &y) const {
- return !IsTkrCompatible(x, y) && !IsTkrCompatible(y, x);
+bool DistinguishUtils::Distinguishable(const TypeAndShape &x,
+ const TypeAndShape &y, common::IgnoreTKRSet ignoreTKR) const {
+ if (!x.type().IsTkCompatibleWith(y.type(), ignoreTKR) &&
+ !y.type().IsTkCompatibleWith(x.type(), ignoreTKR)) {
+ return true;
+ }
+ if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
+ } else if (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
+ y.attrs().test(TypeAndShape::Attr::AssumedRank)) {
+ } else if (x.Rank() != y.Rank()) {
+ return true;
+ }
+ return false;
}
// Compatibility based on type, kind, and rank
+
bool DistinguishUtils::IsTkrCompatible(
const DummyArgument &x, const DummyArgument &y) const {
const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
- return obj1 && obj2 && IsTkrCompatible(obj1->type, obj2->type);
+ return obj1 && obj2 && IsTkCompatible(*obj1, *obj2) &&
+ (obj1->type.Rank() == obj2->type.Rank() ||
+ obj1->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
+ obj2->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
+ obj1->ignoreTKR.test(common::IgnoreTKR::Rank) ||
+ obj2->ignoreTKR.test(common::IgnoreTKR::Rank));
}
-bool DistinguishUtils::IsTkrCompatible(
- const TypeAndShape &x, const TypeAndShape &y) const {
- return x.type().IsTkCompatibleWith(y.type()) &&
- (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
- y.attrs().test(TypeAndShape::Attr::AssumedRank) ||
- x.Rank() == y.Rank());
+
+bool DistinguishUtils::IsTkCompatible(
+ const DummyDataObject &x, const DummyDataObject &y) const {
+ return x.type.type().IsTkCompatibleWith(
+ y.type.type(), x.ignoreTKR | y.ignoreTKR);
}
// Return the argument at the given index, ignoring the passed arg
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 27aa700e07256..5d7129b32fc0b 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1657,4 +1657,19 @@ bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y) {
return false;
}
+common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {
+ common::IgnoreTKRSet result;
+ if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ result = object->ignoreTKR();
+ if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {
+ if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()}) {
+ if (ownerSubp->defaultIgnoreTKR()) {
+ result |= common::ignoreTKRAll;
+ }
+ }
+ }
+ }
+ return result;
+}
+
} // namespace Fortran::semantics
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 4cc1cb173f223..936e85b636004 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -88,6 +88,36 @@ bool IsDescriptor(const Symbol &symbol) {
},
symbol.details());
}
+
+bool IsPassedViaDescriptor(const Symbol &symbol) {
+ if (!IsDescriptor(symbol)) {
+ return false;
+ }
+ if (const auto *object{
+ symbol.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
+ if (object->isDummy()) {
+ if (object->type() &&
+ object->type()->category() == DeclTypeSpec::Character) {
+ return false;
+ }
+ if (object->IsAssumedSize()) {
+ return false;
+ }
+ bool isExplicitShape{true};
+ for (const ShapeSpec &shapeSpec : object->shape()) {
+ if (!shapeSpec.lbound().GetExplicit() ||
+ !shapeSpec.ubound().GetExplicit()) {
+ isExplicitShape = false;
+ break;
+ }
+ }
+ if (isExplicitShape) {
+ return false; // explicit shape but non-constant bounds
+ }
+ }
+ }
+ return true;
+}
} // namespace Fortran::semantics
namespace Fortran::evaluate {
@@ -473,6 +503,21 @@ bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
return AreCompatibleTypes(*this, that, false, true);
}
+bool DynamicType::IsTkCompatibleWith(
+ const DynamicType &that, common::IgnoreTKRSet ignoreTKR) const {
+ if (ignoreTKR.test(common::IgnoreTKR::Type) &&
+ (category() == TypeCategory::Derived ||
+ that.category() == TypeCategory::Derived ||
+ category() != that.category())) {
+ return true;
+ } else if (ignoreTKR.test(common::IgnoreTKR::Kind) &&
+ category() == that.category()) {
+ return true;
+ } else {
+ return AreCompatibleTypes(*this, that, false, true);
+ }
+}
+
bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const {
return AreCompatibleTypes(*this, that, false, false);
}
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 1e7d7deed0a4f..e7208e60afbf6 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -1213,14 +1213,14 @@ TYPE_PARSER(construct<StatOrErrmsg>("STAT =" >> statVariable) ||
construct<StatOrErrmsg>("ERRMSG =" >> msgVariable))
// Directives, extensions, and deprecated statements
-// !DIR$ IGNORE_TKR [ [(tkr...)] name ]...
+// !DIR$ IGNORE_TKR [ [(tkrdmac...)] name ]...
// !DIR$ LOOP COUNT (n1[, n2]...)
// !DIR$ name...
constexpr auto beginDirective{skipStuffBeforeStatement >> "!"_ch};
constexpr auto endDirective{space >> endOfLine};
constexpr auto ignore_tkr{
"DIR$ IGNORE_TKR" >> optionalList(construct<CompilerDirective::IgnoreTKR>(
- defaulted(parenthesized(some("tkr"_ch))), name))};
+ maybe(parenthesized(many(letter))), name))};
constexpr auto loopCount{
"DIR$ LOOP COUNT" >> construct<CompilerDirective::LoopCount>(
parenthesized(nonemptyList(digitString64)))};
diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp
index c70dc56b2ec58..6916052cf78d6 100644
--- a/flang/lib/Parser/unparse.cpp
+++ b/flang/lib/Parser/unparse.cpp
@@ -1794,10 +1794,10 @@ class UnparseVisitor {
Put('\n');
}
void Unparse(const CompilerDirective::IgnoreTKR &x) {
- const auto &list{std::get<std::list<const char *>>(x.t)};
- if (!list.empty()) {
+ if (const auto &maybeList{
+ std::get<std::optional<std::list<const char *>>>(x.t)}) {
Put("(");
- for (const char *tkr : list) {
+ for (const char *tkr : *maybeList) {
Put(*tkr);
}
Put(") ");
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 4d2a118596e17..2d1c167249061 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -204,7 +204,14 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (allowActualArgumentConversions) {
ConvertIntegerActual(actual, dummy.type, actualType, messages);
}
- bool typesCompatible{dummy.type.type().IsTkCompatibleWith(actualType.type())};
+ bool typesCompatible{
+ (dummy.ignoreTKR.test(common::IgnoreTKR::Type) &&
+ (dummy.type.type().category() == TypeCategory::Derived ||
+ actualType.type().category() == TypeCategory::Derived ||
+ dummy.type.type().category() != actualType.type().category())) ||
+ (dummy.ignoreTKR.test(common::IgnoreTKR::Kind) &&
+ dummy.type.type().category() == actualType.type().category()) ||
+ dummy.type.type().IsTkCompatibleWith(actualType.type())};
if (!typesCompatible && dummy.type.Rank() == 0 &&
allowActualArgumentConversions) {
// Extension: pass Hollerith literal to scalar as if it had been BOZ
@@ -221,6 +228,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (isElemental) {
} else if (dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank)) {
+ } else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
} else if (dummy.type.Rank() > 0 && !dummyIsAllocatableOrPointer &&
!dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedShape) &&
@@ -378,7 +386,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (!actualIsCKindCharacter) {
if (!actualIsArrayElement &&
!(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&
- !dummyIsAssumedRank) {
+ !dummyIsAssumedRank &&
+ !dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
messages.Say(
"Whole scalar actual argument may not be associated with a %s array"_err_en_US,
dummyName);
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 9cfa96f47c2d6..5c40e012b62bf 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -702,14 +702,42 @@ void CheckHelper::CheckObjectEntity(
"non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
}
}
+ if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
+ if (IsAllocatableOrPointer(symbol)) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
+ } else if (ignoreTKR.test(common::IgnoreTKR::Contiguous) &&
+ !IsAssumedShape(symbol)) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR(C) may apply only to an assumed-shape array"_err_en_US);
+ } else if (ignoreTKR.test(common::IgnoreTKR::Rank) &&
+ IsPassedViaDescriptor(symbol)) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
+ } else if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {
+ if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()};
+ ownerSubp && !ownerSubp->isInterface() &&
+ !FindModuleContaining(symbol.owner())) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
+ } else if (ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
+ details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
+ }
+ }
+ }
} else if (symbol.attrs().test(Attr::INTENT_IN) ||
symbol.attrs().test(Attr::INTENT_OUT) ||
symbol.attrs().test(Attr::INTENT_INOUT)) {
- messages_.Say("INTENT attributes may apply only to a dummy "
- "argument"_err_en_US); // C843
+ messages_.Say(
+ "INTENT attributes may apply only to a dummy argument"_err_en_US); // C843
} else if (IsOptional(symbol)) {
- messages_.Say("OPTIONAL attribute may apply only to a dummy "
- "argument"_err_en_US); // C849
+ messages_.Say(
+ "OPTIONAL attribute may apply only to a dummy argument"_err_en_US); // C849
+ } else if (!details.ignoreTKR().empty()) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR directive may apply only to a dummy data argument"_err_en_US);
}
if (InElemental()) {
if (details.isDummy()) { // C15100
@@ -795,6 +823,11 @@ void CheckHelper::CheckObjectEntity(
}
}
}
+ if (symbol.attrs().test(Attr::EXTERNAL)) {
+ SayWithDeclaration(symbol,
+ "'%s' is a data object and may not be EXTERNAL"_err_en_US,
+ symbol.name());
+ }
}
void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp
index 77ba4280a634b..8ff4469a78ec0 100644
--- a/flang/lib/Semantics/mod-file.cpp
+++ b/flang/lib/Semantics/mod-file.cpp
@@ -480,7 +480,6 @@ void ModFileWriter::PutSubprogram(const Symbol &symbol) {
}
}
os << '\n';
-
// walk symbols, collect ones needed for interface
const Scope &scope{
details.entryScope() ? *details.entryScope() : DEREF(symbol.scope())};
@@ -684,6 +683,33 @@ void ModFileWriter::PutObjectEntity(
PutShape(os, details.coshape(), '[', ']');
PutInit(os, symbol, details.init(), details.unanalyzedPDTComponentInit());
os << '\n';
+ if (auto tkr{GetIgnoreTKR(symbol)}; !tkr.empty()) {
+ os << "!dir$ ignore_tkr(";
+ tkr.IterateOverMembers([&](common::IgnoreTKR tkr) {
+ switch (tkr) {
+ SWITCH_COVERS_ALL_CASES
+ case common::IgnoreTKR::Type:
+ os << 't';
+ break;
+ case common::IgnoreTKR::Kind:
+ os << 'k';
+ break;
+ case common::IgnoreTKR::Rank:
+ os << 'r';
+ break;
+ case common::IgnoreTKR::Device:
+ os << 'd';
+ break;
+ case common::IgnoreTKR::Managed:
+ os << 'm';
+ break;
+ case common::IgnoreTKR::Contiguous:
+ os << 'c';
+ break;
+ }
+ });
+ os << ") " << symbol.name() << '\n';
+ }
}
void ModFileWriter::PutProcEntity(llvm::raw_ostream &os, const Symbol &symbol) {
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 35f71242d7831..820b3d8fda0b6 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1505,6 +1505,7 @@ class ResolveNamesVisitor : public virtual ScopeHandler,
bool Pre(const parser::ProgramUnit &);
void Post(const parser::AssignStmt &);
void Post(const parser::AssignedGotoStmt &);
+ void Post(const parser::CompilerDirective &);
// These nodes should never be reached: they are handled in ProgramUnit
bool Pre(const parser::MainProgram &) {
@@ -7713,6 +7714,96 @@ void ResolveNamesVisitor::Post(const parser::AssignedGotoStmt &x) {
}
}
+void ResolveNamesVisitor::Post(const parser::CompilerDirective &x) {
+ if (const auto *tkr{
+ std::get_if<std::list<parser::CompilerDirective::IgnoreTKR>>(&x.u)}) {
+ if (currScope().IsTopLevel() ||
+ GetProgramUnitContaining(currScope()).kind() !=
+ Scope::Kind::Subprogram) {
+ Say(x.source,
+ "!DIR$ IGNORE_TKR directive must appear in a subroutine or function"_err_en_US);
+ return;
+ }
+ if (!inSpecificationPart_) {
+ Say(x.source,
+ "!DIR$ IGNORE_TKR directive must appear in the specification part"_err_en_US);
+ return;
+ }
+ if (tkr->empty()) {
+ Symbol *symbol{currScope().symbol()};
+ if (SubprogramDetails *
+ subp{symbol ? symbol->detailsIf<SubprogramDetails>() : nullptr}) {
+ subp->set_defaultIgnoreTKR(true);
+ }
+ } else {
+ for (const parser::CompilerDirective::IgnoreTKR &item : *tkr) {
+ common::IgnoreTKRSet set;
+ if (const auto &maybeList{
+ std::get<std::optional<std::list<const char *>>>(item.t)}) {
+ for (const char *p : *maybeList) {
+ if (p) {
+ switch (*p) {
+ case 't':
+ set.set(common::IgnoreTKR::Type);
+ break;
+ case 'k':
+ set.set(common::IgnoreTKR::Kind);
+ break;
+ case 'r':
+ set.set(common::IgnoreTKR::Rank);
+ break;
+ case 'd':
+ set.set(common::IgnoreTKR::Device);
+ break;
+ case 'm':
+ set.set(common::IgnoreTKR::Managed);
+ break;
+ case 'c':
+ set.set(common::IgnoreTKR::Contiguous);
+ break;
+ case 'a':
+ set = common::ignoreTKRAll;
+ break;
+ default:
+ Say(x.source,
+ "'%c' is not a valid letter for !DIR$ IGNORE_TKR directive"_err_en_US,
+ *p);
+ set = common::ignoreTKRAll;
+ break;
+ }
+ }
+ }
+ if (set.empty()) {
+ Say(x.source,
+ "!DIR$ IGNORE_TKR directive may not have an empty parenthesized list of letters"_err_en_US);
+ }
+ } else { // no (list)
+ set = common::ignoreTKRAll;
+ ;
+ }
+ const auto &name{std::get<parser::Name>(item.t)};
+ Symbol *symbol{FindSymbol(name)};
+ if (!symbol) {
+ symbol = &MakeSymbol(name, Attrs{}, ObjectEntityDetails{});
+ }
+ if (symbol->owner() != currScope()) {
+ SayWithDecl(
+ name, *symbol, "'%s' must be local to this subprogram"_err_en_US);
+ } else {
+ ConvertToObjectEntity(*symbol);
+ if (auto *object{symbol->detailsIf<ObjectEntityDetails>()}) {
+ object->set_ignoreTKR(set);
+ } else {
+ SayWithDecl(name, *symbol, "'%s' must be an object"_err_en_US);
+ }
+ }
+ }
+ }
+ } else {
+ Say(x.source, "Compiler directive was ignored"_warn_en_US);
+ }
+}
+
bool ResolveNamesVisitor::Pre(const parser::ProgramUnit &x) {
if (std::holds_alternative<common::Indirection<parser::CompilerDirective>>(
x.u)) {
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 6822cba0c090b..ca917531165cb 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -125,6 +125,9 @@ llvm::raw_ostream &operator<<(
if (x.moduleInterface_) {
os << " moduleInterface: " << *x.moduleInterface_;
}
+ if (x.defaultIgnoreTKR_) {
+ os << " defaultIgnoreTKR";
+ }
return os;
}
@@ -407,6 +410,10 @@ llvm::raw_ostream &operator<<(
if (x.unanalyzedPDTComponentInit()) {
os << " (has unanalyzedPDTComponentInit)";
}
+ if (!x.ignoreTKR_.empty()) {
+ os << ' ';
+ x.ignoreTKR_.Dump(os, common::EnumToString);
+ }
return os;
}
diff --git a/flang/test/Semantics/ignore_tkr01.f90 b/flang/test/Semantics/ignore_tkr01.f90
new file mode 100644
index 0000000000000..6540ba1d394fc
--- /dev/null
+++ b/flang/test/Semantics/ignore_tkr01.f90
@@ -0,0 +1,202 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! !DIR$ IGNORE_TKR tests
+
+!ERROR: !DIR$ IGNORE_TKR directive must appear in a subroutine or function
+!dir$ ignore_tkr
+
+module m
+
+!ERROR: !DIR$ IGNORE_TKR directive must appear in a subroutine or function
+!dir$ ignore_tkr
+
+ interface
+ subroutine t1(x)
+!dir$ ignore_tkr
+ real, intent(in) :: x
+ end
+
+ subroutine t2(x)
+!dir$ ignore_tkr(t) x
+ real, intent(in) :: x
+ end
+
+ subroutine t3(x)
+!dir$ ignore_tkr(k) x
+ real, intent(in) :: x
+ end
+
+ subroutine t4(a)
+!dir$ ignore_tkr(r) a
+ real, intent(in) :: a(2)
+ end
+
+ subroutine t5(m)
+!dir$ ignore_tkr(r) m
+ real, intent(in) :: m(2,2)
+ end
+
+ subroutine t6(x)
+!dir$ ignore_tkr(a) x
+ real, intent(in) :: x
+ end
+
+ subroutine t7(x)
+!ERROR: !DIR$ IGNORE_TKR directive may not have an empty parenthesized list of letters
+!dir$ ignore_tkr() x
+ real, intent(in) :: x
+ end
+
+ subroutine t8(x)
+!dir$ ignore_tkr x
+ real, intent(in) :: x
+ end
+
+ subroutine t9(x)
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+ real, intent(in), allocatable :: x
+ end
+
+ subroutine t10(x)
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+ real, intent(in), pointer :: x
+ end
+
+ subroutine t11
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR directive may apply only to a dummy data argument
+ real :: x
+ end
+
+ subroutine t12(p,q,r)
+!dir$ ignore_tkr p, q
+!ERROR: 'p' is a data object and may not be EXTERNAL
+ real, external :: p
+!ERROR: 'q' is already declared as an object
+ procedure(real) :: q
+ procedure(), pointer :: r
+!ERROR: 'r' must be an object
+!dir$ ignore_tkr r
+ end
+
+ elemental subroutine t13(x)
+!dir$ ignore_tkr(r) x
+!ERROR: !DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure
+ real, intent(in) :: x
+ end
+
+ end interface
+
+ contains
+ subroutine t14(x)
+ real x
+ x = x + 1.
+!ERROR: !DIR$ IGNORE_TKR directive must appear in the specification part
+!dir$ ignore_tkr x
+ end
+
+ subroutine t15(x)
+!ERROR: 'q' is not a valid letter for !DIR$ IGNORE_TKR directive
+!dir$ ignore_tkr(q) x
+ real x
+ x = x + 1.
+ end
+
+ subroutine t16(x)
+ real x
+ contains
+ subroutine inner
+!ERROR: 'x' must be local to this subprogram
+!dir$ ignore_tkr x
+ end
+ end
+
+ subroutine t17(x)
+ real x
+ block
+!ERROR: 'x' must be local to this subprogram
+!dir$ ignore_tkr x
+ end block
+ end
+
+ subroutine t18(x)
+!dir$ ignore_tkr(c) x
+!ERROR: !DIR$ IGNORE_TKR(C) may apply only to an assumed-shape array
+ real x(1)
+ end
+
+ subroutine t19(x)
+!dir$ ignore_tkr(r) x
+!ERROR: !DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor
+ real x(..)
+ end
+
+end
+
+subroutine bad1(x)
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR may apply only in an interface or a module procedure
+ real, intent(in) :: x
+end
+
+program test
+
+!ERROR: !DIR$ IGNORE_TKR directive must appear in a subroutine or function
+!dir$ ignore_tkr
+
+ use m
+ real x
+ real a(2)
+ real m(2,2)
+ double precision dx
+
+ call t1(1)
+ call t1(dx)
+ call t1('a')
+ call t1((1.,2.))
+ call t1(.true.)
+
+ call t2(1)
+ !ERROR: Actual argument type 'REAL(8)' is not compatible with dummy argument type 'REAL(4)'
+ call t2(dx)
+ call t2('a')
+ call t2((1.,2.))
+ call t2(.true.)
+
+ !ERROR: Actual argument type 'INTEGER(4)' is not compatible with dummy argument type 'REAL(4)'
+ call t3(1)
+ call t3(dx)
+ !ERROR: passing Hollerith or character literal as if it were BOZ
+ call t3('a')
+ !ERROR: Actual argument type 'COMPLEX(4)' is not compatible with dummy argument type 'REAL(4)'
+ call t3((1.,2.))
+ !ERROR: Actual argument type 'LOGICAL(4)' is not compatible with dummy argument type 'REAL(4)'
+ call t3(.true.)
+
+ call t4(x)
+ call t4(m)
+ call t5(x)
+ call t5(a)
+
+ call t6(1)
+ call t6(dx)
+ call t6('a')
+ call t6((1.,2.))
+ call t6(.true.)
+ call t6(a)
+
+ call t8(1)
+ call t8(dx)
+ call t8('a')
+ call t8((1.,2.))
+ call t8(.true.)
+ call t8(a)
+
+ contains
+ subroutine inner(x)
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR may apply only in an interface or a module procedure
+ real, intent(in) :: x
+ end
+end
More information about the flang-commits
mailing list