shylie/llvm-project
1
0
Fork 0
Code Issues Pull Requests Actions 6 Packages Projects Releases Wiki Activity

[flang] Tag warnings with LanguageFeature or UsageWarning (#110304)

Browse Source 
(This is a big patch, but it's nearly an NFC. No test results have
changed and all Fortran tests in the LLVM test suites work as expected.)

Allow a parser::Message for a warning to be marked with the
common::LanguageFeature or common::UsageWarning that controls it. This
will allow a later patch to add hooks whereby a driver will be able to
decorate warning messages with the names of its options that enable each
particular warning, and to add hooks whereby a driver can map those
enumerators by name to command-line options that enable/disable the
language feature and enable/disable the messages.

The default settings in the constructor for LanguageFeatureControl were
moved from its header file into its C++ source file.

Hooks for a driver to use to map the name of a feature or warning to its
enumerator were also added.

To simplify the tagging of warnings with their corresponding language
feature or usage warning, to ensure that they are properly controlled by
ShouldWarn(), and to ensure that warnings never issue at code sites in
module files, two new Warn() member function templates were added to
SemanticsContext and other contextual frameworks. Warn() can't be used
before source locations can be mapped to scopes, but the bulk of
existing code blocks testing ShouldWarn() and FindModuleFile() before
calling Say() were convertible into calls to Warn(). The ones that were
not convertible were extended with explicit calls to
Message::set_languageFeature() and set_usageWarning().
This commit is contained in:
Peter Klausler 2024-10-02 08:54:49 -07:00 committed by GitHub
parent 4cd1f9ac9f
commit 0f973ac783
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
44 changed files with 1093 additions and 938 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
flang/include/flang/Common/Fortran-features.h
View File

@ -12,6 +12,7 @@
#include "flang/Common/Fortran.h"
#include "flang/Common/enum-set.h"
#include "flang/Common/idioms.h"
#include <optional>
#include <vector>
namespace Fortran::common {
@ -48,7 +49,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
ImpliedDoIndexScope, DistinctCommonSizes, OddIndexVariableRestrictions,
IndistinguishableSpecifics, SubroutineAndFunctionSpecifics,
EmptySequenceType, NonSequenceCrayPointee, BranchIntoConstruct,
BadBranchTarget, ConvertedArgument, HollerithPolymorphic, ListDirectedSize,
BadBranchTarget, HollerithPolymorphic, ListDirectedSize,
NonBindCInteroperability, CudaManaged, CudaUnified,
PolymorphicActualAllocatableOrPointerToMonomorphicDummy, RelaxedPureDummy,
UndefinableAsynchronousOrVolatileActual, AutomaticInMainProgram, PrintCptr,
@ -76,80 +77,12 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;
std::optional<LanguageFeature> FindLanguageFeature(const char *);
std::optional<UsageWarning> FindUsageWarning(const char *);
class LanguageFeatureControl {
public:
LanguageFeatureControl() {
// These features must be explicitly enabled by command line options.
disable_.set(LanguageFeature::OldDebugLines);
disable_.set(LanguageFeature::OpenACC);
disable_.set(LanguageFeature::OpenMP);
disable_.set(LanguageFeature::CUDA); // !@cuf
disable_.set(LanguageFeature::CudaManaged);
disable_.set(LanguageFeature::CudaUnified);
disable_.set(LanguageFeature::ImplicitNoneTypeNever);
disable_.set(LanguageFeature::ImplicitNoneTypeAlways);
disable_.set(LanguageFeature::DefaultSave);
disable_.set(LanguageFeature::SaveMainProgram);
// These features, if enabled, conflict with valid standard usage,
// so there are disabled here by default.
disable_.set(LanguageFeature::BackslashEscapes);
disable_.set(LanguageFeature::LogicalAbbreviations);
disable_.set(LanguageFeature::XOROperator);
disable_.set(LanguageFeature::OldStyleParameter);
// These warnings are enabled by default, but only because they used
// to be unconditional. TODO: prune this list
warnLanguage_.set(LanguageFeature::ExponentMatchingKindParam);
warnLanguage_.set(LanguageFeature::RedundantAttribute);
warnLanguage_.set(LanguageFeature::SubroutineAndFunctionSpecifics);
warnLanguage_.set(LanguageFeature::EmptySequenceType);
warnLanguage_.set(LanguageFeature::NonSequenceCrayPointee);
warnLanguage_.set(LanguageFeature::BranchIntoConstruct);
warnLanguage_.set(LanguageFeature::BadBranchTarget);
warnLanguage_.set(LanguageFeature::ConvertedArgument);
warnLanguage_.set(LanguageFeature::HollerithPolymorphic);
warnLanguage_.set(LanguageFeature::ListDirectedSize);
warnUsage_.set(UsageWarning::ShortArrayActual);
warnUsage_.set(UsageWarning::FoldingException);
warnUsage_.set(UsageWarning::FoldingAvoidsRuntimeCrash);
warnUsage_.set(UsageWarning::FoldingValueChecks);
warnUsage_.set(UsageWarning::FoldingFailure);
warnUsage_.set(UsageWarning::FoldingLimit);
warnUsage_.set(UsageWarning::Interoperability);
warnUsage_.set(UsageWarning::Bounds);
warnUsage_.set(UsageWarning::Preprocessing);
warnUsage_.set(UsageWarning::Scanning);
warnUsage_.set(UsageWarning::OpenAccUsage);
warnUsage_.set(UsageWarning::ProcPointerCompatibility);
warnUsage_.set(UsageWarning::VoidMold);
warnUsage_.set(UsageWarning::KnownBadImplicitInterface);
warnUsage_.set(UsageWarning::EmptyCase);
warnUsage_.set(UsageWarning::CaseOverflow);
warnUsage_.set(UsageWarning::CUDAUsage);
warnUsage_.set(UsageWarning::IgnoreTKRUsage);
warnUsage_.set(UsageWarning::ExternalInterfaceMismatch);
warnUsage_.set(UsageWarning::DefinedOperatorArgs);
warnUsage_.set(UsageWarning::Final);
warnUsage_.set(UsageWarning::ZeroDoStep);
warnUsage_.set(UsageWarning::UnusedForallIndex);
warnUsage_.set(UsageWarning::OpenMPUsage);
warnUsage_.set(UsageWarning::ModuleFile);
warnUsage_.set(UsageWarning::DataLength);
warnUsage_.set(UsageWarning::IgnoredDirective);
warnUsage_.set(UsageWarning::HomonymousSpecific);
warnUsage_.set(UsageWarning::HomonymousResult);
warnUsage_.set(UsageWarning::IgnoredIntrinsicFunctionType);
warnUsage_.set(UsageWarning::PreviousScalarUse);
warnUsage_.set(UsageWarning::RedeclaredInaccessibleComponent);
warnUsage_.set(UsageWarning::ImplicitShared);
warnUsage_.set(UsageWarning::IndexVarRedefinition);
warnUsage_.set(UsageWarning::IncompatibleImplicitInterfaces);
warnUsage_.set(UsageWarning::BadTypeForTarget);
warnUsage_.set(UsageWarning::VectorSubscriptFinalization);
warnUsage_.set(UsageWarning::UndefinedFunctionResult);
warnUsage_.set(UsageWarning::UselessIomsg);
// New warnings, on by default
warnLanguage_.set(LanguageFeature::SavedLocalInSpecExpr);
}
LanguageFeatureControl();
LanguageFeatureControl(const LanguageFeatureControl &) = default;
void Enable(LanguageFeature f, bool yes = true) { disable_.set(f, !yes); }

90
flang/include/flang/Parser/message.h
View File

@ -15,6 +15,7 @@
#include "char-block.h"
#include "char-set.h"
#include "provenance.h"
#include "flang/Common/Fortran-features.h"
#include "flang/Common/idioms.h"
#include "flang/Common/reference-counted.h"
#include "flang/Common/restorer.h"
@ -202,6 +203,26 @@ public:
Message(ProvenanceRange pr, const MessageExpectedText &t)
: location_{pr}, text_{t} {}
Message(common::LanguageFeature feature, ProvenanceRange pr,
const MessageFixedText &t)
: location_{pr}, text_{t}, languageFeature_{feature} {}
Message(common::LanguageFeature feature, ProvenanceRange pr,
const MessageFormattedText &s)
: location_{pr}, text_{s}, languageFeature_{feature} {}
Message(common::LanguageFeature feature, ProvenanceRange pr,
MessageFormattedText &&s)
: location_{pr}, text_{std::move(s)}, languageFeature_{feature} {}
Message(common::UsageWarning warning, ProvenanceRange pr,
const MessageFixedText &t)
: location_{pr}, text_{t}, usageWarning_{warning} {}
Message(common::UsageWarning warning, ProvenanceRange pr,
const MessageFormattedText &s)
: location_{pr}, text_{s}, usageWarning_{warning} {}
Message(common::UsageWarning warning, ProvenanceRange pr,
MessageFormattedText &&s)
: location_{pr}, text_{std::move(s)}, usageWarning_{warning} {}
Message(CharBlock csr, const MessageFixedText &t)
: location_{csr}, text_{t} {}
Message(CharBlock csr, const MessageFormattedText &s)
@ -211,10 +232,41 @@ public:
Message(CharBlock csr, const MessageExpectedText &t)
: location_{csr}, text_{t} {}
Message(
common::LanguageFeature feature, CharBlock csr, const MessageFixedText &t)
: location_{csr}, text_{t}, languageFeature_{feature} {}
Message(common::LanguageFeature feature, CharBlock csr,
const MessageFormattedText &s)
: location_{csr}, text_{s}, languageFeature_{feature} {}
Message(
common::LanguageFeature feature, CharBlock csr, MessageFormattedText &&s)
: location_{csr}, text_{std::move(s)}, languageFeature_{feature} {}
Message(
common::UsageWarning warning, CharBlock csr, const MessageFixedText &t)
: location_{csr}, text_{t}, usageWarning_{warning} {}
Message(common::UsageWarning warning, CharBlock csr,
const MessageFormattedText &s)
: location_{csr}, text_{s}, usageWarning_{warning} {}
Message(common::UsageWarning warning, CharBlock csr, MessageFormattedText &&s)
: location_{csr}, text_{std::move(s)}, usageWarning_{warning} {}
template <typename RANGE, typename A, typename... As>
Message(RANGE r, const MessageFixedText &t, A &&x, As &&...xs)
: location_{r}, text_{MessageFormattedText{
t, std::forward<A>(x), std::forward<As>(xs)...}} {}
template <typename RANGE, typename A, typename... As>
Message(common::LanguageFeature feature, RANGE r, const MessageFixedText &t,
A &&x, As &&...xs)
: location_{r}, text_{MessageFormattedText{
t, std::forward<A>(x), std::forward<As>(xs)...}},
languageFeature_{feature} {}
template <typename RANGE, typename A, typename... As>
Message(common::UsageWarning warning, RANGE r, const MessageFixedText &t,
A &&x, As &&...xs)
: location_{r}, text_{MessageFormattedText{
t, std::forward<A>(x), std::forward<As>(xs)...}},
usageWarning_{warning} {}
Reference attachment() const { return attachment_; }
@ -232,6 +284,10 @@ public:
bool IsFatal() const;
Severity severity() const;
Message &set_severity(Severity);
std::optional<common::LanguageFeature> languageFeature() const;
Message &set_languageFeature(common::LanguageFeature);
std::optional<common::UsageWarning> usageWarning() const;
Message &set_usageWarning(common::UsageWarning);
std::string ToString() const;
std::optional<ProvenanceRange> GetProvenanceRange(
const AllCookedSources &) const;
@ -256,6 +312,8 @@ private:
text_;
bool attachmentIsContext_{false};
Reference attachment_;
std::optional<common::LanguageFeature> languageFeature_;
std::optional<common::UsageWarning> usageWarning_;
};
class Messages {
@ -275,6 +333,16 @@ public:
return messages_.emplace_back(std::forward<A>(args)...);
}
template <typename... A>
Message &Say(common::LanguageFeature feature, A &&...args) {
return Say(std::forward<A>(args)...).set_languageFeature(feature);
}
template <typename... A>
Message &Say(common::UsageWarning warning, A &&...args) {
return Say(std::forward<A>(args)...).set_usageWarning(warning);
}
void Annex(Messages &&that) {
messages_.splice(messages_.end(), that.messages_);
}
@ -330,6 +398,10 @@ public:
return common::ScopedSet(messages_, nullptr);
}
template <typename... A> Message *Say(A &&...args) {
return Say(at_, std::forward<A>(args)...);
}
template <typename... A> Message *Say(CharBlock at, A &&...args) {
if (messages_ != nullptr) {
auto &msg{messages_->Say(at, std::forward<A>(args)...)};
@ -347,8 +419,22 @@ public:
return Say(at.value_or(at_), std::forward<A>(args)...);
}
template <typename... A> Message *Say(A &&...args) {
return Say(at_, std::forward<A>(args)...);
template <typename... A>
Message *Say(common::LanguageFeature feature, A &&...args) {
Message *msg{Say(std::forward<A>(args)...)};
if (msg) {
msg->set_languageFeature(feature);
}
return msg;
}
template <typename... A>
Message *Say(common::UsageWarning warning, A &&...args) {
Message *msg{Say(std::forward<A>(args)...)};
if (msg) {
msg->set_usageWarning(warning);
}
return msg;
}
Message *Say(Message &&msg) {

10
flang/include/flang/Semantics/expression.h
View File

@ -123,6 +123,16 @@ public:
template <typename... A> parser::Message *Say(A &&...args) {
return GetContextualMessages().Say(std::forward<A>(args)...);
}
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(
FeatureOrUsageWarning warning, parser::CharBlock at, A &&...args) {
return context_.Warn(warning, at, std::forward<A>(args)...);
}
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(FeatureOrUsageWarning warning, A &&...args) {
return Warn(
warning, GetContextualMessages().at(), std::forward<A>(args)...);
}
template <typename T, typename... A>
parser::Message *SayAt(const T &parsed, A &&...args) {

20
flang/include/flang/Semantics/semantics.h
View File

@ -188,6 +188,24 @@ public:
return message;
}
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(
FeatureOrUsageWarning warning, parser::CharBlock at, A &&...args) {
if (languageFeatures_.ShouldWarn(warning) && !IsInModuleFile(at)) {
parser::Message &msg{
messages_.Say(warning, at, std::forward<A>(args)...)};
return &msg;
} else {
return nullptr;
}
}
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(FeatureOrUsageWarning warning, A &&...args) {
CHECK(location_);
return Warn(warning, *location_, std::forward<A>(args)...);
}
const Scope &FindScope(parser::CharBlock) const;
Scope &FindScope(parser::CharBlock);
void UpdateScopeIndex(Scope &, parser::CharBlock);
@ -270,7 +288,7 @@ private:
std::multimap<parser::CharBlock, Scope &, ScopeIndexComparator>;
ScopeIndex::iterator SearchScopeIndex(parser::CharBlock);
void CheckIndexVarRedefine(
parser::Message *CheckIndexVarRedefine(
const parser::CharBlock &, const Symbol &, parser::MessageFixedText &&);
void CheckError(const Symbol &);

125
flang/lib/Common/Fortran-features.cpp
View File

@ -12,6 +12,131 @@
namespace Fortran::common {
LanguageFeatureControl::LanguageFeatureControl() {
// These features must be explicitly enabled by command line options.
disable_.set(LanguageFeature::OldDebugLines);
disable_.set(LanguageFeature::OpenACC);
disable_.set(LanguageFeature::OpenMP);
disable_.set(LanguageFeature::CUDA); // !@cuf
disable_.set(LanguageFeature::CudaManaged);
disable_.set(LanguageFeature::CudaUnified);
disable_.set(LanguageFeature::ImplicitNoneTypeNever);
disable_.set(LanguageFeature::ImplicitNoneTypeAlways);
disable_.set(LanguageFeature::DefaultSave);
disable_.set(LanguageFeature::SaveMainProgram);
// These features, if enabled, conflict with valid standard usage,
// so there are disabled here by default.
disable_.set(LanguageFeature::BackslashEscapes);
disable_.set(LanguageFeature::LogicalAbbreviations);
disable_.set(LanguageFeature::XOROperator);
disable_.set(LanguageFeature::OldStyleParameter);
// These warnings are enabled by default, but only because they used
// to be unconditional. TODO: prune this list
warnLanguage_.set(LanguageFeature::ExponentMatchingKindParam);
warnLanguage_.set(LanguageFeature::RedundantAttribute);
warnLanguage_.set(LanguageFeature::SubroutineAndFunctionSpecifics);
warnLanguage_.set(LanguageFeature::EmptySequenceType);
warnLanguage_.set(LanguageFeature::NonSequenceCrayPointee);
warnLanguage_.set(LanguageFeature::BranchIntoConstruct);
warnLanguage_.set(LanguageFeature::BadBranchTarget);
warnLanguage_.set(LanguageFeature::HollerithPolymorphic);
warnLanguage_.set(LanguageFeature::ListDirectedSize);
warnUsage_.set(UsageWarning::ShortArrayActual);
warnUsage_.set(UsageWarning::FoldingException);
warnUsage_.set(UsageWarning::FoldingAvoidsRuntimeCrash);
warnUsage_.set(UsageWarning::FoldingValueChecks);
warnUsage_.set(UsageWarning::FoldingFailure);
warnUsage_.set(UsageWarning::FoldingLimit);
warnUsage_.set(UsageWarning::Interoperability);
warnUsage_.set(UsageWarning::Bounds);
warnUsage_.set(UsageWarning::Preprocessing);
warnUsage_.set(UsageWarning::Scanning);
warnUsage_.set(UsageWarning::OpenAccUsage);
warnUsage_.set(UsageWarning::ProcPointerCompatibility);
warnUsage_.set(UsageWarning::VoidMold);
warnUsage_.set(UsageWarning::KnownBadImplicitInterface);
warnUsage_.set(UsageWarning::EmptyCase);
warnUsage_.set(UsageWarning::CaseOverflow);
warnUsage_.set(UsageWarning::CUDAUsage);
warnUsage_.set(UsageWarning::IgnoreTKRUsage);
warnUsage_.set(UsageWarning::ExternalInterfaceMismatch);
warnUsage_.set(UsageWarning::DefinedOperatorArgs);
warnUsage_.set(UsageWarning::Final);
warnUsage_.set(UsageWarning::ZeroDoStep);
warnUsage_.set(UsageWarning::UnusedForallIndex);
warnUsage_.set(UsageWarning::OpenMPUsage);
warnUsage_.set(UsageWarning::ModuleFile);
warnUsage_.set(UsageWarning::DataLength);
warnUsage_.set(UsageWarning::IgnoredDirective);
warnUsage_.set(UsageWarning::HomonymousSpecific);
warnUsage_.set(UsageWarning::HomonymousResult);
warnUsage_.set(UsageWarning::IgnoredIntrinsicFunctionType);
warnUsage_.set(UsageWarning::PreviousScalarUse);
warnUsage_.set(UsageWarning::RedeclaredInaccessibleComponent);
warnUsage_.set(UsageWarning::ImplicitShared);
warnUsage_.set(UsageWarning::IndexVarRedefinition);
warnUsage_.set(UsageWarning::IncompatibleImplicitInterfaces);
warnUsage_.set(UsageWarning::BadTypeForTarget);
warnUsage_.set(UsageWarning::VectorSubscriptFinalization);
warnUsage_.set(UsageWarning::UndefinedFunctionResult);
warnUsage_.set(UsageWarning::UselessIomsg);
// New warnings, on by default
warnLanguage_.set(LanguageFeature::SavedLocalInSpecExpr);
}
// Ignore case and any inserted punctuation (like '-'/'_')
static std::optional<char> GetWarningChar(char ch) {
if (ch >= 'a' && ch <= 'z') {
return ch;
} else if (ch >= 'A' && ch <= 'Z') {
return ch - 'A' + 'a';
} else if (ch >= '0' && ch <= '9') {
return ch;
} else {
return std::nullopt;
}
}
static bool WarningNameMatch(const char *a, const char *b) {
while (true) {
auto ach{GetWarningChar(*a)};
while (!ach && *a) {
ach = GetWarningChar(*++a);
}
auto bch{GetWarningChar(*b)};
while (!bch && *b) {
bch = GetWarningChar(*++b);
}
if (!ach && !bch) {
return true;
} else if (!ach || !bch || *ach != *bch) {
return false;
}
++a, ++b;
}
}
template <typename ENUM, std::size_t N>
std::optional<ENUM> ScanEnum(const char *name) {
if (name) {
for (std::size_t j{0}; j < N; ++j) {
auto feature{static_cast<ENUM>(j)};
if (WarningNameMatch(name, EnumToString(feature).data())) {
return feature;
}
}
}
return std::nullopt;
}
std::optional<LanguageFeature> FindLanguageFeature(const char *name) {
return ScanEnum<LanguageFeature, LanguageFeature_enumSize>(name);
}
std::optional<UsageWarning> FindUsageWarning(const char *name) {
return ScanEnum<UsageWarning, UsageWarning_enumSize>(name);
}
std::vector<const char *> LanguageFeatureControl::GetNames(
LogicalOperator opr) const {
std::vector<const char *> result;

66
flang/lib/Evaluate/check-expression.cpp
View File

@ -412,6 +412,7 @@ std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
symbol.owner().context().ShouldWarn(
common::LanguageFeature::LogicalIntegerAssignment)) {
context.messages().Say(
common::LanguageFeature::LogicalIntegerAssignment,
"nonstandard usage: initialization of %s with %s"_port_en_US,
symTS->type().AsFortran(), x.GetType().value().AsFortran());
}
@ -565,7 +566,7 @@ public:
if (!scope_.IsModuleFile() &&
context_.languageFeatures().ShouldWarn(
common::LanguageFeature::SavedLocalInSpecExpr)) {
context_.messages().Say(
context_.messages().Say(common::LanguageFeature::SavedLocalInSpecExpr,
"specification expression refers to local object '%s' (initialized and saved)"_port_en_US,
ultimate.name().ToString());
}
@ -1102,44 +1103,53 @@ class StmtFunctionChecker
public:
using Result = std::optional<parser::Message>;
using Base = AnyTraverse<StmtFunctionChecker, Result>;
static constexpr auto feature{
common::LanguageFeature::StatementFunctionExtensions};
StmtFunctionChecker(const Symbol &sf, FoldingContext &context)
: Base{*this}, sf_{sf}, context_{context} {
if (!context_.languageFeatures().IsEnabled(
common::LanguageFeature::StatementFunctionExtensions)) {
if (!context_.languageFeatures().IsEnabled(feature)) {
severity_ = parser::Severity::Error;
} else if (context_.languageFeatures().ShouldWarn(
common::LanguageFeature::StatementFunctionExtensions)) {
} else if (context_.languageFeatures().ShouldWarn(feature)) {
severity_ = parser::Severity::Portability;
}
}
using Base::operator();
Result Return(parser::Message &&msg) const {
if (severity_) {
msg.set_severity(*severity_);
if (*severity_ != parser::Severity::Error) {
msg.set_languageFeature(feature);
}
}
return std::move(msg);
}
template <typename T> Result operator()(const ArrayConstructor<T> &) const {
if (severity_) {
auto msg{
"Statement function '%s' should not contain an array constructor"_port_en_US};
msg.set_severity(*severity_);
return parser::Message{sf_.name(), std::move(msg), sf_.name()};
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not contain an array constructor"_port_en_US,
sf_.name()});
} else {
return std::nullopt;
}
}
Result operator()(const StructureConstructor &) const {
if (severity_) {
auto msg{
"Statement function '%s' should not contain a structure constructor"_port_en_US};
msg.set_severity(*severity_);
return parser::Message{sf_.name(), std::move(msg), sf_.name()};
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not contain a structure constructor"_port_en_US,
sf_.name()});
} else {
return std::nullopt;
}
}
Result operator()(const TypeParamInquiry &) const {
if (severity_) {
auto msg{
"Statement function '%s' should not contain a type parameter inquiry"_port_en_US};
msg.set_severity(*severity_);
return parser::Message{sf_.name(), std::move(msg), sf_.name()};
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not contain a type parameter inquiry"_port_en_US,
sf_.name()});
} else {
return std::nullopt;
}
@ -1161,21 +1171,18 @@ public:
proc, context_, /*emitError=*/true)}) {
if (!chars->CanBeCalledViaImplicitInterface()) {
if (severity_) {
auto msg{
"Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US};
msg.set_severity(*severity_);
return parser::Message{
sf_.name(), std::move(msg), sf_.name(), symbol->name()};
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US,
sf_.name(), symbol->name()});
}
}
}
}
if (proc.Rank() > 0) {
if (severity_) {
auto msg{
"Statement function '%s' should not reference a function that returns an array"_port_en_US};
msg.set_severity(*severity_);
return parser::Message{sf_.name(), std::move(msg), sf_.name()};
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not reference a function that returns an array"_port_en_US,
sf_.name()});
}
}
return std::nullopt;
@ -1187,10 +1194,9 @@ public:
}
if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {
if (severity_) {
auto msg{
"Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US};
msg.set_severity(*severity_);
return parser::Message{sf_.name(), std::move(msg), sf_.name()};
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US,
sf_.name()});
}
}
}

