diff --git a/flang/docs/Directives.md b/flang/docs/Directives.md --- a/flang/docs/Directives.md +++ b/flang/docs/Directives.md @@ -12,4 +12,20 @@ * `!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 --- 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 namespace Fortran::common { diff --git a/flang/include/flang/Common/Fortran.h b/flang/include/flang/Common/Fortran.h --- 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 -#include +#include namespace Fortran::common { @@ -81,5 +82,21 @@ // 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; +// 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 --- 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 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -219,6 +219,7 @@ std::vector> 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 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1235,6 +1235,8 @@ // 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 --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -37,7 +37,12 @@ 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 @@ // 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 --- a/flang/include/flang/Parser/parse-tree-visitor.h +++ b/flang/include/flang/Parser/parse-tree-visitor.h @@ -60,17 +60,6 @@ template void Walk(format::IntrinsicTypeDataEditDesc &, M &); // Traversal of needed STL template classes (optional, list, tuple, variant) -template -void Walk(const std::optional &x, V &visitor) { - if (x) { - Walk(*x, visitor); - } -} -template void Walk(std::optional &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), also invoke the // visitor/mutator on the list itself. @@ -100,6 +89,17 @@ mutator.Post(x); } } +template +void Walk(const std::optional &x, V &visitor) { + if (x) { + Walk(*x, visitor); + } +} +template void Walk(std::optional &x, M &mutator) { + if (x) { + Walk(*x, mutator); + } +} template void ForEachInTuple(const T &tuple, Func func) { func(std::get(tuple)); diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -3230,14 +3230,14 @@ }; // 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, Name> t; + std::tuple>, Name> t; }; struct LoopCount { WRAPPER_CLASS_BOILERPLATE(LoopCount, std::list); diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -112,6 +112,8 @@ 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 @@ // 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 @@ 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 @@ 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 --- a/flang/lib/Common/Fortran.cpp +++ b/flang/lib/Common/Fortran.cpp @@ -74,4 +74,27 @@ } } +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 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -314,6 +314,11 @@ } return false; } + if (ignoreTKR != actual.ignoreTKR) { + if (whyNot) { + *whyNot = "incompatible !DIR$ IGNORE_TKR directives"; + } + } return true; } @@ -331,8 +336,8 @@ std::optional DummyDataObject::Characterize( const semantics::Symbol &symbol, FoldingContext &context) { - if (symbol.has() || - symbol.has()) { + if (const auto *object{symbol.detailsIf()}; + object || symbol.has()) { if (auto type{TypeAndShape::Characterize(symbol, context)}) { std::optional result{std::move(*type)}; using semantics::Attr; @@ -348,6 +353,7 @@ {Attr::TARGET, DummyDataObject::Attr::Target}, }); result->intent = GetIntent(symbol.attrs()); + result->ignoreTKR = GetIgnoreTKR(symbol); return result; } } @@ -1254,9 +1260,10 @@ 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( 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 @@ return common::visit( common::visitors{ [&](const TypeAndShape &z) { - return Distinguishable(z, std::get(y.u)); + return Distinguishable( + z, std::get(y.u), common::IgnoreTKRSet{}); }, [&](const CopyableIndirection &z) { return Distinguishable(z.value(), @@ -1491,24 +1499,39 @@ 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(&x.u)}; const auto *obj2{std::get_if(&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 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1657,4 +1657,19 @@ return false; } +common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) { + common::IgnoreTKRSet result; + if (const auto *object{symbol.detailsIf()}) { + result = object->ignoreTKR(); + if (const Symbol * ownerSymbol{symbol.owner().symbol()}) { + if (const auto *ownerSubp{ownerSymbol->detailsIf()}) { + 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 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -88,6 +88,36 @@ }, symbol.details()); } + +bool IsPassedViaDescriptor(const Symbol &symbol) { + if (!IsDescriptor(symbol)) { + return false; + } + if (const auto *object{ + symbol.GetUltimate().detailsIf()}) { + 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 @@ 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 --- a/flang/lib/Parser/Fortran-parsers.cpp +++ b/flang/lib/Parser/Fortran-parsers.cpp @@ -1213,14 +1213,14 @@ construct("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( - defaulted(parenthesized(some("tkr"_ch))), name))}; + maybe(parenthesized(many(letter))), name))}; constexpr auto loopCount{ "DIR$ LOOP COUNT" >> construct( parenthesized(nonemptyList(digitString64)))}; diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp --- a/flang/lib/Parser/unparse.cpp +++ b/flang/lib/Parser/unparse.cpp @@ -1794,10 +1794,10 @@ Put('\n'); } void Unparse(const CompilerDirective::IgnoreTKR &x) { - const auto &list{std::get>(x.t)}; - if (!list.empty()) { + if (const auto &maybeList{ + std::get>>(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 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -204,7 +204,14 @@ 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 @@ 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 @@ 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 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -702,14 +702,42 @@ "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()}; + 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 @@ } } } + 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 --- a/flang/lib/Semantics/mod-file.cpp +++ b/flang/lib/Semantics/mod-file.cpp @@ -480,7 +480,6 @@ } } os << '\n'; - // walk symbols, collect ones needed for interface const Scope &scope{ details.entryScope() ? *details.entryScope() : DEREF(symbol.scope())}; @@ -684,6 +683,33 @@ 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 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1505,6 +1505,7 @@ 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::CompilerDirective &x) { + if (const auto *tkr{ + std::get_if>(&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() : nullptr}) { + subp->set_defaultIgnoreTKR(true); + } + } else { + for (const parser::CompilerDirective::IgnoreTKR &item : *tkr) { + common::IgnoreTKRSet set; + if (const auto &maybeList{ + std::get>>(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(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()}) { + 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>( x.u)) { diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -125,6 +125,9 @@ if (x.moduleInterface_) { os << " moduleInterface: " << *x.moduleInterface_; } + if (x.defaultIgnoreTKR_) { + os << " defaultIgnoreTKR"; + } return os; } @@ -407,6 +410,10 @@ 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 --- /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