16
flang/lib/Evaluate/common.cpp
View File

@ -15,23 +15,25 @@ namespace Fortran::evaluate {
void RealFlagWarnings(
FoldingContext &context, const RealFlags &flags, const char *operation) {
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
static constexpr auto warning{common::UsageWarning::FoldingException};
if (context.languageFeatures().ShouldWarn(warning)) {
if (flags.test(RealFlag::Overflow)) {
context.messages().Say("overflow on %s"_warn_en_US, operation);
context.messages().Say(warning, "overflow on %s"_warn_en_US, operation);
}
if (flags.test(RealFlag::DivideByZero)) {
if (std::strcmp(operation, "division") == 0) {
context.messages().Say("division by zero"_warn_en_US);
context.messages().Say(warning, "division by zero"_warn_en_US);
} else {
context.messages().Say("division by zero on %s"_warn_en_US, operation);
context.messages().Say(
warning, "division by zero on %s"_warn_en_US, operation);
}
}
if (flags.test(RealFlag::InvalidArgument)) {
context.messages().Say("invalid argument on %s"_warn_en_US, operation);
context.messages().Say(
warning, "invalid argument on %s"_warn_en_US, operation);
}
if (flags.test(RealFlag::Underflow)) {
context.messages().Say("underflow on %s"_warn_en_US, operation);
context.messages().Say(warning, "underflow on %s"_warn_en_US, operation);
}
}
}

4
flang/lib/Evaluate/fold-character.cpp
View File

@ -60,7 +60,7 @@ Expr<Type<TypeCategory::Character, KIND>> FoldIntrinsicFunction(
if (i.IsNegative() || i.BGE(Scalar<IntT>{0}.IBSET(8 * KIND))) {
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingValueChecks)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingValueChecks,
"%s(I=%jd) is out of range for CHARACTER(KIND=%d)"_warn_en_US,
parser::ToUpperCaseLetters(name),
static_cast<std::intmax_t>(i.ToInt64()), KIND);
@ -108,7 +108,7 @@ Expr<Type<TypeCategory::Character, KIND>> FoldIntrinsicFunction(
(1 << 20)) { // sanity limit of 1MiB
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingLimit)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingLimit,
"Result of REPEAT() is too large to compute at compilation time (%g characters)"_port_en_US,
static_cast<double>(n) * str.size());
}

2
flang/lib/Evaluate/fold-complex.cpp
View File

@ -31,7 +31,7 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
context, std::move(funcRef), *callable);
} else if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingFailure)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingFailure,
"%s(complex(kind=%d)) cannot be folded on host"_warn_en_US, name,
KIND);
}

26
flang/lib/Evaluate/fold-implementation.h
View File

@ -1735,7 +1735,7 @@ Expr<TO> FoldOperation(
if (converted.overflow &&
msvcWorkaround.context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
ctx.messages().Say(
ctx.messages().Say(common::UsageWarning::FoldingException,
"conversion of %s_%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
value->SignedDecimal(), Operand::kind, TO::kind,
converted.value.SignedDecimal());
@ -1746,7 +1746,7 @@ Expr<TO> FoldOperation(
if (msvcWorkaround.context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
if (converted.flags.test(RealFlag::InvalidArgument)) {
ctx.messages().Say(
ctx.messages().Say(common::UsageWarning::FoldingException,
"REAL(%d) to INTEGER(%d) conversion: invalid argument"_warn_en_US,
Operand::kind, TO::kind);
} else if (converted.flags.test(RealFlag::Overflow)) {
@ -1865,7 +1865,7 @@ Expr<T> FoldOperation(FoldingContext &context, Negate<T> &&x) {
if (negated.overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) negation overflowed"_warn_en_US, T::kind);
}
return Expr<T>{Constant<T>{std::move(negated.value)}};
@ -1907,7 +1907,7 @@ Expr<T> FoldOperation(FoldingContext &context, Add<T> &&x) {
if (sum.overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) addition overflowed"_warn_en_US, T::kind);
}
return Expr<T>{Constant<T>{sum.value}};
@ -1935,7 +1935,7 @@ Expr<T> FoldOperation(FoldingContext &context, Subtract<T> &&x) {
if (difference.overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) subtraction overflowed"_warn_en_US, T::kind);
}
return Expr<T>{Constant<T>{difference.value}};
@ -1963,7 +1963,7 @@ Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
if (product.SignedMultiplicationOverflowed() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) multiplication overflowed"_warn_en_US, T::kind);
}
return Expr<T>{Constant<T>{product.lower}};
@ -2009,7 +2009,7 @@ Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
if (quotAndRem.divisionByZero) {
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) division by zero"_warn_en_US, T::kind);
}
return Expr<T>{std::move(x)};
@ -2017,7 +2017,7 @@ Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
if (quotAndRem.overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) division overflowed"_warn_en_US, T::kind);
}
return Expr<T>{Constant<T>{quotAndRem.quotient}};
@ -2060,13 +2060,13 @@ Expr<T> FoldOperation(FoldingContext &context, Power<T> &&x) {
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
if (power.divisionByZero) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) zero to negative power"_warn_en_US, T::kind);
} else if (power.overflow) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) power overflowed"_warn_en_US, T::kind);
} else if (power.zeroToZero) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"INTEGER(%d) 0**0 is not defined"_warn_en_US, T::kind);
}
}
@ -2077,7 +2077,7 @@ Expr<T> FoldOperation(FoldingContext &context, Power<T> &&x) {
Constant<T>{(*callable)(context, folded->first, folded->second)}};
} else if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingFailure)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingFailure,
"Power for %s cannot be folded on host"_warn_en_US,
T{}.AsFortran());
}
@ -2163,7 +2163,7 @@ Expr<Type<TypeCategory::Real, KIND>> ToReal(
if (original != converted &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingValueChecks)) { // C1601
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingValueChecks,
"Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_warn_en_US);
}
} else if constexpr (IsNumericCategoryExpr<From>()) {

34
flang/lib/Evaluate/fold-integer.cpp
View File

@ -300,7 +300,7 @@ static Expr<T> FoldCount(FoldingContext &context, FunctionRef<T> &&ref) {
if (accumulator.overflow() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"Result of intrinsic function COUNT overflows its result type"_warn_en_US);
}
return Expr<T>{std::move(result)};
@ -562,7 +562,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
if (result.ToInt64() != n &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"Result of intrinsic function '%s' (%jd) overflows its result type"_warn_en_US,
name, std::intmax_t{n});
}
@ -575,7 +575,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
if (j.overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"abs(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);
}
return j.value;
@ -598,6 +598,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
common::UsageWarning::FoldingException,
"%s intrinsic folding overflow"_warn_en_US, name);
}
return y.value;
@ -646,7 +647,8 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
if (result.overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say("DIM intrinsic folding overflow"_warn_en_US);
context.messages().Say(common::UsageWarning::FoldingException,
"DIM intrinsic folding overflow"_warn_en_US);
}
return result.value;
}));
@ -708,7 +710,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
context.languageFeatures().ShouldWarn(
common::UsageWarning::Portability)) {
// Do not die, this was not checked before
context.messages().Say(
context.messages().Say(common::UsageWarning::Portability,
"Character in intrinsic function %s should have length one"_port_en_US,
name);
} else {
@ -1127,7 +1129,8 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
pConst->IsZero() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
context.messages().Say("MOD: P argument is zero"_warn_en_US);
context.messages().Say(common::UsageWarning::FoldingAvoidsRuntimeCrash,
"MOD: P argument is zero"_warn_en_US);
badPConst = true;
}
}
@ -1139,9 +1142,13 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
if (!badPConst && quotRem.divisionByZero) {
context.messages().Say("mod() by zero"_warn_en_US);
context.messages().Say(
common::UsageWarning::FoldingAvoidsRuntimeCrash,
"mod() by zero"_warn_en_US);
} else if (quotRem.overflow) {
context.messages().Say("mod() folding overflowed"_warn_en_US);
context.messages().Say(
common::UsageWarning::FoldingAvoidsRuntimeCrash,
"mod() folding overflowed"_warn_en_US);
}
}
return quotRem.remainder;
@ -1154,7 +1161,8 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
pConst->IsZero() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
context.messages().Say("MODULO: P argument is zero"_warn_en_US);
context.messages().Say(common::UsageWarning::FoldingAvoidsRuntimeCrash,
"MODULO: P argument is zero"_warn_en_US);
badPConst = true;
}
}
@ -1166,7 +1174,8 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
if (!badPConst && result.overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say("modulo() folding overflowed"_warn_en_US);
context.messages().Say(common::UsageWarning::FoldingException,
"modulo() folding overflowed"_warn_en_US);
}
return result.value;
}));
@ -1303,7 +1312,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
if (result.overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"sign(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);
}
return result.value;
@ -1363,7 +1372,8 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
if (intBytes != realBytes &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingValueChecks)) {
context.messages().Say(*context.moduleFileName(),
context.messages().Say(common::UsageWarning::FoldingValueChecks,
*context.moduleFileName(),
"NUMERIC_STORAGE_SIZE from ISO_FORTRAN_ENV is not well-defined when default INTEGER and REAL are not consistent due to compiler options"_warn_en_US);
}
return Expr<T>{8 * std::min(intBytes, realBytes)};

3
flang/lib/Evaluate/fold-logical.cpp
View File

@ -534,7 +534,8 @@ static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
context.languageFeatures().ShouldWarn(
common::UsageWarning::OptionalMustBePresent)) {
if (auto source{args[2]->sourceLocation()}) {
context.messages().Say(*source,
context.messages().Say(
common::UsageWarning::OptionalMustBePresent, *source,
"ROUND= argument to OUT_OF_RANGE() is an optional dummy argument that must be present at execution"_warn_en_US);
}
}

2
flang/lib/Evaluate/fold-matmul.h
View File

@ -95,7 +95,7 @@ static Expr<T> FoldMatmul(FoldingContext &context, FunctionRef<T> &&funcRef) {
if (overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"MATMUL of %s data overflowed during computation"_warn_en_US,
T::AsFortran());
}

36
flang/lib/Evaluate/fold-real.cpp
View File

@ -37,7 +37,7 @@ static Expr<T> FoldTransformationalBessel(
std::move(results), ConstantSubscripts{std::max(n2 - n1 + 1, 0)}}};
} else if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingFailure)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingFailure,
"%s(integer(kind=4), real(kind=%d)) cannot be folded on host"_warn_en_US,
name, T::kind);
}
@ -134,7 +134,7 @@ static Expr<Type<TypeCategory::Real, KIND>> FoldNorm2(FoldingContext &context,
if (norm2Accumulator.overflow() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"NORM2() of REAL(%d) data overflowed"_warn_en_US, KIND);
}
return Expr<T>{std::move(result)};
@ -167,7 +167,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
context, std::move(funcRef), *callable);
} else if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingFailure)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingFailure,
"%s(real(kind=%d)) cannot be folded on host"_warn_en_US, name, KIND);
}
} else if (name == "amax0" || name == "amin0" || name == "amin1" ||
@ -181,7 +181,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
context, std::move(funcRef), *callable);
} else if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingFailure)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingFailure,
"%s(real(kind=%d), real(kind%d)) cannot be folded on host"_warn_en_US,
name, KIND, KIND);
}
@ -193,7 +193,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
context, std::move(funcRef), *callable);
} else if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingFailure)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingFailure,
"%s(integer(kind=4), real(kind=%d)) cannot be folded on host"_warn_en_US,
name, KIND);
}
@ -213,7 +213,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
if (y.flags.test(RealFlag::Overflow) &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"complex ABS intrinsic folding overflow"_warn_en_US, name);
}
return y.value;
@ -237,7 +237,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
if (y.flags.test(RealFlag::Overflow) &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"%s intrinsic folding overflow"_warn_en_US, name);
}
return y.value;
@ -250,7 +250,8 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
if (result.flags.test(RealFlag::Overflow) &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say("DIM intrinsic folding overflow"_warn_en_US);
context.messages().Say(common::UsageWarning::FoldingException,
"DIM intrinsic folding overflow"_warn_en_US);
}
return result.value;
}));
@ -284,7 +285,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
if (result.flags.test(RealFlag::Overflow) &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"HYPOT intrinsic folding overflow"_warn_en_US);
}
return result.value;
@ -310,7 +311,8 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
pConst->IsZero() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
context.messages().Say("MOD: P argument is zero"_warn_en_US);
context.messages().Say(common::UsageWarning::FoldingAvoidsRuntimeCrash,
"MOD: P argument is zero"_warn_en_US);
badPConst = true;
}
}
@ -322,6 +324,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
context.messages().Say(
common::UsageWarning::FoldingAvoidsRuntimeCrash,
"second argument to MOD must not be zero"_warn_en_US);
}
return result.value;
@ -335,7 +338,8 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
pConst->IsZero() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
context.messages().Say("MODULO: P argument is zero"_warn_en_US);
context.messages().Say(common::UsageWarning::FoldingAvoidsRuntimeCrash,
"MODULO: P argument is zero"_warn_en_US);
badPConst = true;
}
}
@ -347,6 +351,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
context.messages().Say(
common::UsageWarning::FoldingAvoidsRuntimeCrash,
"second argument to MODULO must not be zero"_warn_en_US);
}
return result.value;
@ -362,7 +367,8 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
(sConst->IsZero() || sConst->IsNotANumber()) &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingValueChecks)) {
context.messages().Say("NEAREST: S argument is %s"_warn_en_US,
context.messages().Say(common::UsageWarning::FoldingValueChecks,
"NEAREST: S argument is %s"_warn_en_US,
sConst->IsZero() ? "zero" : "NaN");
badSConst = true;
}
@ -373,6 +379,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingValueChecks)) {
context.messages().Say(
common::UsageWarning::FoldingValueChecks,
"NEAREST: S argument is %s"_warn_en_US,
s.IsZero() ? "zero" : "NaN");
}
@ -381,6 +388,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
common::UsageWarning::FoldingException)) {
if (result.flags.test(RealFlag::InvalidArgument)) {
context.messages().Say(
common::UsageWarning::FoldingException,
"NEAREST intrinsic folding: bad argument"_warn_en_US);
}
}
@ -423,6 +431,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
common::UsageWarning::FoldingException,
"SCALE intrinsic folding overflow"_warn_en_US);
}
return result.value;
@ -475,6 +484,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingValueChecks)) {
context.messages().Say(
common::UsageWarning::FoldingValueChecks,
"IEEE_NEXT_AFTER intrinsic folding: arguments are unordered"_warn_en_US);
}
return x.NotANumber();
@ -500,7 +510,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
if (result.flags.test(RealFlag::InvalidArgument)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"%s intrinsic folding: argument is NaN"_warn_en_US, iName);
}
}

6
flang/lib/Evaluate/fold-reduction.h
View File

@ -108,7 +108,7 @@ static Expr<T> FoldDotProduct(
if (overflow &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"DOT_PRODUCT of %s data overflowed during computation"_warn_en_US,
T::AsFortran());
}
@ -326,7 +326,7 @@ static Expr<T> FoldProduct(
if (accumulator.overflow() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"PRODUCT() of %s data overflowed"_warn_en_US, T::AsFortran());
}
return result;
@ -394,7 +394,7 @@ static Expr<T> FoldSum(FoldingContext &context, FunctionRef<T> &&ref) {
if (accumulator.overflow() &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingException)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingException,
"SUM() of %s data overflowed"_warn_en_US, T::AsFortran());
}
return result;

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

@ -102,7 +102,7 @@ void HostFloatingPointEnvironment::SetUpHostFloatingPointEnvironment(
fesetround(FE_TONEAREST);
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::FoldingFailure)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::FoldingFailure,
"TiesAwayFromZero rounding mode is not available when folding "
"constants"
" with host runtime; using TiesToEven instead"_warn_en_US);

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

@ -2375,10 +2375,10 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::OptionalMustBePresent)) {
if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
messages.Say(
messages.Say(common::UsageWarning::OptionalMustBePresent,
"The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_warn_en_US);
} else {
messages.Say(
messages.Say(common::UsageWarning::OptionalMustBePresent,
"The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning"_warn_en_US);
}
}
@ -2851,11 +2851,11 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
if (context.languageFeatures().ShouldWarn(
common::UsageWarning::Interoperability)) {
if (type->IsUnlimitedPolymorphic()) {
context.messages().Say(at,
context.messages().Say(common::UsageWarning::Interoperability, at,
"FPTR= argument to C_F_POINTER() should not be unlimited polymorphic"_warn_en_US);
} else if (!type->GetDerivedTypeSpec().typeSymbol().attrs().test(
semantics::Attr::BIND_C)) {
context.messages().Say(at,
context.messages().Say(common::UsageWarning::Interoperability, at,
"FPTR= argument to C_F_POINTER() should not have a derived type that is not BIND(C)"_warn_en_US);
}
}
@ -2864,7 +2864,7 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
.value_or(true) &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::Interoperability)) {
context.messages().Say(at,
context.messages().Say(common::UsageWarning::Interoperability, at,
"FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type %s"_warn_en_US,
type->AsFortran());
}
@ -2966,7 +2966,8 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
!IsInteroperableIntrinsicType(typeAndShape->type()).value_or(true) &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::Interoperability)) {
context.messages().Say(arguments[0]->sourceLocation(),
context.messages().Say(common::UsageWarning::Interoperability,
arguments[0]->sourceLocation(),
"C_LOC() argument has non-interoperable intrinsic type, kind, or length"_warn_en_US);
}
@ -3311,6 +3312,8 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
common::LanguageFeature::
UseGenericIntrinsicWhenSpecificDoesntMatch)) {
context.messages().Say(
common::LanguageFeature::
UseGenericIntrinsicWhenSpecificDoesntMatch,
"Argument types do not match specific intrinsic '%s' requirements; using '%s' generic instead and converting the result to %s if needed"_port_en_US,
call.name, genericName, newType.AsFortran());
}

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

@ -215,7 +215,7 @@ std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
if (!result) { // error cases
if (*lbi < 1) {
if (context.languageFeatures().ShouldWarn(common::UsageWarning::Bounds)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::Bounds,
"Lower bound (%jd) on substring is less than one"_warn_en_US,
static_cast<std::intmax_t>(*lbi));
}
@ -224,7 +224,7 @@ std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
}
if (length && *ubi > *length) {
if (context.languageFeatures().ShouldWarn(common::UsageWarning::Bounds)) {
context.messages().Say(
context.messages().Say(common::UsageWarning::Bounds,
"Upper bound (%jd) on substring is greater than character length (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*ubi),
static_cast<std::intmax_t>(*length));

18
flang/lib/Parser/message.cpp
View File

@ -185,6 +185,24 @@ Message &Message::set_severity(Severity severity) {
return *this;
}
std::optional<common::LanguageFeature> Message::languageFeature() const {
return languageFeature_;
}
Message &Message::set_languageFeature(common::LanguageFeature feature) {
languageFeature_ = feature;
return *this;
}
std::optional<common::UsageWarning> Message::usageWarning() const {
return usageWarning_;
}
Message &Message::set_usageWarning(common::UsageWarning warning) {
usageWarning_ = warning;
return *this;
}
std::string Message::ToString() const {
return common::visit(
common::visitors{

18
flang/lib/Parser/preprocessor.cpp
View File

@ -610,7 +610,8 @@ void Preprocessor::Directive(const TokenSequence &dir, Prescanner &prescanner) {
if (dir.IsAnythingLeft(++j)) {
if (prescanner.features().ShouldWarn(
common::UsageWarning::Portability)) {
prescanner.Say(dir.GetIntervalProvenanceRange(j, tokens - j),
prescanner.Say(common::UsageWarning::Portability,
dir.GetIntervalProvenanceRange(j, tokens - j),
"#undef: excess tokens at end of directive"_port_en_US);
}
} else {
@ -627,7 +628,8 @@ void Preprocessor::Directive(const TokenSequence &dir, Prescanner &prescanner) {
if (dir.IsAnythingLeft(++j)) {
if (prescanner.features().ShouldWarn(
common::UsageWarning::Portability)) {
prescanner.Say(dir.GetIntervalProvenanceRange(j, tokens - j),
prescanner.Say(common::UsageWarning::Portability,
dir.GetIntervalProvenanceRange(j, tokens - j),
"#%s: excess tokens at end of directive"_port_en_US, dirName);
}
}
@ -649,7 +651,8 @@ void Preprocessor::Directive(const TokenSequence &dir, Prescanner &prescanner) {
} else if (dirName == "else") {
if (dir.IsAnythingLeft(j)) {
if (prescanner.features().ShouldWarn(common::UsageWarning::Portability)) {
prescanner.Say(dir.GetIntervalProvenanceRange(j, tokens - j),
prescanner.Say(common::UsageWarning::Portability,
dir.GetIntervalProvenanceRange(j, tokens - j),
"#else: excess tokens at end of directive"_port_en_US);
}
} else if (ifStack_.empty()) {
@ -678,7 +681,8 @@ void Preprocessor::Directive(const TokenSequence &dir, Prescanner &prescanner) {
} else if (dirName == "endif") {
if (dir.IsAnythingLeft(j)) {
if (prescanner.features().ShouldWarn(common::UsageWarning::Portability)) {
prescanner.Say(dir.GetIntervalProvenanceRange(j, tokens - j),
prescanner.Say(common::UsageWarning::Portability,
dir.GetIntervalProvenanceRange(j, tokens - j),
"#endif: excess tokens at end of directive"_port_en_US);
}
} else if (ifStack_.empty()) {
@ -729,7 +733,8 @@ void Preprocessor::Directive(const TokenSequence &dir, Prescanner &prescanner) {
if (k >= pathTokens) {
if (prescanner.features().ShouldWarn(
common::UsageWarning::Portability)) {
prescanner.Say(dir.GetIntervalProvenanceRange(j, tokens - j),
prescanner.Say(common::UsageWarning::Portability,
dir.GetIntervalProvenanceRange(j, tokens - j),
"#include: expected '>' at end of included file"_port_en_US);
}
}
@ -758,7 +763,8 @@ void Preprocessor::Directive(const TokenSequence &dir, Prescanner &prescanner) {
k = path.SkipBlanks(k + 1);
if (k < pathTokens && path.TokenAt(k).ToString() != "!") {
if (prescanner.features().ShouldWarn(common::UsageWarning::Portability)) {
prescanner.Say(dir.GetIntervalProvenanceRange(j, tokens - j),
prescanner.Say(common::UsageWarning::Portability,
dir.GetIntervalProvenanceRange(j, tokens - j),
"#include: extra stuff ignored after file name"_port_en_US);
}
}

28
flang/lib/Parser/prescan.cpp
View File

@ -243,7 +243,8 @@ void Prescanner::Statement() {
}
if (continuationLines_ > 255) {
if (features_.ShouldWarn(common::LanguageFeature::MiscSourceExtensions)) {
Say(GetProvenance(statementStart),
Say(common::LanguageFeature::MiscSourceExtensions,
GetProvenance(statementStart),
"%d continuation lines is more than the Fortran standard allows"_port_en_US,
continuationLines_);
}
@ -265,7 +266,8 @@ void Prescanner::Statement() {
case LineClassification::Kind::DefinitionDirective:
case LineClassification::Kind::PreprocessorDirective:
if (features_.ShouldWarn(common::UsageWarning::Preprocessing)) {
Say(preprocessed->GetProvenanceRange(),
Say(common::UsageWarning::Preprocessing,
preprocessed->GetProvenanceRange(),
"Preprocessed line resembles a preprocessor directive"_warn_en_US);
}
CheckAndEmitLine(preprocessed->ToLowerCase(), newlineProvenance);
@ -400,7 +402,7 @@ void Prescanner::LabelField(TokenSequence &token) {
// CookedSource::Marshal().
cooked_.MarkPossibleFixedFormContinuation();
} else if (features_.ShouldWarn(common::UsageWarning::Scanning)) {
Say(GetProvenance(start + *badColumn - 1),
Say(common::UsageWarning::Scanning, GetProvenance(start + *badColumn - 1),
*badColumn == 6
? "Statement should not begin with a continuation line"_warn_en_US
: "Character in fixed-form label field must be a digit"_warn_en_US);
@ -424,7 +426,7 @@ void Prescanner::LabelField(TokenSequence &token) {
SkipToNextSignificantCharacter();
if (IsDecimalDigit(*at_)) {
if (features_.ShouldWarn(common::LanguageFeature::MiscSourceExtensions)) {
Say(GetCurrentProvenance(),
Say(common::LanguageFeature::MiscSourceExtensions, GetCurrentProvenance(),
"Label digit is not in fixed-form label field"_port_en_US);
}
}
@ -627,7 +629,7 @@ bool Prescanner::NextToken(TokenSequence &tokens) {
// Recognize and skip over classic C style /*comments*/ when
// outside a character literal.
if (features_.ShouldWarn(LanguageFeature::ClassicCComments)) {
Say(GetCurrentProvenance(),
Say(LanguageFeature::ClassicCComments, GetCurrentProvenance(),
"nonstandard usage: C-style comment"_port_en_US);
}
SkipCComments();
@ -795,7 +797,8 @@ bool Prescanner::NextToken(TokenSequence &tokens) {
if (IsDecimalDigit(*at_)) {
if (features_.ShouldWarn(
common::LanguageFeature::MiscSourceExtensions)) {
Say(GetProvenanceRange(at_, at_ + 1),
Say(common::LanguageFeature::MiscSourceExtensions,
GetProvenanceRange(at_, at_ + 1),
"Label should be in the label field"_port_en_US);
}
}
@ -923,7 +926,7 @@ void Prescanner::Hollerith(
if (PadOutCharacterLiteral(tokens)) {
} else if (*at_ == '\n') {
if (features_.ShouldWarn(common::UsageWarning::Scanning)) {
Say(GetProvenanceRange(start, at_),
Say(common::UsageWarning::Scanning, GetProvenanceRange(start, at_),
"Possible truncated Hollerith literal"_warn_en_US);
}
break;
@ -1087,7 +1090,7 @@ void Prescanner::FortranInclude(const char *firstQuote) {
for (; *p != '\n' && *p != '!'; ++p) {
}
if (features_.ShouldWarn(common::UsageWarning::Scanning)) {
Say(GetProvenanceRange(garbage, p),
Say(common::UsageWarning::Scanning, GetProvenanceRange(garbage, p),
"excess characters after path name"_warn_en_US);
}
}
@ -1228,7 +1231,8 @@ const char *Prescanner::FixedFormContinuationLine(bool mightNeedSpace) {
// Extension: '&' as continuation marker
if (features_.ShouldWarn(
LanguageFeature::FixedFormContinuationWithColumn1Ampersand)) {
Say(GetProvenance(nextLine_), "nonstandard usage"_port_en_US);
Say(LanguageFeature::FixedFormContinuationWithColumn1Ampersand,
GetProvenance(nextLine_), "nonstandard usage"_port_en_US);
}
return nextLine_ + 1;
}
@ -1294,7 +1298,8 @@ const char *Prescanner::FreeFormContinuationLine(bool ampersand) {
// 'b'
if (features_.ShouldWarn(
common::LanguageFeature::MiscSourceExtensions)) {
Say(GetProvenanceRange(p, p + 1),
Say(common::LanguageFeature::MiscSourceExtensions,
GetProvenanceRange(p, p + 1),
"Character literal continuation line should have been preceded by '&'"_port_en_US);
}
} else if (p > nextLine_) {
@ -1339,7 +1344,8 @@ bool Prescanner::FreeFormContinuation() {
} else if (ampersand && isPossibleMacroCall_ && (*p == ',' || *p == ')')) {
return false; // allow & at end of a macro argument
} else if (features_.ShouldWarn(LanguageFeature::CruftAfterAmpersand)) {
Say(GetProvenance(p), "missing ! before comment after &"_warn_en_US);
Say(LanguageFeature::CruftAfterAmpersand, GetProvenance(p),
"missing ! before comment after &"_warn_en_US);
}
}
do {

28
flang/lib/Semantics/check-acc-structure.cpp
View File

@ -409,16 +409,12 @@ void AccStructureChecker::CheckMultipleOccurrenceInDeclare(
if (const auto *name = getDesignatorNameIfDataRef(designator)) {
if (declareSymbols.contains(&name->symbol->GetUltimate())) {
if (declareSymbols[&name->symbol->GetUltimate()] == clause) {
if (context_.languageFeatures().ShouldWarn(
common::UsageWarning::OpenAccUsage)) {
context_.Say(GetContext().clauseSource,
"'%s' in the %s clause is already present in the "
"same "
"clause in this module"_warn_en_US,
name->symbol->name(),
parser::ToUpperCaseLetters(
llvm::acc::getOpenACCClauseName(clause).str()));
}
context_.Warn(common::UsageWarning::OpenAccUsage,
GetContext().clauseSource,
"'%s' in the %s clause is already present in the same clause in this module"_warn_en_US,
name->symbol->name(),
parser::ToUpperCaseLetters(
llvm::acc::getOpenACCClauseName(clause).str()));
} else {
context_.Say(GetContext().clauseSource,
"'%s' in the %s clause is already present in another "
@ -770,10 +766,8 @@ void AccStructureChecker::Enter(const parser::AccClause::Link &x) {
}
void AccStructureChecker::Enter(const parser::AccClause::Shortloop &x) {
if (CheckAllowed(llvm::acc::Clause::ACCC_shortloop) &&
context_.languageFeatures().ShouldWarn(
common::UsageWarning::OpenAccUsage)) {
context_.Say(GetContext().clauseSource,
if (CheckAllowed(llvm::acc::Clause::ACCC_shortloop)) {
context_.Warn(common::UsageWarning::OpenAccUsage, GetContext().clauseSource,
"Non-standard shortloop clause ignored"_warn_en_US);
}
}
@ -793,10 +787,8 @@ void AccStructureChecker::Enter(const parser::AccClause::If &x) {
}
void AccStructureChecker::Enter(const parser::OpenACCEndConstruct &x) {
if (context_.languageFeatures().ShouldWarn(
common::UsageWarning::OpenAccUsage)) {
context_.Say(x.source, "Misplaced OpenACC end directive"_warn_en_US);
}
context_.Warn(common::UsageWarning::OpenAccUsage, x.source,
"Misplaced OpenACC end directive"_warn_en_US);
}
void AccStructureChecker::Enter(const parser::Module &) {

6
flang/lib/Semantics/check-allocate.cpp
View File

@ -531,10 +531,8 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
// Character length distinction is allowed, with a warning
if (!HaveCompatibleLengths(
*type_, allocateInfo_.sourceExprType.value())) { // F'2023 C950
if (context.ShouldWarn(common::LanguageFeature::AllocateToOtherLength)) {
context.Say(name_.source,
"Character length of allocatable object in ALLOCATE should be the same as the SOURCE or MOLD"_port_en_US);
}
context.Warn(common::LanguageFeature::AllocateToOtherLength, name_.source,
"Character length of allocatable object in ALLOCATE should be the same as the SOURCE or MOLD"_port_en_US);
return false;
}
}

199
flang/lib/Semantics/check-call.cpp
View File

@ -169,37 +169,40 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
actualOffset->offset()) /
actualType.type().kind();
}
if (actualChars < dummyChars &&
(extentErrors ||
context.ShouldWarn(
common::UsageWarning::ShortCharacterActual))) {
auto msg{
"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_warn_en_US};
if (actualChars < dummyChars) {
if (extentErrors) {
msg.set_severity(parser::Severity::Error);
messages.Say(
"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_err_en_US,
static_cast<std::intmax_t>(actualChars), dummyName,
static_cast<std::intmax_t>(dummyChars));
} else if (context.ShouldWarn(
common::UsageWarning::ShortCharacterActual)) {
messages.Say(common::UsageWarning::ShortCharacterActual,
"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_warn_en_US,
static_cast<std::intmax_t>(actualChars), dummyName,
static_cast<std::intmax_t>(dummyChars));
}
messages.Say(std::move(msg),
static_cast<std::intmax_t>(actualChars), dummyName,
static_cast<std::intmax_t>(dummyChars));
}
}
} else { // actual.type.Rank() > 0
if (auto actualSize{evaluate::ToInt64(evaluate::Fold(
foldingContext, evaluate::GetSize(actualType.shape())))};
actualSize &&
*actualSize * *actualLength < *dummySize * *dummyLength &&
(extentErrors ||
context.ShouldWarn(
common::UsageWarning::ShortCharacterActual))) {
auto msg{
"Actual argument array has fewer characters (%jd) than %s array (%jd)"_warn_en_US};
*actualSize * *actualLength < *dummySize * *dummyLength) {
if (extentErrors) {
msg.set_severity(parser::Severity::Error);
messages.Say(
"Actual argument array has fewer characters (%jd) than %s array (%jd)"_err_en_US,
static_cast<std::intmax_t>(*actualSize * *actualLength),
dummyName,
static_cast<std::intmax_t>(*dummySize * *dummyLength));
} else if (context.ShouldWarn(
common::UsageWarning::ShortCharacterActual)) {
messages.Say(common::UsageWarning::ShortCharacterActual,
"Actual argument array has fewer characters (%jd) than %s array (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*actualSize * *actualLength),
dummyName,
static_cast<std::intmax_t>(*dummySize * *dummyLength));
}
messages.Say(std::move(msg),
static_cast<std::intmax_t>(*actualSize * *actualLength),
dummyName,
static_cast<std::intmax_t>(*dummySize * *dummyLength));
}
}
}
@ -217,11 +220,11 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
if (context.ShouldWarn(
common::UsageWarning::ShortCharacterActual)) {
if (isVariable) {
messages.Say(
messages.Say(common::UsageWarning::ShortCharacterActual,
"Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US,
*actualLength, *dummyLength);
} else {
messages.Say(
messages.Say(common::UsageWarning::ShortCharacterActual,
"Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US,
*actualLength, *dummyLength);
}
@ -260,23 +263,16 @@ static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
actual = std::move(*converted);
if (dummyType.type().kind() < actualType.type().kind()) {
if (!semanticsContext.IsEnabled(
common::LanguageFeature::ActualIntegerConvertedToSmallerKind) ||
semanticsContext.ShouldWarn(
common::LanguageFeature::ActualIntegerConvertedToSmallerKind)) {
std::optional<parser::MessageFixedText> msg;
if (!semanticsContext.IsEnabled(
common::LanguageFeature::ActualIntegerConvertedToSmallerKind)) {
msg =
"Actual argument scalar expression of type INTEGER(%d) cannot beimplicitly converted to smaller dummy argument type INTEGER(%d)"_err_en_US;
} else if (semanticsContext.ShouldWarn(
common::LanguageFeature::ConvertedArgument)) {
msg =
"Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_port_en_US;
}
if (msg) {
messages.Say(std::move(msg.value()), actualType.type().kind(),
dummyType.type().kind());
}
messages.Say(
"Actual argument scalar expression of type INTEGER(%d) cannot beimplicitly converted to smaller dummy argument type INTEGER(%d)"_err_en_US,
actualType.type().kind(), dummyType.type().kind());
} else if (semanticsContext.ShouldWarn(common::LanguageFeature::
ActualIntegerConvertedToSmallerKind)) {
messages.Say(
common::LanguageFeature::ActualIntegerConvertedToSmallerKind,
"Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_port_en_US,
actualType.type().kind(), dummyType.type().kind());
}
}
actualType = dummyType;
@ -355,7 +351,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
constantChar && constantChar->wasHollerith() &&
dummy.type.type().IsUnlimitedPolymorphic() &&
context.ShouldWarn(common::LanguageFeature::HollerithPolymorphic)) {
messages.Say(
messages.Say(common::LanguageFeature::HollerithPolymorphic,
"passing Hollerith to unlimited polymorphic as if it were CHARACTER"_port_en_US);
}
} else if (dummyRank == 0 && allowActualArgumentConversions) {
@ -364,7 +360,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
foldingContext, actual, dummy.type.type())}) {
if (context.ShouldWarn(
common::LanguageFeature::HollerithOrCharacterAsBOZ)) {
messages.Say(
messages.Say(common::LanguageFeature::HollerithOrCharacterAsBOZ,
"passing Hollerith or character literal as if it were BOZ"_port_en_US);
}
actual = *converted;
@ -607,35 +603,38 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
*actualSymTypeBytes;
}
}
if (actualElements && *actualElements < *dummySize &&
(extentErrors ||
context.ShouldWarn(
common::UsageWarning::ShortArrayActual))) {
auto msg{
"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US};
if (actualElements && *actualElements < *dummySize) {
if (extentErrors) {
msg.set_severity(parser::Severity::Error);
messages.Say(
"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_err_en_US,
static_cast<std::intmax_t>(*actualElements), dummyName,
static_cast<std::intmax_t>(*dummySize));
} else if (context.ShouldWarn(
common::UsageWarning::ShortArrayActual)) {
messages.Say(common::UsageWarning::ShortArrayActual,
"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*actualElements), dummyName,
static_cast<std::intmax_t>(*dummySize));
}
messages.Say(std::move(msg),
static_cast<std::intmax_t>(*actualElements), dummyName,
static_cast<std::intmax_t>(*dummySize));
}
}
}
} else { // actualRank > 0 || actualIsAssumedRank
if (auto actualSize{evaluate::ToInt64(evaluate::Fold(
foldingContext, evaluate::GetSize(actualType.shape())))};
actualSize && *actualSize < *dummySize &&
(extentErrors ||
context.ShouldWarn(common::UsageWarning::ShortArrayActual))) {
auto msg{
"Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US};
actualSize && *actualSize < *dummySize) {
if (extentErrors) {
msg.set_severity(parser::Severity::Error);
messages.Say(
"Actual argument array has fewer elements (%jd) than %s array (%jd)"_err_en_US,
static_cast<std::intmax_t>(*actualSize), dummyName,
static_cast<std::intmax_t>(*dummySize));
} else if (context.ShouldWarn(
common::UsageWarning::ShortArrayActual)) {
messages.Say(common::UsageWarning::ShortArrayActual,
"Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*actualSize), dummyName,
static_cast<std::intmax_t>(*dummySize));
}
messages.Say(std::move(msg),
static_cast<std::intmax_t>(*actualSize), dummyName,
static_cast<std::intmax_t>(*dummySize));
}
}
}
@ -683,8 +682,11 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
}
if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) {
if (whyNot->IsFatal()) {
if (auto *msg{
messages.Say(std::move(*undefinableMessage), dummyName)}) {
if (auto *msg{messages.Say(*undefinableMessage, dummyName)}) {
if (!msg->IsFatal()) {
msg->set_languageFeature(common::LanguageFeature::
UndefinableAsynchronousOrVolatileActual);
}
msg->Attach(
std::move(whyNot->set_severity(parser::Severity::Because)));
}
@ -747,7 +749,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// is treated as an unassociated allocatable.
if (context.ShouldWarn(
common::LanguageFeature::NullActualForAllocatable)) {
messages.Say(
messages.Say(common::LanguageFeature::NullActualForAllocatable,
"Allocatable %s is associated with a null pointer"_port_en_US,
dummyName);
}
@ -802,7 +804,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
if (context.ShouldWarn(
common::LanguageFeature::RelaxedIntentInChecking)) {
messages.Say(
messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
"If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both should be so"_port_en_US);
}
} else {
@ -814,7 +816,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
if (context.ShouldWarn(
common::LanguageFeature::RelaxedIntentInChecking)) {
messages.Say(
messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
"If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_port_en_US);
}
} else if (actualIsPolymorphic &&
@ -823,6 +825,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (context.ShouldWarn(common::LanguageFeature::
PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {
messages.Say(
common::LanguageFeature::
PolymorphicActualAllocatableOrPointerToMonomorphicDummy,
"If a POINTER or ALLOCATABLE actual argument is polymorphic, the corresponding dummy argument should also be so"_port_en_US);
}
} else {
@ -838,7 +842,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
common::LanguageFeature::RelaxedIntentInChecking)) {
if (context.ShouldWarn(
common::LanguageFeature::RelaxedIntentInChecking)) {
messages.Say(
messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
"POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US);
}
} else {
@ -908,13 +912,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
bool actualIsTemp{!actualIsVariable || HasVectorSubscript(actual) ||
evaluate::ExtractCoarrayRef(actual)};
if (actualIsTemp) {
messages.Say(
messages.Say(common::UsageWarning::NonTargetPassedToTarget,
"Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US,
dummyName, actual.AsFortran());
} else {
auto actualSymbolVector{GetSymbolVector(actual)};
if (!evaluate::GetLastTarget(actualSymbolVector)) {
messages.Say(
messages.Say(common::UsageWarning::NonTargetPassedToTarget,
"Any pointer associated with TARGET %s during this call must not be used afterwards, as '%s' is not a target"_warn_en_US,
dummyName, actual.AsFortran());
}
@ -1012,15 +1016,16 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
return;
}
} else if (argProcSymbol->has<ProcBindingDetails>()) {
if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure) ||
context.ShouldWarn(common::LanguageFeature::BindingAsProcedure)) {
parser::MessageFixedText msg{
"Procedure binding '%s' passed as an actual argument"_port_en_US};
if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure)) {
msg.set_severity(parser::Severity::Error);
}
evaluate::SayWithDeclaration(
messages, *argProcSymbol, std::move(msg), argProcSymbol->name());
if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure)) {
evaluate::SayWithDeclaration(messages, *argProcSymbol,
"Procedure binding '%s' passed as an actual argument"_err_en_US,
argProcSymbol->name());
} else if (context.ShouldWarn(
common::LanguageFeature::BindingAsProcedure)) {
evaluate::SayWithDeclaration(messages, *argProcSymbol,
common::LanguageFeature::BindingAsProcedure,
"Procedure binding '%s' passed as an actual argument"_port_en_US,
argProcSymbol->name());
}
}
}
@ -1067,13 +1072,13 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
dummyName);
} else if (context.ShouldWarn(
common::UsageWarning::ImplicitInterfaceActual)) {
messages.Say(
messages.Say(common::UsageWarning::ImplicitInterfaceActual,
"Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US,
dummyName);
}
} else if (warning &&
context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) {
messages.Say(
messages.Say(common::UsageWarning::ProcDummyArgShapes,
"Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US,
dummyName, std::move(*warning));
}
@ -1239,6 +1244,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
if (context.ShouldWarn(common::LanguageFeature::
NullActualForAllocatable)) {
messages.Say(
common::LanguageFeature::NullActualForAllocatable,
"Allocatable %s is associated with NULL()"_port_en_US,
dummyName);
}
@ -1430,7 +1436,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
if (semanticsContext.ShouldWarn(common::UsageWarning::Portability)) {
if (!evaluate::ExtractDataRef(*pointerExpr) &&
!evaluate::IsProcedurePointer(*pointerExpr)) {
messages.Say(pointerArg->sourceLocation(),
messages.Say(common::UsageWarning::Portability,
pointerArg->sourceLocation(),
"POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer"_port_en_US);
} else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) {
if (auto whyNot{WhyNotDefinable(
@ -1440,7 +1447,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
DefinabilityFlag::DoNotNoteDefinition},
*pointerExpr)}) {
if (whyNot->IsFatal()) {
if (auto *msg{messages.Say(pointerArg->sourceLocation(),
if (auto *msg{messages.Say(common::UsageWarning::Portability,
pointerArg->sourceLocation(),
"POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement"_port_en_US)}) {
msg->Attach(std::move(
whyNot->set_severity(parser::Severity::Because)));
@ -1474,23 +1482,27 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
CheckProcCompatibility(isCall, pointerProc, &*targetProc,
specificIntrinsic, whyNot, warning,
/*ignoreImplicitVsExplicit=*/false)};
std::optional<common::UsageWarning> whichWarning;
if (!msg && warning &&
semanticsContext.ShouldWarn(
common::UsageWarning::ProcDummyArgShapes)) {
whichWarning = common::UsageWarning::ProcDummyArgShapes;
msg =
"Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US;
whyNot = std::move(*warning);
} else if (msg &&
msg->severity() != parser::Severity::Error &&
!semanticsContext.ShouldWarn(
} else if (msg && !msg->IsFatal() &&
semanticsContext.ShouldWarn(
common::UsageWarning::ProcPointerCompatibility)) {
msg.reset();
whichWarning =
common::UsageWarning::ProcPointerCompatibility;
}
if (msg) {
msg->set_severity(parser::Severity::Warning);
messages.Say(std::move(*msg),
"pointer '" + pointerExpr->AsFortran() + "'",
targetExpr->AsFortran(), whyNot);
if (msg && (msg->IsFatal() || whichWarning)) {
if (auto *said{messages.Say(std::move(*msg),
"pointer '" + pointerExpr->AsFortran() + "'",
targetExpr->AsFortran(), whyNot)};
said && whichWarning) {
said->set_usageWarning(*whichWarning);
}
}
}
} else if (!IsNullProcedurePointer(*targetExpr)) {
@ -1819,6 +1831,7 @@ static void CheckTransferOperandType(SemanticsContext &context,
if (type.IsPolymorphic() &&
context.ShouldWarn(common::UsageWarning::PolymorphicTransferArg)) {
context.foldingContext().messages().Say(
common::UsageWarning::PolymorphicTransferArg,
"%s of TRANSFER is polymorphic"_warn_en_US, which);
} else if (!type.IsUnlimitedPolymorphic() &&
type.category() == TypeCategory::Derived &&
@ -1827,6 +1840,7 @@ static void CheckTransferOperandType(SemanticsContext &context,
if (auto bad{std::find_if(directs.begin(), directs.end(), IsDescriptor)};
bad != directs.end()) {
evaluate::SayWithDeclaration(context.foldingContext().messages(), *bad,
common::UsageWarning::PointerComponentTransferArg,
"%s of TRANSFER contains allocatable or pointer component %s"_warn_en_US,
which, bad.BuildResultDesignatorName());
}
@ -1856,7 +1870,7 @@ static void CheckTransfer(evaluate::ActualArguments &arguments,
"Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US);
}
} else if (context.ShouldWarn(common::UsageWarning::VoidMold)) {
messages.Say(
messages.Say(common::UsageWarning::VoidMold,
"Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US);
}
}
@ -1872,7 +1886,7 @@ static void CheckTransfer(evaluate::ActualArguments &arguments,
} else if (context.ShouldWarn(
common::UsageWarning::TransferSizePresence) &&
IsAllocatableOrObjectPointer(whole)) {
messages.Say(
messages.Say(common::UsageWarning::TransferSizePresence,
"SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
}
}
@ -2094,6 +2108,7 @@ bool CheckArguments(const characteristics::Procedure &proc,
if (context.ShouldWarn(
common::UsageWarning::KnownBadImplicitInterface)) {
if (auto *msg{messages.Say(
common::UsageWarning::KnownBadImplicitInterface,
"If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
buffer.AttachTo(*msg, parser::Severity::Because);
}

14
flang/lib/Semantics/check-case.cpp
View File

@ -49,10 +49,8 @@ private:
for (const auto &range : ranges) {
auto pair{ComputeBounds(range)};
if (pair.first && pair.second && *pair.first > *pair.second) {
if (context_.ShouldWarn(common::UsageWarning::EmptyCase)) {
context_.Say(stmt.source,
"CASE has lower bound greater than upper bound"_warn_en_US);
}
context_.Warn(common::UsageWarning::EmptyCase, stmt.source,
"CASE has lower bound greater than upper bound"_warn_en_US);
} else {
if constexpr (T::category == TypeCategory::Logical) { // C1148
if ((pair.first || pair.second) &&
@ -95,11 +93,9 @@ private:
x->v = converted;
return value;
} else {
if (context_.ShouldWarn(common::UsageWarning::CaseOverflow)) {
context_.Say(expr.source,
"CASE value (%s) overflows type (%s) of SELECT CASE expression"_warn_en_US,
folded.AsFortran(), caseExprType_.AsFortran());
}
context_.Warn(common::UsageWarning::CaseOverflow, expr.source,
"CASE value (%s) overflows type (%s) of SELECT CASE expression"_warn_en_US,
folded.AsFortran(), caseExprType_.AsFortran());
hasErrors_ = true;
return std::nullopt;
}

6
flang/lib/Semantics/check-cuda.cpp
View File

@ -296,10 +296,8 @@ private:
return false;
}
void WarnOnIoStmt(const parser::CharBlock &source) {
if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
context_.Say(
source, "I/O statement might not be supported on device"_warn_en_US);
}
context_.Warn(common::UsageWarning::CUDAUsage, source,
"I/O statement might not be supported on device"_warn_en_US);
}
template <typename A>
void WarnIfNotInternal(const A &stmt, const parser::CharBlock &source) {

10
flang/lib/Semantics/check-data.cpp
View File

@ -89,9 +89,8 @@ public:
"Procedure pointer '%s' may not appear in a DATA statement"_err_en_US,
symbol.name());
return false;
} else if (context_.ShouldWarn(
common::LanguageFeature::DataStmtExtensions)) {
context_.Say(source_,
} else {
context_.Warn(common::LanguageFeature::DataStmtExtensions, source_,
"Procedure pointer '%s' in a DATA statement is not standard"_port_en_US,
symbol.name());
}
@ -102,9 +101,8 @@ public:
"Blank COMMON object '%s' may not appear in a DATA statement"_err_en_US,
symbol.name());
return false;
} else if (context_.ShouldWarn(
common::LanguageFeature::DataStmtExtensions)) {
context_.Say(source_,
} else {
context_.Warn(common::LanguageFeature::DataStmtExtensions, source_,
"Blank COMMON object '%s' in a DATA statement is not standard"_port_en_US,
symbol.name());
}

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

@ -124,19 +124,23 @@ private:
return FindModuleFileContaining(context_.FindScope(messages_.at())) !=
nullptr;
}
template <typename... A> parser::Message *WarnIfNotInModuleFile(A &&...x) {
if (InModuleFile()) {
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(FeatureOrUsageWarning warning, A &&...x) {
if (!context_.ShouldWarn(warning) || InModuleFile()) {
return nullptr;
} else {
return messages_.Say(std::forward<A>(x)...);
return messages_.Say(warning, std::forward<A>(x)...);
}
}
template <typename... A>
parser::Message *WarnIfNotInModuleFile(parser::CharBlock source, A &&...x) {
if (FindModuleFileContaining(context_.FindScope(source))) {
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(
FeatureOrUsageWarning warning, parser::CharBlock source, A &&...x) {
if (!context_.ShouldWarn(warning) ||
FindModuleFileContaining(context_.FindScope(source))) {
return nullptr;
} else {
return messages_.Say(warning, source, std::forward<A>(x)...);
}
return messages_.Say(source, std::forward<A>(x)...);
}
bool IsResultOkToDiffer(const FunctionResult &);
void CheckGlobalName(const Symbol &);
@ -261,11 +265,9 @@ void CheckHelper::Check(const Symbol &symbol) {
}
if (symbol.name().size() > common::maxNameLen &&
&symbol == &symbol.GetUltimate()) {
if (context_.ShouldWarn(common::LanguageFeature::LongNames)) {
WarnIfNotInModuleFile(symbol.name(),
"%s has length %d, which is greater than the maximum name length %d"_port_en_US,
symbol.name(), symbol.name().size(), common::maxNameLen);
}
Warn(common::LanguageFeature::LongNames, symbol.name(),
"%s has length %d, which is greater than the maximum name length %d"_port_en_US,
symbol.name(), symbol.name().size(), common::maxNameLen);
}
if (context_.HasError(symbol)) {
return;
@ -448,10 +450,8 @@ void CheckHelper::Check(const Symbol &symbol) {
}
}
if (IsProcedurePointer(symbol) && IsDummy(symbol)) {
if (context_.ShouldWarn(common::UsageWarning::Portability)) {
messages_.Say(
"A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
}
Warn(common::UsageWarning::Portability,
"A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
// The non-dummy case is a hard error that's caught elsewhere.
}
}
@ -481,12 +481,9 @@ void CheckHelper::Check(const Symbol &symbol) {
symbol.name());
} else if (symbol.owner().kind() == Scope::Kind::MainProgram) {
if (context_.IsEnabled(common::LanguageFeature::AutomaticInMainProgram)) {
if (context_.ShouldWarn(
common::LanguageFeature::AutomaticInMainProgram)) {
messages_.Say(
"Automatic data object '%s' should not appear in the specification part of a main program"_port_en_US,
symbol.name());
}
Warn(common::LanguageFeature::AutomaticInMainProgram,
"Automatic data object '%s' should not appear in the specification part of a main program"_port_en_US,
symbol.name());
} else {
messages_.Say(
"Automatic data object '%s' may not appear in the specification part of a main program"_err_en_US,
@ -602,10 +599,9 @@ void CheckHelper::CheckValue(
messages_.Say(
"VALUE attribute may not apply to an assumed-rank array"_err_en_US);
}
if (context_.ShouldWarn(common::UsageWarning::Portability) &&
IsAssumedLengthCharacter(symbol)) {
if (IsAssumedLengthCharacter(symbol)) {
// F'2008 feature not widely implemented
messages_.Say(
Warn(common::UsageWarning::Portability,
"VALUE attribute on assumed-length CHARACTER may not be portable"_port_en_US);
}
}
@ -779,10 +775,8 @@ void CheckHelper::CheckObjectEntity(
}
if (ok && InFunction() && !InModuleFile() && !InElemental()) {
if (context_.IsEnabled(common::LanguageFeature::RelaxedPureDummy)) {
if (context_.ShouldWarn(common::LanguageFeature::RelaxedPureDummy)) {
messages_.Say(
"non-POINTER dummy argument of pure function should be INTENT(IN) or VALUE"_warn_en_US);
}
Warn(common::LanguageFeature::RelaxedPureDummy,
"non-POINTER dummy argument of pure function should be INTENT(IN) or VALUE"_warn_en_US);
} else {
messages_.Say(
"non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
@ -806,25 +800,19 @@ void CheckHelper::CheckObjectEntity(
if (IsPassedViaDescriptor(symbol)) {
if (IsAllocatableOrObjectPointer(&symbol)) {
if (inExplicitExternalInterface) {
if (context_.ShouldWarn(common::UsageWarning::IgnoreTKRUsage)) {
WarnIfNotInModuleFile(
"!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
}
Warn(common::UsageWarning::IgnoreTKRUsage,
"!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
} else {
messages_.Say(
"!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
}
} else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
if (context_.ShouldWarn(common::UsageWarning::IgnoreTKRUsage)) {
WarnIfNotInModuleFile(
"!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
}
Warn(common::UsageWarning::IgnoreTKRUsage,
"!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
} else if (inExplicitExternalInterface) {
if (context_.ShouldWarn(common::UsageWarning::IgnoreTKRUsage)) {
WarnIfNotInModuleFile(
"!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
}
Warn(common::UsageWarning::IgnoreTKRUsage,
"!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
} else {
messages_.Say(
"!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
@ -884,10 +872,8 @@ void CheckHelper::CheckObjectEntity(
} else if (IsFunctionResult(symbol)) {
messages_.Say("A function result must not be initialized"_err_en_US);
} else if (IsInBlankCommon(symbol)) {
if (context_.ShouldWarn(common::LanguageFeature::InitBlankCommon)) {
WarnIfNotInModuleFile(
"A variable in blank COMMON should not be initialized"_port_en_US);
}
Warn(common::LanguageFeature::InitBlankCommon,
"A variable in blank COMMON should not be initialized"_port_en_US);
}
}
if (symbol.owner().kind() == Scope::Kind::BlockData) {
@ -929,31 +915,25 @@ void CheckHelper::CheckObjectEntity(
bool inDeviceSubprogram{IsCUDADeviceContext(&symbol.owner())};
if (inDeviceSubprogram) {
if (IsSaved(symbol)) {
if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
WarnIfNotInModuleFile(
"'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,
symbol.name());
}
Warn(common::UsageWarning::CUDAUsage,
"'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,
symbol.name());
}
if (IsPointer(symbol)) {
if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
WarnIfNotInModuleFile(
"Pointer '%s' may not be associated in a device subprogram"_warn_en_US,
symbol.name());
}
Warn(common::UsageWarning::CUDAUsage,
"Pointer '%s' may not be associated in a device subprogram"_warn_en_US,
symbol.name());
}
if (details.isDummy() &&
details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
common::CUDADataAttr::Device &&
details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
common::CUDADataAttr::Managed) {
if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
WarnIfNotInModuleFile(
"Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,
symbol.name(),
parser::ToUpperCaseLetters(
common::EnumToString(*details.cudaDataAttr())));
}
Warn(common::UsageWarning::CUDAUsage,
"Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,
symbol.name(),
parser::ToUpperCaseLetters(
common::EnumToString(*details.cudaDataAttr())));
}
}
if (details.cudaDataAttr()) {
@ -1003,23 +983,17 @@ void CheckHelper::CheckObjectEntity(
break;
case common::CUDADataAttr::Pinned:
if (inDeviceSubprogram) {
if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
WarnIfNotInModuleFile(
"Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,
symbol.name());
}
Warn(common::UsageWarning::CUDAUsage,
"Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,
symbol.name());
} else if (IsPointer(symbol)) {
if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
WarnIfNotInModuleFile(
"Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,
symbol.name());
}
Warn(common::UsageWarning::CUDAUsage,
"Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,
symbol.name());
} else if (!IsAllocatable(symbol)) {
if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
WarnIfNotInModuleFile(
"Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,
symbol.name());
}
Warn(common::UsageWarning::CUDAUsage,
"Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,
symbol.name());
}
break;
case common::CUDADataAttr::Shared:
@ -1281,10 +1255,8 @@ void CheckHelper::CheckProcEntity(
// because it is explicitly legal to *pass* the specific intrinsic
// function SIN as an actual argument.
if (interface->attrs().test(Attr::INTRINSIC)) {
if (context_.ShouldWarn(common::UsageWarning::Portability)) {
messages_.Say(
"A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
}
Warn(common::UsageWarning::Portability,
"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);
}
@ -1302,11 +1274,9 @@ void CheckHelper::CheckProcEntity(
"to procedure pointer '%s'"_err_en_US,
interface->name(), symbol.name());
} else if (IsElementalProcedure(*interface)) {
if (context_.ShouldWarn(common::UsageWarning::Portability)) {
messages_.Say(
"Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
symbol.name()); // C1517
}
Warn(common::UsageWarning::Portability,
"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,
@ -1470,13 +1440,11 @@ void CheckHelper::CheckSubprogram(
// 15.6.4 p2 weird requirement
if (const Symbol *
host{symbol.owner().parent().FindSymbol(symbol.name())}) {
if (context_.ShouldWarn(
common::LanguageFeature::StatementFunctionExtensions)) {
evaluate::AttachDeclaration(
messages_.Say(symbol.name(),
"An implicitly typed statement function should not appear when the same symbol is available in its host scope"_port_en_US),
*host);
}
evaluate::AttachDeclaration(
Warn(common::LanguageFeature::StatementFunctionExtensions,
symbol.name(),
"An implicitly typed statement function should not appear when the same symbol is available in its host scope"_port_en_US),
*host);
}
}
if (GetProgramUnitOrBlockConstructContaining(symbol).kind() ==
@ -1566,9 +1534,8 @@ void CheckHelper::CheckExternal(const Symbol &symbol) {
parser::Message *msg{nullptr};
if (!IsProcedure(*global)) {
if ((symbol.flags().test(Symbol::Flag::Function) ||
symbol.flags().test(Symbol::Flag::Subroutine)) &&
context_.ShouldWarn(common::UsageWarning::ExternalNameConflict)) {
msg = WarnIfNotInModuleFile(
symbol.flags().test(Symbol::Flag::Subroutine))) {
msg = Warn(common::UsageWarning::ExternalNameConflict,
"The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_warn_en_US,
global->name(), symbol.name());
}
@ -1577,20 +1544,16 @@ void CheckHelper::CheckExternal(const Symbol &symbol) {
if (chars->HasExplicitInterface()) {
std::string whyNot;
if (!chars->IsCompatibleWith(*globalChars,
/*ignoreImplicitVsExplicit=*/false, &whyNot) &&
context_.ShouldWarn(
common::UsageWarning::ExternalInterfaceMismatch)) {
msg = WarnIfNotInModuleFile(
/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,
"The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
global->name(), whyNot);
}
} else if (!globalChars->CanBeCalledViaImplicitInterface() &&
context_.ShouldWarn(
common::UsageWarning::ExternalInterfaceMismatch)) {
} else if (!globalChars->CanBeCalledViaImplicitInterface()) {
// TODO: This should be a hard error if the procedure has
// actually been called (as opposed to just being used as a
// procedure pointer target or passed as an actual argument).
msg = WarnIfNotInModuleFile(
msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,
"The global subprogram '%s' should not be referenced via the implicit interface '%s'"_warn_en_US,
global->name(), symbol.name());
}
@ -1611,10 +1574,8 @@ void CheckHelper::CheckExternal(const Symbol &symbol) {
if (auto previousChars{Characterize(previous)}) {
std::string whyNot;
if (!chars->IsCompatibleWith(*previousChars,
/*ignoreImplicitVsExplicit=*/false, &whyNot) &&
context_.ShouldWarn(
common::UsageWarning::ExternalInterfaceMismatch)) {
if (auto *msg{WarnIfNotInModuleFile(
/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
if (auto *msg{Warn(common::UsageWarning::ExternalInterfaceMismatch,
"The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
symbol.name(), whyNot)}) {
evaluate::AttachDeclaration(msg, previous);
@ -1891,22 +1852,20 @@ void CheckHelper::CheckSpecifics(
auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
specific.name().ToString())};
if (intrinsic && !intrinsic->isRestrictedSpecific) {
if (context_.ShouldWarn(common::LanguageFeature::IntrinsicAsSpecific)) {
if (auto *msg{messages_.Say(specific.name(),
"Specific procedure '%s' of generic interface '%s' should not be INTRINSIC"_port_en_US,
specific.name(), generic.name())}) {
msg->Attach(
generic.name(), "Definition of '%s'"_en_US, generic.name());
}
if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,
specific.name(),
"Specific procedure '%s' of generic interface '%s' should not be INTRINSIC"_port_en_US,
specific.name(), generic.name())}) {
msg->Attach(
generic.name(), "Definition of '%s'"_en_US, generic.name());
}
} else {
if (context_.ShouldWarn(common::LanguageFeature::IntrinsicAsSpecific)) {
if (auto *msg{messages_.Say(specific.name(),
"Procedure '%s' of generic interface '%s' is INTRINSIC but not an unrestricted specific intrinsic function"_port_en_US,
specific.name(), generic.name())}) {
msg->Attach(
generic.name(), "Definition of '%s'"_en_US, generic.name());
}
if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,
specific.name(),
"Procedure '%s' of generic interface '%s' is INTRINSIC but not an unrestricted specific intrinsic function"_port_en_US,
specific.name(), generic.name())}) {
msg->Attach(
generic.name(), "Definition of '%s'"_en_US, generic.name());
}
continue;
}
@ -2041,23 +2000,27 @@ bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
msg = "%s function '%s' may not have assumed-length CHARACTER(*)"
" result"_err_en_US;
} else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) {
msg = std::move(m);
if (m->IsFatal()) {
msg = *m;
} else {
evaluate::AttachDeclaration(
Warn(common::UsageWarning::DefinedOperatorArgs, specific.name(),
std::move(*m), MakeOpName(opName), specific.name()),
specific);
return true;
}
} else if (!checkDefinedOperatorArgs(opName, specific, proc)) {
return false; // error was reported
} else if (ConflictsWithIntrinsicOperator(kind, proc)) {
msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US;
} else {
return true; // OK
}
bool isFatal{msg->IsFatal()};
if (isFatal || !FindModuleFileContaining(specific.owner())) {
if (msg) {
SayWithDeclaration(
specific, std::move(*msg), MakeOpName(opName), specific.name());
}
if (isFatal) {
context_.SetError(specific);
return false;
}
return !isFatal;
return true;
}
// If the number of arguments is wrong for this intrinsic operator, return
@ -2114,32 +2077,29 @@ bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,
auto &arg{proc.dummyArguments.at(pos)};
std::optional<parser::MessageFixedText> msg;
if (arg.IsOptional()) {
msg = "In %s function '%s', dummy argument '%s' may not be"
" OPTIONAL"_err_en_US;
msg =
"In %s function '%s', dummy argument '%s' may not be OPTIONAL"_err_en_US;
} else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)};
dataObject == nullptr) {
msg = "In %s function '%s', dummy argument '%s' must be a"
" data object"_err_en_US;
msg =
"In %s function '%s', dummy argument '%s' must be a data object"_err_en_US;
} else if (dataObject->intent == common::Intent::Out) {
msg =
"In %s function '%s', dummy argument '%s' may not be INTENT(OUT)"_err_en_US;
} else if (dataObject->intent != common::Intent::In &&
!dataObject->attrs.test(DummyDataObject::Attr::Value)) {
if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
msg =
"In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
}
evaluate::AttachDeclaration(
Warn(common::UsageWarning::DefinedOperatorArgs,
"In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US,
parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),
arg.name),
symbol);
return true;
}
if (msg) {
bool isFatal{msg->IsFatal()};
if (isFatal || !FindModuleFileContaining(symbol.owner())) {
SayWithDeclaration(symbol, std::move(*msg),
parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),
arg.name);
}
if (isFatal) {
return false;
}
SayWithDeclaration(symbol, std::move(*msg),
parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name);
return false;
}
return true;
}
@ -2190,10 +2150,8 @@ bool CheckHelper::CheckDefinedAssignmentArg(
" may not have INTENT(IN)"_err_en_US;
} else if (dataObject->intent != common::Intent::Out &&
dataObject->intent != common::Intent::InOut) {
if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
msg =
"In defined assignment subroutine '%s', first dummy argument '%s' should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;
}
msg =
"In defined assignment subroutine '%s', first dummy argument '%s' should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;
}
} else if (pos == 1) {
if (dataObject->intent == common::Intent::Out) {
@ -2201,10 +2159,8 @@ bool CheckHelper::CheckDefinedAssignmentArg(
" argument '%s' may not have INTENT(OUT)"_err_en_US;
} else if (dataObject->intent != common::Intent::In &&
!dataObject->attrs.test(DummyDataObject::Attr::Value)) {
if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
msg =
"In defined assignment subroutine '%s', second dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
}
msg =
"In defined assignment subroutine '%s', second dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
} else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {
msg =
"In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;
@ -2220,13 +2176,15 @@ bool CheckHelper::CheckDefinedAssignmentArg(
" must be a data object"_err_en_US;
}
if (msg) {
bool isFatal{msg->IsFatal()};
if (isFatal || !FindModuleFileContaining(symbol.owner())) {
if (msg->IsFatal()) {
SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
}
if (isFatal) {
context_.SetError(symbol);
return false;
} else {
evaluate::AttachDeclaration(
Warn(common::UsageWarning::DefinedOperatorArgs, std::move(*msg),
symbol.name(), arg.name),
symbol);
}
}
return true;
@ -2258,13 +2216,12 @@ void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
while (const auto *derivedDetails{
derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) {
if (!derivedDetails->finals().empty() &&
!derivedDetails->GetFinalForRank(rank) &&
context_.ShouldWarn(common::UsageWarning::Final)) {
!derivedDetails->GetFinalForRank(rank)) {
if (auto *msg{derivedSym == initialDerivedSym
? WarnIfNotInModuleFile(symbol.name(),
? Warn(common::UsageWarning::Final, symbol.name(),
"'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
symbol.name(), derivedSym->name(), rank)
: WarnIfNotInModuleFile(symbol.name(),
: Warn(common::UsageWarning::Final, symbol.name(),
"'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
symbol.name(), initialDerivedSym->name(),
derivedSym->name(), rank)}) {
@ -2316,16 +2273,17 @@ void CheckHelper::CheckContiguous(const Symbol &symbol) {
if (evaluate::IsVariable(symbol) &&
((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||
evaluate::IsAssumedRank(symbol))) {
} else if (!context_.IsEnabled(
common::LanguageFeature::RedundantContiguous) ||
context_.ShouldWarn(common::LanguageFeature::RedundantContiguous)) {
} else {
parser::MessageFixedText msg{symbol.owner().IsDerivedType()
? "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US
: "CONTIGUOUS entity '%s' should be an array pointer, assumed-shape, or assumed-rank"_port_en_US};
if (!context_.IsEnabled(common::LanguageFeature::RedundantContiguous)) {
msg.set_severity(parser::Severity::Error);
messages_.Say(std::move(msg), symbol.name());
} else {
Warn(common::LanguageFeature::RedundantContiguous, std::move(msg),
symbol.name());
}
messages_.Say(std::move(msg), symbol.name());
}
}
@ -2615,26 +2573,24 @@ void CheckHelper::Check(const Scope &scope) {
auto iter{scope.find(*name)};
if (iter != scope.end()) {
const char *kind{nullptr};
if (context_.ShouldWarn(common::LanguageFeature::BenignNameClash)) {
switch (scope.kind()) {
case Scope::Kind::Module:
kind = scope.symbol()->get<ModuleDetails>().isSubmodule()
? "submodule"
: "module";
break;
case Scope::Kind::MainProgram:
kind = "main program";
break;
case Scope::Kind::BlockData:
kind = "BLOCK DATA subprogram";
break;
default:;
}
if (kind) {
messages_.Say(iter->second->name(),
"Name '%s' declared in a %s should not have the same name as the %s"_port_en_US,
*name, kind, kind);
}
switch (scope.kind()) {
case Scope::Kind::Module:
kind = scope.symbol()->get<ModuleDetails>().isSubmodule()
? "submodule"
: "module";
break;
case Scope::Kind::MainProgram:
kind = "main program";
break;
case Scope::Kind::BlockData:
kind = "BLOCK DATA subprogram";
break;
default:;
}
if (kind) {
Warn(common::LanguageFeature::BenignNameClash, iter->second->name(),
"Name '%s' declared in a %s should not have the same name as the %s"_port_en_US,
*name, kind, kind);
}
}
}
@ -2876,17 +2832,13 @@ void CheckHelper::CheckGlobalName(const Symbol &symbol) {
!IsExternalProcedureDefinition(other))) {
// both are procedures/BLOCK DATA, not both definitions
} else if (symbol.has<ModuleDetails>()) {
if (context_.ShouldWarn(common::LanguageFeature::BenignNameClash)) {
messages_.Say(symbol.name(),
"Module '%s' conflicts with a global name"_port_en_US,
pair.first->first);
}
Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
"Module '%s' conflicts with a global name"_port_en_US,
pair.first->first);
} else if (other.has<ModuleDetails>()) {
if (context_.ShouldWarn(common::LanguageFeature::BenignNameClash)) {
messages_.Say(symbol.name(),
"Global name '%s' conflicts with a module"_port_en_US,
pair.first->first);
}
Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
"Global name '%s' conflicts with a module"_port_en_US,
pair.first->first);
} else if (auto *msg{messages_.Say(symbol.name(),
"Two entities have the same global name '%s'"_err_en_US,
pair.first->first)}) {
@ -3012,13 +2964,13 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
.value_or(false)) {
if (type->category() == DeclTypeSpec::Logical) {
if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
msgs.Say(component.name(),
msgs.Say(common::UsageWarning::LogicalVsCBool, component.name(),
"A LOGICAL component of an interoperable type should have the interoperable KIND=C_BOOL"_port_en_US);
}
} else if (type->category() == DeclTypeSpec::Character && dyType &&
dyType->kind() == 1) {
if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
msgs.Say(component.name(),
msgs.Say(common::UsageWarning::BindCCharLength, component.name(),
"A CHARACTER component of an interoperable type should have length 1"_port_en_US);
}
} else {
@ -3036,7 +2988,7 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
}
if (derived->componentNames().empty()) { // F'2023 C1805
if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
msgs.Say(symbol.name(),
msgs.Say(common::LanguageFeature::EmptyBindCDerivedType, symbol.name(),
"A derived type with the BIND attribute should not be empty"_warn_en_US);
}
}
@ -3119,13 +3071,12 @@ parser::Messages CheckHelper::WhyNotInteroperableObject(const Symbol &symbol) {
// when processing a module file, since the module file might have been
// compiled with CUDA while the client is not.
} else if (type->category() == DeclTypeSpec::Logical) {
if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool) &&
!InModuleFile()) {
if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
if (IsDummy(symbol)) {
msgs.Say(symbol.name(),
msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
"A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
} else {
msgs.Say(symbol.name(),
msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
"A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
}
}

23
flang/lib/Semantics/check-directive-structure.h
View File

@ -463,12 +463,11 @@ void DirectiveStructureChecker<D, C, PC,
}
// No clause matched in the actual clauses list
if (warnInsteadOfError) {
if (context_.ShouldWarn(common::UsageWarning::Portability)) {
context_.Say(GetContext().directiveSource,
"At least one of %s clause should appear on the %s directive"_port_en_US,
ClauseSetToString(GetContext().requiredClauses),
ContextDirectiveAsFortran());
}
context_.Warn(common::UsageWarning::Portability,
GetContext().directiveSource,
"At least one of %s clause should appear on the %s directive"_port_en_US,
ClauseSetToString(GetContext().requiredClauses),
ContextDirectiveAsFortran());
} else {
context_.Say(GetContext().directiveSource,
"At least one of %s clause must appear on the %s directive"_err_en_US,
@ -493,13 +492,11 @@ bool DirectiveStructureChecker<D, C, PC, ClauseEnumSize>::CheckAllowed(
!GetContext().allowedExclusiveClauses.test(clause) &&
!GetContext().requiredClauses.test(clause)) {
if (warnInsteadOfError) {
if (context_.ShouldWarn(common::UsageWarning::Portability)) {
context_.Say(GetContext().clauseSource,
"%s clause is not allowed on the %s directive and will be ignored"_port_en_US,
parser::ToUpperCaseLetters(getClauseName(clause).str()),
parser::ToUpperCaseLetters(
GetContext().directiveSource.ToString()));
}
context_.Warn(common::UsageWarning::Portability,
GetContext().clauseSource,
"%s clause is not allowed on the %s directive and will be ignored"_port_en_US,
parser::ToUpperCaseLetters(getClauseName(clause).str()),
parser::ToUpperCaseLetters(GetContext().directiveSource.ToString()));
} else {
context_.Say(GetContext().clauseSource,
"%s clause is not allowed on the %s directive"_err_en_US,

26
flang/lib/Semantics/check-do-forall.cpp
View File

@ -495,10 +495,8 @@ private:
void CheckDoControl(const parser::CharBlock &sourceLocation, bool isReal) {
if (isReal) {
if (context_.ShouldWarn(common::LanguageFeature::RealDoControls)) {
context_.Say(
sourceLocation, "DO controls should be INTEGER"_port_en_US);
}
context_.Warn(common::LanguageFeature::RealDoControls, sourceLocation,
"DO controls should be INTEGER"_port_en_US);
} else {
SayBadDoControl(sourceLocation);
}
@ -552,9 +550,9 @@ private:
CheckDoExpression(bounds.upper);
if (bounds.step) {
CheckDoExpression(*bounds.step);
if (IsZero(*bounds.step) &&
context_.ShouldWarn(common::UsageWarning::ZeroDoStep)) {
context_.Say(bounds.step->thing.value().source,
if (IsZero(*bounds.step)) {
context_.Warn(common::UsageWarning::ZeroDoStep,
bounds.step->thing.value().source,
"DO step expression should not be zero"_warn_en_US);
}
}
@ -679,10 +677,9 @@ private:
if (std::holds_alternative<parser::LocalitySpec::DefaultNone>(ls.u)) {
if (hasDefaultNone) {
// F'2023 C1129, you can only have one DEFAULT(NONE)
if (context_.ShouldWarn(common::LanguageFeature::BenignRedundancy)) {
context_.Say(currentStatementSourcePosition_,
"Only one DEFAULT(NONE) may appear"_port_en_US);
}
context_.Warn(common::LanguageFeature::BenignRedundancy,
currentStatementSourcePosition_,
"Only one DEFAULT(NONE) may appear"_port_en_US);
break;
}
hasDefaultNone = true;
@ -890,10 +887,9 @@ private:
},
assignment.u);
for (const Symbol &index : indexVars) {
if (symbols.count(index) == 0 &&
context_.ShouldWarn(common::UsageWarning::UnusedForallIndex)) {
context_.Say("FORALL index variable '%s' not used on left-hand side"
" of assignment"_warn_en_US,
if (symbols.count(index) == 0) {
context_.Warn(common::UsageWarning::UnusedForallIndex,
"FORALL index variable '%s' not used on left-hand side of assignment"_warn_en_US,
index.name());
}
}

19
flang/lib/Semantics/check-io.cpp
View File

@ -232,8 +232,8 @@ void IoChecker::Enter(const parser::Format &spec) {
if (!IsVariable(*expr)) {
context_.Say(format.source,
"Assigned format label must be a scalar variable"_err_en_US);
} else if (context_.ShouldWarn(common::LanguageFeature::Assign)) {
context_.Say(format.source,
} else {
context_.Warn(common::LanguageFeature::Assign, format.source,
"Assigned format labels are deprecated"_port_en_US);
}
return;
@ -245,11 +245,9 @@ void IoChecker::Enter(const parser::Format &spec) {
common::LanguageFeature::NonCharacterFormat)) {
// Legacy extension: using non-character variables, typically
// DATA-initialized with Hollerith, as format expressions.
if (context_.ShouldWarn(
common::LanguageFeature::NonCharacterFormat)) {
context_.Say(format.source,
"Non-character format expression is not standard"_port_en_US);
}
context_.Warn(common::LanguageFeature::NonCharacterFormat,
format.source,
"Non-character format expression is not standard"_port_en_US);
} else if (!type ||
type->kind() !=
context_.defaultKinds().GetDefaultKind(type->category())) {
@ -936,11 +934,8 @@ void IoChecker::CheckStringValue(IoSpecKind specKind, const std::string &value,
auto upper{Normalize(value)};
if (specValues.at(specKind).count(upper) == 0) {
if (specKind == IoSpecKind::Access && upper == "APPEND") {
if (context_.ShouldWarn(common::LanguageFeature::OpenAccessAppend)) {
context_.Say(source,
"ACCESS='%s' interpreted as POSITION='%s'"_port_en_US, value,
upper);
}
context_.Warn(common::LanguageFeature::OpenAccessAppend, source,
"ACCESS='%s' interpreted as POSITION='%s'"_port_en_US, value, upper);
} else {
context_.Say(source, "Invalid %s value '%s'"_err_en_US,
parser::ToUpperCaseLetters(common::EnumToString(specKind)), value);

59
flang/lib/Semantics/check-omp-structure.cpp
View File

@ -666,11 +666,10 @@ void OmpStructureChecker::CheckTargetNest(const parser::OpenMPConstruct &c) {
[&](const auto &c) {},
},
c.u);
if (!eligibleTarget &&
context_.ShouldWarn(common::UsageWarning::Portability)) {
context_.Say(parser::FindSourceLocation(c),
"If %s directive is nested inside TARGET region, the behaviour "
"is unspecified"_port_en_US,
if (!eligibleTarget) {
context_.Warn(common::UsageWarning::Portability,
parser::FindSourceLocation(c),
"If %s directive is nested inside TARGET region, the behaviour is unspecified"_port_en_US,
parser::ToUpperCaseLetters(
getDirectiveName(ineligibleTargetDir).str()));
}
@ -1077,12 +1076,10 @@ void OmpStructureChecker::CheckThreadprivateOrDeclareTargetVar(
ContextDirectiveAsFortran());
else if (GetContext().directive ==
llvm::omp::Directive::OMPD_declare_target)
if (context_.ShouldWarn(
common::UsageWarning::OpenMPUsage)) {
context_.Say(name->source,
"The entity with PARAMETER attribute is used in a %s directive"_warn_en_US,
ContextDirectiveAsFortran());
}
context_.Warn(common::UsageWarning::OpenMPUsage,
name->source,
"The entity with PARAMETER attribute is used in a %s directive"_warn_en_US,
ContextDirectiveAsFortran());
} else if (FindCommonBlockContaining(*name->symbol)) {
context_.Say(name->source,
"A variable in a %s directive cannot be an element of a "
@ -1249,8 +1246,8 @@ void OmpStructureChecker::Leave(const parser::OmpDeclareTargetWithClause &x) {
context_.Say(x.source,
"If the DECLARE TARGET directive has a clause, it must contain at least one ENTER clause or LINK clause"_err_en_US);
}
if (toClause && context_.ShouldWarn(common::UsageWarning::OpenMPUsage)) {
context_.Say(toClause->source,
if (toClause) {
context_.Warn(common::UsageWarning::OpenMPUsage, toClause->source,
"The usage of TO clause on DECLARE TARGET directive has been deprecated. Use ENTER clause instead."_warn_en_US);
}
}
@ -3143,9 +3140,8 @@ void OmpStructureChecker::CheckCopyingPolymorphicAllocatable(
const auto *symbol{it->first};
const auto source{it->second};
if (IsPolymorphicAllocatable(*symbol)) {
context_.Say(source,
"If a polymorphic variable with allocatable attribute '%s' is in "
"%s clause, the behavior is unspecified"_port_en_US,
context_.Warn(common::UsageWarning::Portability, source,
"If a polymorphic variable with allocatable attribute '%s' is in %s clause, the behavior is unspecified"_port_en_US,
symbol->name(),
parser::ToUpperCaseLetters(getClauseName(clause).str()));
}
@ -3246,11 +3242,10 @@ void OmpStructureChecker::Enter(const parser::OmpClause::UseDevicePtr &x) {
if (const auto *name{parser::Unwrap<parser::Name>(ompObject)}) {
if (name->symbol) {
if (!(IsBuiltinCPtr(*(name->symbol)))) {
if (context_.ShouldWarn(common::UsageWarning::OpenMPUsage)) {
context_.Say(itr->second->source,
"Use of non-C_PTR type '%s' in USE_DEVICE_PTR is deprecated, use USE_DEVICE_ADDR instead"_warn_en_US,
name->ToString());
}
context_.Warn(common::UsageWarning::OpenMPUsage,
itr->second->source,
"Use of non-C_PTR type '%s' in USE_DEVICE_PTR is deprecated, use USE_DEVICE_ADDR instead"_warn_en_US,
name->ToString());
} else {
useDevicePtrNameList.push_back(*name);
}
@ -3307,20 +3302,16 @@ void OmpStructureChecker::Enter(const parser::OmpClause::IsDevicePtr &x) {
"Variable '%s' in IS_DEVICE_PTR clause must be of type C_PTR"_err_en_US,
source.ToString());
} else if (!(IsDummy(*symbol))) {
if (context_.ShouldWarn(common::UsageWarning::OpenMPUsage)) {
context_.Say(itr->second->source,
"Variable '%s' in IS_DEVICE_PTR clause must be a dummy argument. "
"This semantic check is deprecated from OpenMP 5.2 and later."_warn_en_US,
source.ToString());
}
context_.Warn(common::UsageWarning::OpenMPUsage, itr->second->source,
"Variable '%s' in IS_DEVICE_PTR clause must be a dummy argument. "
"This semantic check is deprecated from OpenMP 5.2 and later."_warn_en_US,
source.ToString());
} else if (IsAllocatableOrPointer(*symbol) || IsValue(*symbol)) {
if (context_.ShouldWarn(common::UsageWarning::OpenMPUsage)) {
context_.Say(itr->second->source,
"Variable '%s' in IS_DEVICE_PTR clause must be a dummy argument "
"that does not have the ALLOCATABLE, POINTER or VALUE attribute. "
"This semantic check is deprecated from OpenMP 5.2 and later."_warn_en_US,
source.ToString());
}
context_.Warn(common::UsageWarning::OpenMPUsage, itr->second->source,
"Variable '%s' in IS_DEVICE_PTR clause must be a dummy argument "
"that does not have the ALLOCATABLE, POINTER or VALUE attribute. "
"This semantic check is deprecated from OpenMP 5.2 and later."_warn_en_US,
source.ToString());
}
}
}

6
flang/lib/Semantics/check-return.cpp
View File

@ -36,9 +36,9 @@ void ReturnStmtChecker::Leave(const parser::ReturnStmt &returnStmt) {
IsFunction(*subprogramScope->GetSymbol()))) {
context_.Say(
"RETURN with expression is only allowed in SUBROUTINE subprogram"_err_en_US);
} else if (subprogramScope->kind() == Scope::Kind::MainProgram &&
context_.ShouldWarn(common::LanguageFeature::ProgramReturn)) {
context_.Say("RETURN should not appear in a main program"_port_en_US);
} else if (subprogramScope->kind() == Scope::Kind::MainProgram) {
context_.Warn(common::LanguageFeature::ProgramReturn,
"RETURN should not appear in a main program"_port_en_US);
}
}
}

8
flang/lib/Semantics/compute-offsets.cpp
View File

@ -167,11 +167,9 @@ void ComputeOffsetsHelper::DoCommonBlock(Symbol &commonBlock) {
auto errorSite{
commonBlock.name().empty() ? symbol.name() : commonBlock.name()};
if (std::size_t padding{DoSymbol(symbol.GetUltimate())}) {
if (context_.ShouldWarn(common::UsageWarning::CommonBlockPadding)) {
context_.Say(errorSite,
"COMMON block /%s/ requires %zd bytes of padding before '%s' for alignment"_port_en_US,
commonBlock.name(), padding, symbol.name());
}
context_.Warn(common::UsageWarning::CommonBlockPadding, errorSite,
"COMMON block /%s/ requires %zd bytes of padding before '%s' for alignment"_port_en_US,
commonBlock.name(), padding, symbol.name());
}
previous.emplace(symbol);
auto eqIter{equivalenceBlock_.end()};

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

@ -298,12 +298,10 @@ DataInitializationCompiler<DSV>::ConvertElement(
if (context.IsEnabled(common::LanguageFeature::LogicalIntegerAssignment)) {
if (MaybeExpr converted{evaluate::DataConstantConversionExtension(
exprAnalyzer_.GetFoldingContext(), type, expr)}) {
if (context.ShouldWarn(
common::LanguageFeature::LogicalIntegerAssignment)) {
context.Say(
"nonstandard usage: initialization of %s with %s"_port_en_US,
type.AsFortran(), expr.GetType().value().AsFortran());
}
context.Warn(common::LanguageFeature::LogicalIntegerAssignment,
exprAnalyzer_.GetFoldingContext().messages().at(),
"nonstandard usage: initialization of %s with %s"_port_en_US,
type.AsFortran(), expr.GetType().value().AsFortran());
return {std::make_pair(std::move(*converted), false)};
}
}
@ -434,16 +432,11 @@ bool DataInitializationCompiler<DSV>::InitElement(
// value non-pointer initialization
if (IsBOZLiteral(*expr) &&
designatorType->category() != TypeCategory::Integer) { // 8.6.7(11)
if (exprAnalyzer_.context().ShouldWarn(
common::LanguageFeature::DataStmtExtensions)) {
exprAnalyzer_.Say(
"BOZ literal should appear in a DATA statement only as a value for an integer object, but '%s' is '%s'"_port_en_US,
DescribeElement(), designatorType->AsFortran());
}
} else if (converted->second &&
exprAnalyzer_.context().ShouldWarn(
common::LanguageFeature::DataStmtExtensions)) {
exprAnalyzer_.context().Say(
exprAnalyzer_.Warn(common::LanguageFeature::DataStmtExtensions,
"BOZ literal should appear in a DATA statement only as a value for an integer object, but '%s' is '%s'"_port_en_US,
DescribeElement(), designatorType->AsFortran());
} else if (converted->second) {
exprAnalyzer_.Warn(common::LanguageFeature::DataStmtExtensions,
"DATA statement value initializes '%s' of type '%s' with CHARACTER"_port_en_US,
DescribeElement(), designatorType->AsFortran());
}
@ -462,12 +455,9 @@ bool DataInitializationCompiler<DSV>::InitElement(
} else if (status == evaluate::InitialImage::OutOfRange) {
OutOfRangeError();
} else if (status == evaluate::InitialImage::LengthMismatch) {
if (exprAnalyzer_.context().ShouldWarn(
common::UsageWarning::DataLength)) {
exprAnalyzer_.Say(
"DATA statement value '%s' for '%s' has the wrong length"_warn_en_US,
folded.AsFortran(), DescribeElement());
}
exprAnalyzer_.Warn(common::UsageWarning::DataLength,
"DATA statement value '%s' for '%s' has the wrong length"_warn_en_US,
folded.AsFortran(), DescribeElement());
return true;
} else if (status == evaluate::InitialImage::TooManyElems) {
exprAnalyzer_.Say("DATA statement has too many elements"_err_en_US);

3
flang/lib/Semantics/definable.cpp
View File

@ -349,7 +349,8 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
if (!portabilityWarning &&
scope.context().languageFeatures().ShouldWarn(
common::UsageWarning::VectorSubscriptFinalization)) {
portabilityWarning = parser::Message{at,
portabilityWarning = parser::Message{
common::UsageWarning::VectorSubscriptFinalization, at,
"Variable '%s' has a vector subscript and will be finalized by non-elemental subroutine '%s'"_port_en_US,
expr.AsFortran(), anyRankMatch->name()};
}

147
flang/lib/Semantics/expression.cpp
View File

@ -663,10 +663,8 @@ struct IntTypeVisitor {
auto unsignedNum{Int::Read(p, 10, false /*unsigned*/)};
num.value = unsignedNum.value.Negate().value;
num.overflow = unsignedNum.overflow || num.value > Int{0};
if (!num.overflow && num.value.Negate().overflow &&
analyzer.context().ShouldWarn(LanguageFeature::BigIntLiterals) &&
!analyzer.context().IsInModuleFile(digits)) {
analyzer.Say(digits,
if (!num.overflow && num.value.Negate().overflow) {
analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
"negated maximum INTEGER(KIND=%d) literal"_port_en_US, T::kind);
}
} else {
@ -677,9 +675,8 @@ struct IntTypeVisitor {
if (!isDefaultKind ||
!analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {
return std::nullopt;
} else if (analyzer.context().ShouldWarn(
LanguageFeature::BigIntLiterals)) {
analyzer.Say(digits,
} else {
analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
"Integer literal is too large for default INTEGER(KIND=%d); "
"assuming INTEGER(KIND=%d)"_port_en_US,
kind, T::kind);
@ -809,16 +806,12 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
auto kind{AnalyzeKindParam(x.kind, defaultKind)};
if (letterKind && expoLetter != 'e') {
if (kind != *letterKind) {
if (context_.ShouldWarn(
common::LanguageFeature::ExponentMatchingKindParam)) {
Say("Explicit kind parameter on real constant disagrees with exponent letter '%c'"_warn_en_US,
expoLetter);
}
} else if (x.kind &&
context_.ShouldWarn(
common::LanguageFeature::ExponentMatchingKindParam)) {
Say("Explicit kind parameter together with non-'E' exponent letter "
"is not standard"_port_en_US);
Warn(common::LanguageFeature::ExponentMatchingKindParam,
"Explicit kind parameter on real constant disagrees with exponent letter '%c'"_warn_en_US,
expoLetter);
} else if (x.kind) {
Warn(common::LanguageFeature::ExponentMatchingKindParam,
"Explicit kind parameter together with non-'E' exponent letter is not standard"_port_en_US);
}
}
auto result{common::SearchTypes(
@ -1657,11 +1650,8 @@ void ArrayConstructorContext::Push(MaybeExpr &&x) {
if (!type_) {
if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {
// Treat an array constructor of BOZ as if default integer.
if (exprAnalyzer_.context().ShouldWarn(
common::LanguageFeature::BOZAsDefaultInteger)) {
exprAnalyzer_.Say(
"BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);
}
exprAnalyzer_.Warn(common::LanguageFeature::BOZAsDefaultInteger,
"BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);
x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(
exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),
std::move(*boz)));
@ -1672,11 +1662,8 @@ void ArrayConstructorContext::Push(MaybeExpr &&x) {
if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {
if (!type_) {
// Treat an array constructor of BOZ as if default integer.
if (exprAnalyzer_.context().ShouldWarn(
common::LanguageFeature::BOZAsDefaultInteger)) {
exprAnalyzer_.Say(
"BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);
}
exprAnalyzer_.Warn(common::LanguageFeature::BOZAsDefaultInteger,
"BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);
x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(
exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),
std::move(*boz)));
@ -1740,15 +1727,12 @@ void ArrayConstructorContext::Push(MaybeExpr &&x) {
auto xLen{xType.LEN()};
if (auto thisLen{ToInt64(xLen)}) {
if (constantLength_) {
if (exprAnalyzer_.context().ShouldWarn(
common::LanguageFeature::DistinctArrayConstructorLengths) &&
*thisLen != *constantLength_) {
if (!(messageDisplayedSet_ & 1)) {
exprAnalyzer_.Say(
"Character literal in array constructor without explicit "
"type has different length than earlier elements"_port_en_US);
messageDisplayedSet_ |= 1;
}
if (*thisLen != *constantLength_ && !(messageDisplayedSet_ & 1)) {
exprAnalyzer_.Warn(
common::LanguageFeature::DistinctArrayConstructorLengths,
"Character literal in array constructor without explicit "
"type has different length than earlier elements"_port_en_US);
messageDisplayedSet_ |= 1;
}
if (*thisLen > *constantLength_) {
// Language extension: use the longest literal to determine the
@ -2091,11 +2075,9 @@ MaybeExpr ExpressionAnalyzer::Analyze(
valueType->IsEquivalentTo(*parentType)) {
symbol = &*parent;
nextAnonymous = ++parent;
if (context().ShouldWarn(LanguageFeature::AnonymousParents)) {
Say(source,
"Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
symbol->name());
}
Warn(LanguageFeature::AnonymousParents, source,
"Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
symbol->name());
break;
}
}
@ -2166,14 +2148,13 @@ MaybeExpr ExpressionAnalyzer::Analyze(
continue;
}
if (IsNullObjectPointer(*value)) {
if (context().ShouldWarn(common::LanguageFeature::
NullMoldAllocatableComponentValue)) {
AttachDeclaration(
Say(expr.source,
"NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,
symbol->name()),
*symbol);
}
AttachDeclaration(
Warn(common::LanguageFeature::
NullMoldAllocatableComponentValue,
expr.source,
"NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,
symbol->name()),
*symbol);
// proceed to check type & shape
} else {
AttachDeclaration(
@ -2459,13 +2440,11 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
sym->attrs().test(semantics::Attr::NOPASS)) {
// F'2023 C1529 seems unnecessary and most compilers don't
// enforce it.
if (context().ShouldWarn(
common::LanguageFeature::NopassScalarBase)) {
AttachDeclaration(
Say(sc.component.source,
"Base of NOPASS type-bound procedure reference should be scalar"_port_en_US),
*sym);
}
AttachDeclaration(
Warn(common::LanguageFeature::NopassScalarBase,
sc.component.source,
"Base of NOPASS type-bound procedure reference should be scalar"_port_en_US),
*sym);
} else if (IsProcedurePointer(*sym)) { // C919
Say(sc.component.source,
"Base of procedure component reference must be scalar"_err_en_US);
@ -2970,10 +2949,9 @@ void ExpressionAnalyzer::CheckBadExplicitType(
if (const auto *typeAndShape{result->GetTypeAndShape()}) {
if (auto declared{
typeAndShape->Characterize(intrinsic, GetFoldingContext())}) {
if (!declared->type().IsTkCompatibleWith(typeAndShape->type()) &&
context_.ShouldWarn(
common::UsageWarning::IgnoredIntrinsicFunctionType)) {
if (auto *msg{Say(
if (!declared->type().IsTkCompatibleWith(typeAndShape->type())) {
if (auto *msg{Warn(
common::UsageWarning::IgnoredIntrinsicFunctionType,
"The result type '%s' of the intrinsic function '%s' is not the explicit declared type '%s'"_warn_en_US,
typeAndShape->AsFortran(), intrinsic.name(),
declared->AsFortran())}) {
@ -3345,10 +3323,10 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
iter != implicitInterfaces_.end()) {
std::string whyNot;
if (!chars->IsCompatibleWith(iter->second.second,
/*ignoreImplicitVsExplicit=*/false, &whyNot) &&
context_.ShouldWarn(
common::UsageWarning::IncompatibleImplicitInterfaces)) {
if (auto *msg{Say(callSite,
/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
if (auto *msg{Warn(
common::UsageWarning::IncompatibleImplicitInterfaces,
callSite,
"Reference to the procedure '%s' has an implicit interface that is distinct from another reference: %s"_warn_en_US,
name, whyNot)}) {
msg->Attach(
@ -3558,10 +3536,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Subtract &x) {
MaybeExpr ExpressionAnalyzer::Analyze(
const parser::Expr::ComplexConstructor &z) {
if (context_.ShouldWarn(common::LanguageFeature::ComplexConstructor)) {
context_.Say(
"nonstandard usage: generalized COMPLEX constructor"_port_en_US);
}
Warn(common::LanguageFeature::ComplexConstructor,
"nonstandard usage: generalized COMPLEX constructor"_port_en_US);
return AnalyzeComplex(Analyze(std::get<0>(z.t).value()),
Analyze(std::get<1>(z.t).value()), "complex constructor");
}
@ -4040,11 +4016,9 @@ bool ExpressionAnalyzer::CheckIntrinsicKind(
return true;
} else if (foldingContext_.targetCharacteristics().CanSupportType(
category, kind)) {
if (context_.ShouldWarn(common::UsageWarning::BadTypeForTarget) &&
!context_.IsInModuleFile(GetContextualMessages().at())) {
Say("%s(KIND=%jd) is not an enabled type for this target"_warn_en_US,
ToUpperCase(EnumToString(category)), kind);
}
Warn(common::UsageWarning::BadTypeForTarget,
"%s(KIND=%jd) is not an enabled type for this target"_warn_en_US,
ToUpperCase(EnumToString(category)), kind);
return true;
} else {
Say("%s(KIND=%jd) is not a supported type"_err_en_US,
@ -4070,10 +4044,9 @@ bool ExpressionAnalyzer::CheckIntrinsicSize(
return true;
} else if (foldingContext_.targetCharacteristics().CanSupportType(
category, kind)) {
if (context_.ShouldWarn(common::UsageWarning::BadTypeForTarget)) {
Say("%s*%jd is not an enabled type for this target"_warn_en_US,
ToUpperCase(EnumToString(category)), size);
}
Warn(common::UsageWarning::BadTypeForTarget,
"%s*%jd is not an enabled type for this target"_warn_en_US,
ToUpperCase(EnumToString(category)), size);
return true;
} else {
Say("%s*%jd is not a supported type"_err_en_US,
@ -4177,13 +4150,13 @@ MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
MaybeExpr ExpressionAnalyzer::AnalyzeComplex(
MaybeExpr &&re, MaybeExpr &&im, const char *what) {
if (context().ShouldWarn(common::LanguageFeature::ComplexConstructor)) {
if (re && re->Rank() > 0) {
Say("Real part of %s is not scalar"_port_en_US, what);
}
if (im && im->Rank() > 0) {
Say("Imaginary part of %s is not scalar"_port_en_US, what);
}
if (re && re->Rank() > 0) {
Warn(common::LanguageFeature::ComplexConstructor,
"Real part of %s is not scalar"_port_en_US, what);
}
if (im && im->Rank() > 0) {
Warn(common::LanguageFeature::ComplexConstructor,
"Imaginary part of %s is not scalar"_port_en_US, what);
}
if (re && im) {
ConformabilityCheck(GetContextualMessages(), *re, *im);
@ -4594,10 +4567,8 @@ bool ArgumentAnalyzer::OkLogicalIntegerAssignment(
} else {
return false;
}
if (context_.context().ShouldWarn(
common::LanguageFeature::LogicalIntegerAssignment)) {
context_.Say(std::move(*msg));
}
context_.Warn(
common::LanguageFeature::LogicalIntegerAssignment, std::move(*msg));
return true;
}

6
flang/lib/Semantics/mod-file.cpp
View File

@ -1482,14 +1482,16 @@ Scope *ModFileReader::Read(SourceName name, std::optional<bool> isIntrinsic,
if (!checkSum) {
if (context_.ShouldWarn(common::UsageWarning::ModuleFile)) {
Say(name, ancestorName, "File has invalid checksum: %s"_warn_en_US,
sourceFile->path());
sourceFile->path())
.set_usageWarning(common::UsageWarning::ModuleFile);
}
return nullptr;
} else if (requiredHash && *requiredHash != *checkSum) {
if (context_.ShouldWarn(common::UsageWarning::ModuleFile)) {
Say(name, ancestorName,
"File is not the right module file for %s"_warn_en_US,
"'"s + name.ToString() + "': "s + sourceFile->path());
"'"s + name.ToString() + "': "s + sourceFile->path())
.set_usageWarning(common::UsageWarning::ModuleFile);
}
return nullptr;
}

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

@ -77,6 +77,8 @@ private:
const evaluate::SpecificIntrinsic *specific = nullptr);
bool LhsOkForUnlimitedPoly() const;
template <typename... A> parser::Message *Say(A &&...);
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(FeatureOrUsageWarning, A &&...);
SemanticsContext &context_;
evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
@ -215,20 +217,17 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
Say("CONTIGUOUS pointer may not be associated with a discontiguous target"_err_en_US);
return false;
}
} else if (context_.ShouldWarn(
common::UsageWarning::PointerToPossibleNoncontiguous)) {
Say("Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
} else {
Warn(common::UsageWarning::PointerToPossibleNoncontiguous,
"Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
}
}
// Warn about undefinable data targets
if (context_.ShouldWarn(common::UsageWarning::PointerToUndefinable)) {
if (auto because{WhyNotDefinable(
foldingContext_.messages().at(), scope_, {}, rhs)}) {
if (auto *msg{
Say("Pointer target is not a definable variable"_warn_en_US)}) {
msg->Attach(
std::move(because->set_severity(parser::Severity::Because)));
}
if (auto because{
WhyNotDefinable(foldingContext_.messages().at(), scope_, {}, rhs)}) {
if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
"Pointer target is not a definable variable"_warn_en_US)}) {
msg->Attach(std::move(because->set_severity(parser::Severity::Because)));
return false;
}
}
@ -270,10 +269,11 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
" that is a not a pointer"_err_en_US;
} else if (isContiguous_ &&
!funcResult->attrs.test(FunctionResult::Attr::Contiguous)) {
if (context_.ShouldWarn(
common::UsageWarning::PointerToPossibleNoncontiguous)) {
msg =
"CONTIGUOUS %s is associated with the result of reference to function '%s' that is not known to be contiguous"_warn_en_US;
auto restorer{common::ScopedSet(lhs_, symbol)};
if (Warn(common::UsageWarning::PointerToPossibleNoncontiguous,
"CONTIGUOUS %s is associated with the result of reference to function '%s' that is not known to be contiguous"_warn_en_US,
description_, funcName)) {
return false;
}
} else if (lhsType_) {
const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
@ -377,9 +377,9 @@ bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
Say(std::move(*msg), description_, rhsName, whyNot);
return false;
}
if (context_.ShouldWarn(common::UsageWarning::ProcDummyArgShapes) &&
warning) {
Say("%s and %s may not be completely compatible procedures: %s"_warn_en_US,
if (warning) {
Warn(common::UsageWarning::ProcDummyArgShapes,
"%s and %s may not be completely compatible procedures: %s"_warn_en_US,
description_, rhsName, std::move(*warning));
}
return true;
@ -396,11 +396,12 @@ bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
symbol->name());
return false;
}
} else if (symbol->has<ProcBindingDetails>() &&
context_.ShouldWarn(common::LanguageFeature::BindingAsProcedure)) {
evaluate::SayWithDeclaration(foldingContext_.messages(), *symbol,
"Procedure binding '%s' used as target of a pointer assignment"_port_en_US,
symbol->name());
} else if (symbol->has<ProcBindingDetails>()) {
evaluate::AttachDeclaration(
Warn(common::LanguageFeature::BindingAsProcedure,
"Procedure binding '%s' used as target of a pointer assignment"_port_en_US,
symbol->name()),
*symbol);
}
}
if (auto chars{
@ -447,6 +448,22 @@ parser::Message *PointerAssignmentChecker::Say(A &&...x) {
return msg;
}
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *PointerAssignmentChecker::Warn(
FeatureOrUsageWarning warning, A &&...x) {
auto *msg{context_.Warn(
warning, foldingContext_.messages().at(), std::forward<A>(x)...)};
if (msg) {
if (lhs_) {
return evaluate::AttachDeclaration(msg, *lhs_);
}
if (!source_.empty()) {
msg->Attach(source_, "Declaration of %s"_en_US, description_);
}
}
return msg;
}
// Verify that any bounds on the LHS of a pointer assignment are valid.
// Return true if it is a bound-remapping so we can perform further checks.
static bool CheckPointerBounds(

5
flang/lib/Semantics/resolve-directives.cpp
View File

@ -2888,8 +2888,7 @@ void OmpAttributeVisitor::IssueNonConformanceWarning(
default:
warnStr = "OpenMP directive '" + dirName + "' has been deprecated.";
}
if (context_.ShouldWarn(common::UsageWarning::OpenMPUsage)) {
context_.Say(source, "%s"_warn_en_US, warnStr);
}
context_.Warn(
common::UsageWarning::OpenMPUsage, source, "%s"_warn_en_US, warnStr);
}
} // namespace Fortran::semantics

28
flang/lib/Semantics/resolve-labels.cpp
View File

@ -938,7 +938,9 @@ void CheckBranchesIntoDoBody(const SourceStmtList &branches,
context
.Say(
fromPosition, "branch into loop body from outside"_warn_en_US)
.Attach(body.first, "the loop branched into"_en_US);
.Attach(body.first, "the loop branched into"_en_US)
.set_languageFeature(
common::LanguageFeature::BranchIntoConstruct);
}
}
}
@ -1007,7 +1009,9 @@ void CheckLabelDoConstraints(const SourceStmtList &dos,
.Say(position,
"A DO loop should terminate with an END DO or CONTINUE"_port_en_US)
.Attach(doTarget.parserCharBlock,
"DO loop currently ends at statement:"_en_US);
"DO loop currently ends at statement:"_en_US)
.set_languageFeature(
common::LanguageFeature::OldLabelDoEndStatements);
}
} else if (!InInclusiveScope(scopes, scope, doTarget.proxyForScope)) {
context.Say(position, "Label '%u' is not in DO loop scope"_err_en_US,
@ -1067,9 +1071,11 @@ void CheckScopeConstraints(const SourceStmtList &stmts,
SayLabel(label));
} else if (context.ShouldWarn(
common::LanguageFeature::BranchIntoConstruct)) {
context.Say(position,
"Label '%u' is in a construct that should not be used as a branch target here"_warn_en_US,
SayLabel(label));
context
.Say(position,
"Label '%u' is in a construct that should not be used as a branch target here"_warn_en_US,
SayLabel(label))
.set_languageFeature(common::LanguageFeature::BranchIntoConstruct);
}
}
}
@ -1097,7 +1103,8 @@ void CheckBranchTargetConstraints(const SourceStmtList &stmts,
.Say(branchTarget.parserCharBlock,
"Label '%u' is not a branch target"_warn_en_US, SayLabel(label))
.Attach(stmt.parserCharBlock, "Control flow use of '%u'"_en_US,
SayLabel(label));
SayLabel(label))
.set_languageFeature(common::LanguageFeature::BadBranchTarget);
}
}
}
@ -1152,9 +1159,12 @@ void CheckAssignTargetConstraints(const SourceStmtList &stmts,
"Label '%u' is not a branch target or FORMAT"_err_en_US,
SayLabel(label));
} else if (context.ShouldWarn(common::LanguageFeature::BadBranchTarget)) {
msg = &context.Say(target.parserCharBlock,
"Label '%u' is not a branch target or FORMAT"_warn_en_US,
SayLabel(label));
msg =
&context
.Say(target.parserCharBlock,
"Label '%u' is not a branch target or FORMAT"_warn_en_US,
SayLabel(label))
.set_languageFeature(common::LanguageFeature::BadBranchTarget);
}
if (msg) {
msg->Attach(stmt.parserCharBlock, "ASSIGN statement use of '%u'"_en_US,

32
flang/lib/Semantics/resolve-names-utils.cpp
View File

@ -435,6 +435,7 @@ void EquivalenceSets::FinishSet(const parser::CharBlock &source) {
// set.
bool EquivalenceSets::CheckCanEquivalence(
const parser::CharBlock &source, const Symbol &sym1, const Symbol &sym2) {
std::optional<common::LanguageFeature> feature;
std::optional<parser::MessageFixedText> msg;
const DeclTypeSpec *type1{sym1.GetType()};
const DeclTypeSpec *type2{sym2.GetType()};
@ -453,24 +454,19 @@ bool EquivalenceSets::CheckCanEquivalence(
} else if (!(isAnyNum1 || isChar1) &&
!(isAnyNum2 || isChar2)) { // C8110 - C8113
if (AreTkCompatibleTypes(type1, type2)) {
if (context_.ShouldWarn(LanguageFeature::EquivalenceSameNonSequence)) {
msg =
"nonstandard: Equivalence set contains '%s' and '%s' with same "
"type that is neither numeric nor character sequence type"_port_en_US;
}
msg =
"nonstandard: Equivalence set contains '%s' and '%s' with same type that is neither numeric nor character sequence type"_port_en_US;
feature = LanguageFeature::EquivalenceSameNonSequence;
} else {
msg = "Equivalence set cannot contain '%s' and '%s' with distinct types "
"that are not both numeric or character sequence types"_err_en_US;
}
} else if (isAnyNum1) {
if (isChar2) {
if (context_.ShouldWarn(
LanguageFeature::EquivalenceNumericWithCharacter)) {
msg = "nonstandard: Equivalence set contains '%s' that is numeric "
"sequence type and '%s' that is character"_port_en_US;
}
} else if (isAnyNum2 &&
context_.ShouldWarn(LanguageFeature::EquivalenceNonDefaultNumeric)) {
msg =
"nonstandard: Equivalence set contains '%s' that is numeric sequence type and '%s' that is character"_port_en_US;
feature = LanguageFeature::EquivalenceNumericWithCharacter;
} else if (isAnyNum2) {
if (isDefaultNum1) {
msg =
"nonstandard: Equivalence set contains '%s' that is a default "
@ -479,12 +475,16 @@ bool EquivalenceSets::CheckCanEquivalence(
msg = "nonstandard: Equivalence set contains '%s' and '%s' that are "
"numeric sequence types with non-default kinds"_port_en_US;
}
feature = LanguageFeature::EquivalenceNonDefaultNumeric;
}
}
if (msg &&
(!context_.IsInModuleFile(source) ||
msg->severity() == parser::Severity::Error)) {
context_.Say(source, std::move(*msg), sym1.name(), sym2.name());
if (msg) {
if (feature) {
context_.Warn(
*feature, source, std::move(*msg), sym1.name(), sym2.name());
} else {
context_.Say(source, std::move(*msg), sym1.name(), sym2.name());
}
return false;
}
return true;

305
flang/lib/Semantics/resolve-names.cpp
View File

@ -540,15 +540,16 @@ public:
void SayWithReason(
const parser::Name &, Symbol &, MessageFixedText &&, Message &&);
template <typename... A>
void SayWithDecl(
Message &SayWithDecl(
const parser::Name &, Symbol &, MessageFixedText &&, A &&...args);
void SayLocalMustBeVariable(const parser::Name &, Symbol &);
void SayDerivedType(const SourceName &, MessageFixedText &&, const Scope &);
void Say2(const SourceName &, MessageFixedText &&, const SourceName &,
Message &SayDerivedType(
const SourceName &, MessageFixedText &&, const Scope &);
Message &Say2(const SourceName &, MessageFixedText &&, const SourceName &,
MessageFixedText &&);
void Say2(
Message &Say2(
const SourceName &, MessageFixedText &&, Symbol &, MessageFixedText &&);
void Say2(
Message &Say2(
const parser::Name &, MessageFixedText &&, Symbol &, MessageFixedText &&);
// Search for symbol by name in current, parent derived type, and
@ -1867,11 +1868,10 @@ bool AttrsVisitor::Pre(const parser::Pass &x) {
bool AttrsVisitor::IsDuplicateAttr(Attr attrName) {
CHECK(attrs_);
if (attrs_->test(attrName)) {
if (context().ShouldWarn(common::LanguageFeature::RedundantAttribute)) {
Say(currStmtSource().value(),
"Attribute '%s' cannot be used more than once"_warn_en_US,
AttrToString(attrName));
}
context().Warn(common::LanguageFeature::RedundantAttribute,
currStmtSource().value(),
"Attribute '%s' cannot be used more than once"_warn_en_US,
AttrToString(attrName));
return true;
}
return false;
@ -2283,7 +2283,7 @@ void ScopeHandler::SayWithReason(const parser::Name &name, Symbol &symbol,
}
template <typename... A>
void ScopeHandler::SayWithDecl(const parser::Name &name, Symbol &symbol,
Message &ScopeHandler::SayWithDecl(const parser::Name &name, Symbol &symbol,
MessageFixedText &&msg, A &&...args) {
auto &message{
Say(name.source, std::move(msg), symbol.name(), std::forward<A>(args)...)
@ -2299,6 +2299,7 @@ void ScopeHandler::SayWithDecl(const parser::Name &name, Symbol &symbol,
}
}
}
return message;
}
void ScopeHandler::SayLocalMustBeVariable(
@ -2308,28 +2309,31 @@ void ScopeHandler::SayLocalMustBeVariable(
" in a locality-spec"_err_en_US);
}
void ScopeHandler::SayDerivedType(
Message &ScopeHandler::SayDerivedType(
const SourceName &name, MessageFixedText &&msg, const Scope &type) {
const Symbol &typeSymbol{DEREF(type.GetSymbol())};
Say(name, std::move(msg), name, typeSymbol.name())
return Say(name, std::move(msg), name, typeSymbol.name())
.Attach(typeSymbol.name(), "Declaration of derived type '%s'"_en_US,
typeSymbol.name());
}
void ScopeHandler::Say2(const SourceName &name1, MessageFixedText &&msg1,
Message &ScopeHandler::Say2(const SourceName &name1, MessageFixedText &&msg1,
const SourceName &name2, MessageFixedText &&msg2) {
Say(name1, std::move(msg1)).Attach(name2, std::move(msg2), name2);
return Say(name1, std::move(msg1)).Attach(name2, std::move(msg2), name2);
}
void ScopeHandler::Say2(const SourceName &name, MessageFixedText &&msg1,
Message &ScopeHandler::Say2(const SourceName &name, MessageFixedText &&msg1,
Symbol &symbol, MessageFixedText &&msg2) {
bool isFatal{msg1.IsFatal()};
Say2(name, std::move(msg1), symbol.name(), std::move(msg2));
Message &result{Say2(name, std::move(msg1), symbol.name(), std::move(msg2))};
context().SetError(symbol, isFatal);
return result;
}
void ScopeHandler::Say2(const parser::Name &name, MessageFixedText &&msg1,
Message &ScopeHandler::Say2(const parser::Name &name, MessageFixedText &&msg1,
Symbol &symbol, MessageFixedText &&msg2) {
bool isFatal{msg1.IsFatal()};
Say2(name.source, std::move(msg1), symbol.name(), std::move(msg2));
Message &result{
Say2(name.source, std::move(msg1), symbol.name(), std::move(msg2))};
context().SetError(symbol, isFatal);
return result;
}
// This is essentially GetProgramUnitContaining(), but it can return
@ -2613,11 +2617,9 @@ bool ScopeHandler::ImplicitlyTypeForwardRef(Symbol &symbol) {
return false;
}
// TODO: check no INTENT(OUT) if dummy?
if (context().ShouldWarn(common::LanguageFeature::ForwardRefImplicitNone)) {
Say(symbol.name(),
"'%s' was used without (or before) being explicitly typed"_warn_en_US,
symbol.name());
}
context().Warn(common::LanguageFeature::ForwardRefImplicitNone, symbol.name(),
"'%s' was used without (or before) being explicitly typed"_warn_en_US,
symbol.name());
symbol.set(Symbol::Flag::Implicit);
symbol.SetType(*type);
return true;
@ -3391,21 +3393,21 @@ void ModuleVisitor::AddAndCheckModuleUse(SourceName name, bool isIntrinsic) {
if (isIntrinsic) {
if (auto iter{nonIntrinsicUses_.find(name)};
iter != nonIntrinsicUses_.end()) {
if (context().ShouldWarn(common::LanguageFeature::MiscUseExtensions)) {
Say(name,
"Should not USE the intrinsic module '%s' in the same scope as a USE of the non-intrinsic module"_port_en_US,
name)
.Attach(*iter, "Previous USE of '%s'"_en_US, *iter);
if (auto *msg{context().Warn(common::LanguageFeature::MiscUseExtensions,
name,
"Should not USE the intrinsic module '%s' in the same scope as a USE of the non-intrinsic module"_port_en_US,
name)}) {
msg->Attach(*iter, "Previous USE of '%s'"_en_US, *iter);
}
}
intrinsicUses_.insert(name);
} else {
if (auto iter{intrinsicUses_.find(name)}; iter != intrinsicUses_.end()) {
if (context().ShouldWarn(common::LanguageFeature::MiscUseExtensions)) {
Say(name,
"Should not USE the non-intrinsic module '%s' in the same scope as a USE of the intrinsic module"_port_en_US,
name)
.Attach(*iter, "Previous USE of '%s'"_en_US, *iter);
if (auto *msg{context().Warn(common::LanguageFeature::MiscUseExtensions,
name,
"Should not USE the non-intrinsic module '%s' in the same scope as a USE of the intrinsic module"_port_en_US,
name)}) {
msg->Attach(*iter, "Previous USE of '%s'"_en_US, *iter);
}
}
nonIntrinsicUses_.insert(name);
@ -3675,11 +3677,11 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
ResolveSpecificsInGeneric(generic, true);
auto &details{generic.get<GenericDetails>()};
if (auto *proc{details.CheckSpecific()}) {
if (context().ShouldWarn(common::UsageWarning::HomonymousSpecific)) {
Say(proc->name().begin() > generic.name().begin() ? proc->name()
: generic.name(),
"'%s' should not be the name of both a generic interface and a procedure unless it is a specific procedure of the generic"_warn_en_US);
}
context().Warn(common::UsageWarning::HomonymousSpecific,
proc->name().begin() > generic.name().begin() ? proc->name()
: generic.name(),
"'%s' should not be the name of both a generic interface and a procedure unless it is a specific procedure of the generic"_warn_en_US,
generic.name());
}
auto &specifics{details.specificProcs()};
if (specifics.empty()) {
@ -3697,19 +3699,23 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
subroutine = &specific;
if (details.derivedType() &&
context().ShouldWarn(
common::LanguageFeature::SubroutineAndFunctionSpecifics)) {
common::LanguageFeature::SubroutineAndFunctionSpecifics) &&
!InModuleFile()) {
SayDerivedType(generic.name(),
"Generic interface '%s' should only contain functions due to derived type with same name"_warn_en_US,
*details.derivedType()->GetUltimate().scope());
*details.derivedType()->GetUltimate().scope())
.set_languageFeature(
common::LanguageFeature::SubroutineAndFunctionSpecifics);
}
}
if (function && subroutine) {
if (context().ShouldWarn(common::LanguageFeature::
SubroutineAndFunctionSpecifics)) { // C1514
auto &msg{Say(generic.name(),
"Generic interface '%s' has both a function and a subroutine"_warn_en_US)};
msg.Attach(function->name(), "Function declaration"_en_US);
msg.Attach(subroutine->name(), "Subroutine declaration"_en_US);
if (function && subroutine) { // F'2023 C1514
if (auto *msg{context().Warn(
common::LanguageFeature::SubroutineAndFunctionSpecifics,
generic.name(),
"Generic interface '%s' has both a function and a subroutine"_warn_en_US,
generic.name())}) {
msg->Attach(function->name(), "Function declaration"_en_US)
.Attach(subroutine->name(), "Subroutine declaration"_en_US);
}
break;
}
@ -3738,11 +3744,10 @@ bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) {
return false;
}
if (IsHostAssociated(*symbol, currScope())) {
if (context().ShouldWarn(
common::LanguageFeature::StatementFunctionExtensions)) {
Say(name,
"Name '%s' from host scope should have a type declaration before its local statement function definition"_port_en_US);
}
context().Warn(common::LanguageFeature::StatementFunctionExtensions,
name.source,
"Name '%s' from host scope should have a type declaration before its local statement function definition"_port_en_US,
name.source);
MakeSymbol(name, Attrs{}, UnknownDetails{});
} else if (auto *entity{ultimate.detailsIf<EntityDetails>()};
entity && !ultimate.has<ProcEntityDetails>()) {
@ -3844,12 +3849,10 @@ bool SubprogramVisitor::Pre(const parser::PrefixSpec::Attributes &attrs) {
(*current == common::CUDASubprogramAttrs::HostDevice &&
(attr == common::CUDASubprogramAttrs::Host ||
attr == common::CUDASubprogramAttrs::Device))) {
if (context().ShouldWarn(
common::LanguageFeature::RedundantAttribute)) {
Say(currStmtSource().value(),
"ATTRIBUTES(%s) appears more than once"_warn_en_US,
common::EnumToString(attr));
}
context().Warn(common::LanguageFeature::RedundantAttribute,
currStmtSource().value(),
"ATTRIBUTES(%s) appears more than once"_warn_en_US,
common::EnumToString(attr));
} else if ((attr == common::CUDASubprogramAttrs::Host ||
attr == common::CUDASubprogramAttrs::Device) &&
(*current == common::CUDASubprogramAttrs::Host ||
@ -4054,13 +4057,12 @@ void SubprogramVisitor::Post(const parser::FunctionStmt &stmt) {
}
// C1560.
if (info.resultName && !distinctResultName) {
if (context().ShouldWarn(common::UsageWarning::HomonymousResult)) {
Say(info.resultName->source,
"The function name should not appear in RESULT; references to '%s' "
"inside the function will be considered as references to the "
"result only"_warn_en_US,
name.source);
}
context().Warn(common::UsageWarning::HomonymousResult,
info.resultName->source,
"The function name should not appear in RESULT; references to '%s' "
"inside the function will be considered as references to the "
"result only"_warn_en_US,
name.source);
// RESULT name was ignored above, the only side effect from doing so will be
// the inability to make recursive calls. The related parser::Name is still
// resolved to the created function result symbol because every parser::Name
@ -4468,10 +4470,9 @@ bool SubprogramVisitor::HandlePreviousCalls(
if (symbol.attrs().test(Attr::EXTERNAL) &&
!symbol.implicitAttrs().test(Attr::EXTERNAL)) {
// Warn if external statement previously declared.
if (context().ShouldWarn(common::LanguageFeature::RedundantAttribute)) {
Say(name,
"EXTERNAL attribute was already specified on '%s'"_warn_en_US);
}
context().Warn(common::LanguageFeature::RedundantAttribute, name.source,
"EXTERNAL attribute was already specified on '%s'"_warn_en_US,
name.source);
} else if (symbol.test(other)) {
Say2(name,
subpFlag == Symbol::Flag::Function
@ -4924,11 +4925,10 @@ bool DeclarationVisitor::Pre(const parser::ExternalStmt &x) {
if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
if (details->isInterface()) {
// Warn if interface previously declared.
if (context().ShouldWarn(
common::LanguageFeature::RedundantAttribute)) {
Say(name,
"EXTERNAL attribute was already specified on '%s'"_warn_en_US);
}
context().Warn(common::LanguageFeature::RedundantAttribute,
name.source,
"EXTERNAL attribute was already specified on '%s'"_warn_en_US,
name.source);
}
} else {
SayWithDecl(
@ -4973,14 +4973,12 @@ void DeclarationVisitor::DeclareIntrinsic(const parser::Name &name) {
if (symbol.GetType()) {
// These warnings are worded so that they should make sense in either
// order.
if (context().ShouldWarn(
common::UsageWarning::IgnoredIntrinsicFunctionType)) {
Say(symbol.name(),
"Explicit type declaration ignored for intrinsic function '%s'"_warn_en_US,
symbol.name())
.Attach(name.source,
"INTRINSIC statement for explicitly-typed '%s'"_en_US,
name.source);
if (auto *msg{context().Warn(
common::UsageWarning::IgnoredIntrinsicFunctionType, symbol.name(),
"Explicit type declaration ignored for intrinsic function '%s'"_warn_en_US,
symbol.name())}) {
msg->Attach(name.source,
"INTRINSIC statement for explicitly-typed '%s'"_en_US, name.source);
}
}
if (!symbol.test(Symbol::Flag::Function) &&
@ -5047,11 +5045,10 @@ Symbol &DeclarationVisitor::HandleAttributeStmt(
}
} else if (symbol && symbol->has<UseDetails>()) {
if (symbol->GetUltimate().attrs().test(attr)) {
if (context().ShouldWarn(common::LanguageFeature::RedundantAttribute)) {
Say(currStmtSource().value(),
"Use-associated '%s' already has '%s' attribute"_warn_en_US,
name.source, EnumToString(attr));
}
context().Warn(common::LanguageFeature::RedundantAttribute,
currStmtSource().value(),
"Use-associated '%s' already has '%s' attribute"_warn_en_US,
name.source, EnumToString(attr));
} else {
Say(currStmtSource().value(),
"Cannot change %s attribute on use-associated '%s'"_err_en_US,
@ -5193,10 +5190,9 @@ Symbol &DeclarationVisitor::DeclareObjectEntity(
context().SetError(symbol);
}
} else if (MustBeScalar(symbol)) {
if (context().ShouldWarn(common::UsageWarning::PreviousScalarUse)) {
Say(name,
"'%s' appeared earlier as a scalar actual argument to a specification function"_warn_en_US);
}
context().Warn(common::UsageWarning::PreviousScalarUse, name.source,
"'%s' appeared earlier as a scalar actual argument to a specification function"_warn_en_US,
name.source);
} else if (details->init() || symbol.test(Symbol::Flag::InDataStmt)) {
Say(name, "'%s' was initialized earlier as a scalar"_err_en_US);
} else {
@ -5554,10 +5550,8 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
details.set_sequence(true);
if (componentDefs.empty()) {
// F'2023 C745 - not enforced by any compiler
if (context().ShouldWarn(common::LanguageFeature::EmptySequenceType)) {
Say(stmt.source,
"A sequence type should have at least one component"_warn_en_US);
}
context().Warn(common::LanguageFeature::EmptySequenceType, stmt.source,
"A sequence type should have at least one component"_warn_en_US);
}
if (!details.paramDeclOrder().empty()) { // C740
Say(stmt.source,
@ -5683,17 +5677,15 @@ bool DeclarationVisitor::Pre(const parser::PrivateStmt &) {
} else if (!derivedTypeInfo_.privateComps) {
derivedTypeInfo_.privateComps = true;
} else { // C738
if (context().ShouldWarn(common::LanguageFeature::RedundantAttribute)) {
Say("PRIVATE should not appear more than once in derived type components"_warn_en_US);
}
context().Warn(common::LanguageFeature::RedundantAttribute,
"PRIVATE should not appear more than once in derived type components"_warn_en_US);
}
return false;
}
bool DeclarationVisitor::Pre(const parser::SequenceStmt &) {
if (derivedTypeInfo_.sequence) { // C738
if (context().ShouldWarn(common::LanguageFeature::RedundantAttribute)) {
Say("SEQUENCE should not appear more than once in derived type components"_warn_en_US);
}
context().Warn(common::LanguageFeature::RedundantAttribute,
"SEQUENCE should not appear more than once in derived type components"_warn_en_US);
}
derivedTypeInfo_.sequence = true;
return false;
@ -5800,9 +5792,8 @@ bool DeclarationVisitor::Pre(const parser::DataComponentDefStmt &x) {
!InModuleFile()) {
if (GetAttrs().test(Attr::POINTER) &&
context().IsEnabled(common::LanguageFeature::PointerInSeqType)) {
if (context().ShouldWarn(common::LanguageFeature::PointerInSeqType)) {
Say("A sequence type data component that is a pointer to a non-sequence type is not standard"_port_en_US);
}
context().Warn(common::LanguageFeature::PointerInSeqType,
"A sequence type data component that is a pointer to a non-sequence type is not standard"_port_en_US);
} else {
Say("A sequence type data component must either be of an intrinsic type or a derived sequence type"_err_en_US);
}
@ -6219,11 +6210,11 @@ void DeclarationVisitor::Post(const parser::BasedPointer &bp) {
}
if (const auto *pointeeType{pointee->GetType()}) {
if (const auto *derived{pointeeType->AsDerived()}) {
if (!IsSequenceOrBindCType(derived) &&
context().ShouldWarn(
common::LanguageFeature::NonSequenceCrayPointee)) {
Say(pointeeName,
"Type of Cray pointee '%s' is a derived type that is neither SEQUENCE nor BIND(C)"_warn_en_US);
if (!IsSequenceOrBindCType(derived)) {
context().Warn(common::LanguageFeature::NonSequenceCrayPointee,
pointeeName.source,
"Type of Cray pointee '%s' is a derived type that is neither SEQUENCE nor BIND(C)"_warn_en_US,
pointeeName.source);
}
}
}
@ -6372,7 +6363,8 @@ void DeclarationVisitor::CheckSaveStmts() {
if (context().ShouldWarn(common::LanguageFeature::RedundantAttribute)) {
Say2(name,
"Explicit SAVE of '%s' is redundant due to global SAVE statement"_warn_en_US,
*specPartState_.saveInfo.saveAll, "Global SAVE statement"_en_US);
*specPartState_.saveInfo.saveAll, "Global SAVE statement"_en_US)
.set_languageFeature(common::LanguageFeature::RedundantAttribute);
}
} else if (!IsSaved(*symbol)) {
SetExplicitAttr(*symbol, Attr::SAVE);
@ -6418,7 +6410,8 @@ void DeclarationVisitor::AddSaveName(
if (!pair.second &&
context().ShouldWarn(common::LanguageFeature::RedundantAttribute)) {
Say2(name, "SAVE attribute was already specified on '%s'"_warn_en_US,
*pair.first, "Previous specification of SAVE attribute"_en_US);
*pair.first, "Previous specification of SAVE attribute"_en_US)
.set_languageFeature(common::LanguageFeature::RedundantAttribute);
}
}
@ -6728,11 +6721,11 @@ void DeclarationVisitor::SetType(
}
auto *prevType{symbol.GetType()};
if (!prevType) {
if (symbol.test(Symbol::Flag::InDataStmt) && isImplicitNoneType() &&
context().ShouldWarn(
common::LanguageFeature::ForwardRefImplicitNoneData)) {
Say(name,
"'%s' appeared in a DATA statement before its type was declared under IMPLICIT NONE(TYPE)"_port_en_US);
if (symbol.test(Symbol::Flag::InDataStmt) && isImplicitNoneType()) {
context().Warn(common::LanguageFeature::ForwardRefImplicitNoneData,
name.source,
"'%s' appeared in a DATA statement before its type was declared under IMPLICIT NONE(TYPE)"_port_en_US,
name.source);
}
symbol.SetType(type);
} else if (symbol.has<UseDetails>()) {
@ -6877,6 +6870,7 @@ bool DeclarationVisitor::OkToAddComponent(
CHECK(scope->IsDerivedType());
if (auto *prev{FindInScope(*scope, name.source)}) {
std::optional<parser::MessageFixedText> msg;
std::optional<common::UsageWarning> warning;
if (context().HasError(*prev)) { // don't pile on
} else if (extends) {
msg = "Type cannot be extended as it has a component named"
@ -6887,24 +6881,28 @@ bool DeclarationVisitor::OkToAddComponent(
common::UsageWarning::RedeclaredInaccessibleComponent)) {
msg =
"Component '%s' is inaccessibly declared in or as a parent of this derived type"_warn_en_US;
warning = common::UsageWarning::RedeclaredInaccessibleComponent;
}
} else if (prev->test(Symbol::Flag::ParentComp)) {
msg = "'%s' is a parent type of this type and so cannot be"
" a component"_err_en_US;
msg =
"'%s' is a parent type of this type and so cannot be a component"_err_en_US;
} else if (scope == &currScope()) {
msg = "Component '%s' is already declared in this"
" derived type"_err_en_US;
msg =
"Component '%s' is already declared in this derived type"_err_en_US;
} else {
msg = "Component '%s' is already declared in a parent of this"
" derived type"_err_en_US;
msg =
"Component '%s' is already declared in a parent of this derived type"_err_en_US;
}
if (msg) {
Say2(
name, std::move(*msg), *prev, "Previous declaration of '%s'"_en_US);
auto &said{Say2(name, std::move(*msg), *prev,
"Previous declaration of '%s'"_en_US)};
if (msg->severity() == parser::Severity::Error) {
Resolve(name, *prev);
return false;
}
if (warning) {
said.set_usageWarning(*warning);
}
}
}
if (scope == &currScope() && extends) {
@ -6946,7 +6944,9 @@ void ConstructVisitor::ResolveIndexName(
context().ShouldWarn(
common::LanguageFeature::OddIndexVariableRestrictions)) {
SayWithDecl(name, *prev,
"Index variable '%s' should not also be an index in an enclosing FORALL or DO CONCURRENT"_port_en_US);
"Index variable '%s' should not also be an index in an enclosing FORALL or DO CONCURRENT"_port_en_US)
.set_languageFeature(
common::LanguageFeature::OddIndexVariableRestrictions);
}
name.symbol = nullptr;
}
@ -6969,13 +6969,17 @@ void ConstructVisitor::ResolveIndexName(
context().ShouldWarn(
common::LanguageFeature::OddIndexVariableRestrictions)) {
SayWithDecl(name, *prev,
"Index variable '%s' should be scalar in the enclosing scope"_port_en_US);
"Index variable '%s' should be scalar in the enclosing scope"_port_en_US)
.set_languageFeature(
common::LanguageFeature::OddIndexVariableRestrictions);
}
} else if (!prevRoot.has<CommonBlockDetails>() &&
context().ShouldWarn(
common::LanguageFeature::OddIndexVariableRestrictions)) {
SayWithDecl(name, *prev,
"Index variable '%s' should be a scalar object or common block if it is present in the enclosing scope"_port_en_US);
"Index variable '%s' should be a scalar object or common block if it is present in the enclosing scope"_port_en_US)
.set_languageFeature(
common::LanguageFeature::OddIndexVariableRestrictions);
}
}
EvaluateExpr(parser::Scalar{parser::Integer{common::Clone(name)}});
@ -7022,10 +7026,9 @@ bool ConstructVisitor::Pre(const parser::LocalitySpec::Reduce &x) {
bool ConstructVisitor::Pre(const parser::LocalitySpec::Shared &x) {
for (const auto &name : x.v) {
if (!FindSymbol(name)) {
if (context().ShouldWarn(common::UsageWarning::ImplicitShared)) {
Say(name,
"Variable '%s' with SHARED locality implicitly declared"_warn_en_US);
}
context().Warn(common::UsageWarning::ImplicitShared, name.source,
"Variable '%s' with SHARED locality implicitly declared"_warn_en_US,
name.source);
}
Symbol &prev{FindOrDeclareEnclosingEntity(name)};
if (PassesSharedLocalityChecks(name, prev)) {
@ -7403,7 +7406,8 @@ bool ConstructVisitor::CheckDef(const std::optional<parser::Name> &x) {
if (Symbol *
other{FindInScopeOrBlockConstructs(InclusiveScope(), x->source)}) {
SayWithDecl(*x, *other,
"The construct name '%s' should be distinct at the subprogram level"_port_en_US);
"The construct name '%s' should be distinct at the subprogram level"_port_en_US)
.set_languageFeature(common::LanguageFeature::BenignNameClash);
}
}
MakeSymbol(*x, MiscDetails{MiscDetails::Kind::ConstructName});
@ -7827,10 +7831,9 @@ bool ResolveNamesVisitor::Pre(const parser::ImportStmt &x) {
scope.add_importName(name.source);
if (Symbol * symbol{FindInScope(name)}) {
if (outer->GetUltimate() == symbol->GetUltimate()) {
if (context().ShouldWarn(common::LanguageFeature::BenignNameClash)) {
Say(name,
"The same '%s' is already present in this scope"_port_en_US);
}
context().Warn(common::LanguageFeature::BenignNameClash, name.source,
"The same '%s' is already present in this scope"_port_en_US,
name.source);
} else {
Say(name,
"A distinct '%s' is already present in this scope"_err_en_US)
@ -7924,11 +7927,9 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
}
if (checkIndexUseInOwnBounds_ &&
*checkIndexUseInOwnBounds_ == name.source && !InModuleFile()) {
if (context().ShouldWarn(common::LanguageFeature::ImpliedDoIndexScope)) {
Say(name,
"Implied DO index '%s' uses an object of the same name in its bounds expressions"_port_en_US,
name.source);
}
context().Warn(common::LanguageFeature::ImpliedDoIndexScope, name.source,
"Implied DO index '%s' uses an object of the same name in its bounds expressions"_port_en_US,
name.source);
}
return &name;
}
@ -8498,13 +8499,13 @@ Symbol &ModuleVisitor::SetAccess(
if (attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE})) {
// PUBLIC/PRIVATE already set: make it a fatal error if it changed
Attr prev{attrs.test(Attr::PUBLIC) ? Attr::PUBLIC : Attr::PRIVATE};
if (attr != prev ||
context().ShouldWarn(common::LanguageFeature::RedundantAttribute)) {
if (attr != prev) {
Say(name,
WithSeverity(
"The accessibility of '%s' has already been specified as %s"_warn_en_US,
attr != prev ? parser::Severity::Error
: parser::Severity::Warning),
"The accessibility of '%s' has already been specified as %s"_err_en_US,
MakeOpName(name), EnumToString(prev));
} else {
context().Warn(common::LanguageFeature::RedundantAttribute, name,
"The accessibility of '%s' has already been specified as %s"_warn_en_US,
MakeOpName(name), EnumToString(prev));
}
} else {
@ -9103,7 +9104,8 @@ void ResolveNamesVisitor::Post(const parser::CompilerDirective &x) {
}
}
} else if (context().ShouldWarn(common::UsageWarning::IgnoredDirective)) {
Say(x.source, "Unrecognized compiler directive was ignored"_warn_en_US);
Say(x.source, "Unrecognized compiler directive was ignored"_warn_en_US)
.set_usageWarning(common::UsageWarning::IgnoredDirective);
}
}
@ -9165,7 +9167,8 @@ bool ResolveNamesVisitor::Pre(const parser::Program &x) {
if (auto iter{uses.find(name)}; iter != uses.end()) {
if (context().ShouldWarn(common::LanguageFeature::MiscUseExtensions)) {
Say(name,
"A USE statement referencing module '%s' appears earlier in this compilation unit"_port_en_US)
"A USE statement referencing module '%s' appears earlier in this compilation unit"_port_en_US,
name)
.Attach(*iter, "First USE of module"_en_US);
}
disordered = true;
@ -9203,7 +9206,7 @@ bool ResolveNamesVisitor::Pre(const parser::Program &x) {
}
}
if (!ok) {
parser::Message *msg{nullptr};
Message *msg{nullptr};
for (const auto &pair : modules) {
if (msg) {
msg->Attach(pair.first, "Module in a cycle"_en_US);

41
flang/lib/Semantics/semantics.cpp
View File

@ -181,7 +181,7 @@ static void WarnUndefinedFunctionResult(
}
}
if (!wasDefined) {
context.Say(
context.Warn(common::UsageWarning::UndefinedFunctionResult,
symbol->name(), "Function result is never defined"_warn_en_US);
}
}
@ -222,10 +222,7 @@ static bool PerformStatementSemantics(
SemanticsVisitor<CUDAChecker>{context}.Walk(program);
}
if (!context.messages().AnyFatalError()) {
// Do this if all messages are only warnings
if (context.ShouldWarn(common::UsageWarning::UndefinedFunctionResult)) {
WarnUndefinedFunctionResult(context, context.globalScope());
}
WarnUndefinedFunctionResult(context, context.globalScope());
}
if (!context.AnyFatalError()) {
pass2.CompileDataInitializationsIntoInitializers();
@ -285,15 +282,15 @@ public:
info.initialization = common;
}
}
if (common.size() != info.biggestSize->size() && !common.name().empty() &&
context.ShouldWarn(common::LanguageFeature::DistinctCommonSizes)) {
context
.Say(common.name(),
if (common.size() != info.biggestSize->size() && !common.name().empty()) {
if (auto *msg{context.Warn(common::LanguageFeature::DistinctCommonSizes,
common.name(),
"A named COMMON block should have the same size everywhere it appears (%zd bytes here)"_port_en_US,
common.size())
.Attach(info.biggestSize->name(),
"Previously defined with a size of %zd bytes"_en_US,
info.biggestSize->size());
common.size())}) {
msg->Attach(info.biggestSize->name(),
"Previously defined with a size of %zd bytes"_en_US,
info.biggestSize->size());
}
}
if (common.size() > info.biggestSize->size()) {
info.biggestSize = common;
@ -473,22 +470,28 @@ void SemanticsContext::PopConstruct() {
constructStack_.pop_back();
}
void SemanticsContext::CheckIndexVarRedefine(const parser::CharBlock &location,
const Symbol &variable, parser::MessageFixedText &&message) {
parser::Message *SemanticsContext::CheckIndexVarRedefine(
const parser::CharBlock &location, const Symbol &variable,
parser::MessageFixedText &&message) {
const Symbol &symbol{ResolveAssociations(variable)};
auto it{activeIndexVars_.find(symbol)};
if (it != activeIndexVars_.end()) {
std::string kind{EnumToString(it->second.kind)};
Say(location, std::move(message), kind, symbol.name())
.Attach(it->second.location, "Enclosing %s construct"_en_US, kind);
return &Say(location, std::move(message), kind, symbol.name())
.Attach(
it->second.location, "Enclosing %s construct"_en_US, kind);
} else {
return nullptr;
}
}
void SemanticsContext::WarnIndexVarRedefine(
const parser::CharBlock &location, const Symbol &variable) {
if (ShouldWarn(common::UsageWarning::IndexVarRedefinition)) {
CheckIndexVarRedefine(location, variable,
"Possible redefinition of %s variable '%s'"_warn_en_US);
if (auto *msg{CheckIndexVarRedefine(location, variable,
"Possible redefinition of %s variable '%s'"_warn_en_US)}) {
msg->set_usageWarning(common::UsageWarning::IndexVarRedefinition);
}
}
}