[flang-commits] [flang] [flang] Ensure that portability warnings are conditional (PR #71857)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Nov 9 11:47:02 PST 2023
https://github.com/klausler created https://github.com/llvm/llvm-project/pull/71857
Before emitting a warning message, code should check that the usage in question should be diagnosed by calling ShouldWarn(). A fair number of sites in the code do not, and can emit portability warnings unconditionally, which can confuse a user that hasn't asked for them (-pedantic) and isn't terribly concerned about portability *to* other compilers.
Add calls to ShouldWarn() or IsEnabled() around messages that need them, and add -pedantic to tests that now require it to test their portability messages, and add more expected message lines to those tests when -pedantic causes other diagnostics to fire.
>From 81d1cc753ad6fb5b8ecd4ec5f6a5202fe4dcff9b Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 9 Nov 2023 11:28:01 -0800
Subject: [PATCH] [flang] Ensure that portability warnings are conditional
Before emitting a warning message, code should check that
the usage in question should be diagnosed by calling
ShouldWarn(). A fair number of sites in the code do not,
and can emit portability warnings unconditionally, which
can confuse a user that hasn't asked for them (-pedantic)
and isn't terribly concerned about portability *to* other
compilers.
Add calls to ShouldWarn() or IsEnabled() around messages
that need them, and add -pedantic to tests that now require
it to test their portability messages, and add more expected
message lines to those tests when -pedantic causes other
diagnostics to fire.
---
flang/include/flang/Common/Fortran-features.h | 13 +-
flang/include/flang/Evaluate/common.h | 22 ++-
flang/include/flang/Lower/Bridge.h | 13 +-
flang/lib/Evaluate/check-expression.cpp | 73 +++++--
flang/lib/Evaluate/intrinsics.cpp | 68 ++++---
flang/lib/Frontend/FrontendActions.cpp | 3 +-
flang/lib/Lower/Bridge.cpp | 9 +-
flang/lib/Parser/expr-parsers.cpp | 6 +-
flang/lib/Parser/prescan.cpp | 28 ++-
flang/lib/Semantics/check-allocate.cpp | 8 +-
flang/lib/Semantics/check-call.cpp | 96 +++++----
flang/lib/Semantics/check-data.cpp | 28 ++-
flang/lib/Semantics/check-declarations.cpp | 187 +++++++++++-------
.../lib/Semantics/check-directive-structure.h | 37 ++--
flang/lib/Semantics/check-do-forall.cpp | 8 +-
flang/lib/Semantics/check-omp-structure.cpp | 23 ++-
flang/lib/Semantics/compute-offsets.cpp | 8 +-
flang/lib/Semantics/data-to-inits.cpp | 13 +-
flang/lib/Semantics/expression.cpp | 44 +++--
flang/lib/Semantics/pointer-assignment.cpp | 2 +-
flang/lib/Semantics/resolve-names.cpp | 61 +++---
flang/lib/Semantics/semantics.cpp | 5 +-
flang/test/Evaluate/folding04.f90 | 6 +-
flang/test/Evaluate/folding06.f90 | 8 +-
flang/test/Parser/badlabel.f | 2 +-
.../test/Parser/continuation-before-quote.f90 | 2 +-
flang/test/Parser/excessive-continuations.f90 | 2 +-
flang/test/Semantics/OpenACC/acc-branch.f90 | 6 +-
flang/test/Semantics/OpenACC/acc-data.f90 | 2 +-
flang/test/Semantics/OpenACC/acc-serial.f90 | 2 +-
flang/test/Semantics/OpenMP/copying.f90 | 2 +-
.../Semantics/OpenMP/declare-target03.f90 | 2 +-
flang/test/Semantics/OpenMP/nested-target.f90 | 2 +-
.../test/Semantics/OpenMP/threadprivate03.f90 | 2 +-
flang/test/Semantics/allocate09.f90 | 2 +-
flang/test/Semantics/associated.f90 | 17 +-
flang/test/Semantics/bind-c02.f90 | 2 +-
flang/test/Semantics/bind-c06.f90 | 2 +-
flang/test/Semantics/bind-c11.f90 | 2 +-
flang/test/Semantics/bindings01.f90 | 2 +-
flang/test/Semantics/block-data01.f90 | 2 +-
flang/test/Semantics/c_loc01.f90 | 2 +-
flang/test/Semantics/call01.f90 | 6 +-
flang/test/Semantics/call02.f90 | 2 +-
flang/test/Semantics/call09.f90 | 2 +-
flang/test/Semantics/call31.f90 | 2 +-
flang/test/Semantics/common-blocks-warn.f90 | 2 +-
flang/test/Semantics/common-blocks.f90 | 2 +-
flang/test/Semantics/data06.f90 | 2 +-
flang/test/Semantics/data08.f90 | 2 +-
flang/test/Semantics/data11.f90 | 2 +-
flang/test/Semantics/data14.f90 | 2 +-
flang/test/Semantics/declarations04.f90 | 2 +-
flang/test/Semantics/dim01.f90 | 2 +-
flang/test/Semantics/expr-errors05.f90 | 4 +-
flang/test/Semantics/generic06.f90 | 2 +-
flang/test/Semantics/ignore_tkr01.f90 | 2 +-
flang/test/Semantics/io11.f90 | 3 +-
flang/test/Semantics/long-name.f90 | 2 +-
flang/test/Semantics/modfile43.f90 | 2 +-
flang/test/Semantics/modfile54.f90 | 2 +-
flang/test/Semantics/pointer01.f90 | 2 +-
flang/test/Semantics/procinterface02.f90 | 2 +-
flang/test/Semantics/procinterface04.f90 | 2 +-
flang/test/Semantics/resolve05.f90 | 2 +-
flang/test/Semantics/resolve106.f90 | 2 +-
flang/test/Semantics/resolve114.f90 | 2 +-
flang/test/Semantics/resolve118.f90 | 2 +-
flang/test/Semantics/resolve20.f90 | 2 +-
flang/test/Semantics/resolve46.f90 | 2 +-
flang/test/Semantics/resolve59.f90 | 2 +-
flang/test/Semantics/resolve85.f90 | 4 +-
flang/test/Semantics/stmt-func01.f90 | 2 +-
flang/test/Semantics/stmt-func02.f90 | 2 +-
flang/tools/bbc/bbc.cpp | 2 +-
flang/unittests/Evaluate/expression.cpp | 3 +-
flang/unittests/Evaluate/folding.cpp | 9 +-
flang/unittests/Evaluate/intrinsics.cpp | 4 +-
78 files changed, 568 insertions(+), 347 deletions(-)
diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h
index 94a39c50e049b11..7e518a210f01cd3 100644
--- a/flang/include/flang/Common/Fortran-features.h
+++ b/flang/include/flang/Common/Fortran-features.h
@@ -37,14 +37,23 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
DistinguishableSpecifics, DefaultSave, PointerInSeqType, NonCharacterFormat,
SaveMainProgram, SaveBigMainProgramVariables,
DistinctArrayConstructorLengths, PPCVector, RelaxedIntentInChecking,
- ForwardRefImplicitNoneData, NullActualForAllocatable)
+ ForwardRefImplicitNoneData, NullActualForAllocatable,
+ ActualIntegerConvertedToSmallerKind, HollerithOrCharacterAsBOZ,
+ BindingAsProcedure, StatementFunctionExtensions,
+ UseGenericIntrinsicWhenSpecificDoesntMatch, DataStmtExtensions,
+ RedundantContiguous, InitBlankCommon, EmptyBindCDerivedType,
+ MiscSourceExtensions, AllocateToOtherLength, LongNames, IntrinsicAsSpecific,
+ BenignNameClash, BenignRedundancy, NullMoldAllocatableComponentValue,
+ NopassScalarBase, MiscUseExtensions, ImpliedDoIndexScope,
+ DistinctCommonSizes)
// Portability and suspicious usage warnings for conforming code
ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
NonTargetPassedToTarget, PointerToPossibleNoncontiguous,
ShortCharacterActual, ExprPassedToVolatile, ImplicitInterfaceActual,
PolymorphicTransferArg, PointerComponentTransferArg, TransferSizePresence,
- F202XAllocatableBreakingChange)
+ F202XAllocatableBreakingChange, DimMustBePresent, CommonBlockPadding,
+ LogicalVsCBool, BindCCharLength)
using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;
diff --git a/flang/include/flang/Evaluate/common.h b/flang/include/flang/Evaluate/common.h
index d05072742a48ca8..c8d93e0849229f5 100644
--- a/flang/include/flang/Evaluate/common.h
+++ b/flang/include/flang/Evaluate/common.h
@@ -9,6 +9,7 @@
#ifndef FORTRAN_EVALUATE_COMMON_H_
#define FORTRAN_EVALUATE_COMMON_H_
+#include "flang/Common/Fortran-features.h"
#include "flang/Common/Fortran.h"
#include "flang/Common/default-kinds.h"
#include "flang/Common/enum-set.h"
@@ -215,22 +216,27 @@ template <typename A> class Expr;
class FoldingContext {
public:
FoldingContext(const common::IntrinsicTypeDefaultKinds &d,
- const IntrinsicProcTable &t, const TargetCharacteristics &c)
- : defaults_{d}, intrinsics_{t}, targetCharacteristics_{c} {}
+ const IntrinsicProcTable &t, const TargetCharacteristics &c,
+ const common::LanguageFeatureControl &lfc)
+ : defaults_{d}, intrinsics_{t}, targetCharacteristics_{c},
+ languageFeatures_{lfc} {}
FoldingContext(const parser::ContextualMessages &m,
const common::IntrinsicTypeDefaultKinds &d, const IntrinsicProcTable &t,
- const TargetCharacteristics &c)
- : messages_{m}, defaults_{d}, intrinsics_{t}, targetCharacteristics_{c} {}
+ const TargetCharacteristics &c, const common::LanguageFeatureControl &lfc)
+ : messages_{m}, defaults_{d}, intrinsics_{t}, targetCharacteristics_{c},
+ languageFeatures_{lfc} {}
FoldingContext(const FoldingContext &that)
: messages_{that.messages_}, defaults_{that.defaults_},
intrinsics_{that.intrinsics_},
targetCharacteristics_{that.targetCharacteristics_},
- pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_} {}
+ pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_},
+ languageFeatures_{that.languageFeatures_} {}
FoldingContext(
const FoldingContext &that, const parser::ContextualMessages &m)
: messages_{m}, defaults_{that.defaults_}, intrinsics_{that.intrinsics_},
targetCharacteristics_{that.targetCharacteristics_},
- pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_} {}
+ pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_},
+ languageFeatures_{that.languageFeatures_} {}
parser::ContextualMessages &messages() { return messages_; }
const parser::ContextualMessages &messages() const { return messages_; }
@@ -242,6 +248,9 @@ class FoldingContext {
const TargetCharacteristics &targetCharacteristics() const {
return targetCharacteristics_;
}
+ const common::LanguageFeatureControl &languageFeatures() const {
+ return languageFeatures_;
+ }
bool inModuleFile() const { return inModuleFile_; }
FoldingContext &set_inModuleFile(bool yes = true) {
inModuleFile_ = yes;
@@ -272,6 +281,7 @@ class FoldingContext {
const semantics::DerivedTypeSpec *pdtInstance_{nullptr};
bool inModuleFile_{false};
std::map<parser::CharBlock, ConstantSubscript> impliedDos_;
+ const common::LanguageFeatureControl &languageFeatures_;
};
void RealFlagWarnings(FoldingContext &, const RealFlags &, const char *op);
diff --git a/flang/include/flang/Lower/Bridge.h b/flang/include/flang/Lower/Bridge.h
index b4ee77a0b166ec9..ecf82ba5bc3bb40 100644
--- a/flang/include/flang/Lower/Bridge.h
+++ b/flang/include/flang/Lower/Bridge.h
@@ -58,10 +58,11 @@ class LoweringBridge {
const Fortran::parser::AllCookedSources &allCooked,
llvm::StringRef triple, fir::KindMapping &kindMap,
const Fortran::lower::LoweringOptions &loweringOptions,
- const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults) {
+ const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,
+ const Fortran::common::LanguageFeatureControl &languageFeatures) {
return LoweringBridge(ctx, semanticsContext, defaultKinds, intrinsics,
targetCharacteristics, allCooked, triple, kindMap,
- loweringOptions, envDefaults);
+ loweringOptions, envDefaults, languageFeatures);
}
//===--------------------------------------------------------------------===//
@@ -99,6 +100,10 @@ class LoweringBridge {
return envDefaults;
}
+ const Fortran::common::LanguageFeatureControl &getLanguageFeatures() const {
+ return languageFeatures;
+ }
+
/// Create a folding context. Careful: this is very expensive.
Fortran::evaluate::FoldingContext createFoldingContext() const;
@@ -132,7 +137,8 @@ class LoweringBridge {
const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
fir::KindMapping &kindMap,
const Fortran::lower::LoweringOptions &loweringOptions,
- const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults);
+ const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,
+ const Fortran::common::LanguageFeatureControl &languageFeatures);
LoweringBridge() = delete;
LoweringBridge(const LoweringBridge &) = delete;
@@ -147,6 +153,7 @@ class LoweringBridge {
fir::KindMapping &kindMap;
const Fortran::lower::LoweringOptions &loweringOptions;
const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults;
+ const Fortran::common::LanguageFeatureControl &languageFeatures;
};
} // namespace lower
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 531fc5ccc56c858..2f46ed7dccb6455 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -12,6 +12,7 @@
#include "flang/Evaluate/tools.h"
#include "flang/Evaluate/traverse.h"
#include "flang/Evaluate/type.h"
+#include "flang/Semantics/semantics.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include <set>
@@ -1030,23 +1031,46 @@ class StmtFunctionChecker
using Result = std::optional<parser::Message>;
using Base = AnyTraverse<StmtFunctionChecker, Result>;
StmtFunctionChecker(const Symbol &sf, FoldingContext &context)
- : Base{*this}, sf_{sf}, context_{context} {}
+ : Base{*this}, sf_{sf}, context_{context} {
+ if (!context_.languageFeatures().IsEnabled(
+ common::LanguageFeature::StatementFunctionExtensions)) {
+ severity_ = parser::Severity::Error;
+ } else if (context_.languageFeatures().ShouldWarn(
+ common::LanguageFeature::StatementFunctionExtensions)) {
+ severity_ = parser::Severity::Portability;
+ }
+ }
using Base::operator();
template <typename T> Result operator()(const ArrayConstructor<T> &) const {
- return parser::Message{sf_.name(),
- "Statement function '%s' should not contain an array constructor"_port_en_US,
- sf_.name()};
+ 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()};
+ } else {
+ return std::nullopt;
+ }
}
Result operator()(const StructureConstructor &) const {
- return parser::Message{sf_.name(),
- "Statement function '%s' should not contain a structure constructor"_port_en_US,
- sf_.name()};
+ 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()};
+ } else {
+ return std::nullopt;
+ }
}
Result operator()(const TypeParamInquiry &) const {
- return parser::Message{sf_.name(),
- "Statement function '%s' should not contain a type parameter inquiry"_port_en_US,
- sf_.name()};
+ 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()};
+ } else {
+ return std::nullopt;
+ }
}
Result operator()(const ProcedureDesignator &proc) const {
if (const Symbol * symbol{proc.GetSymbol()}) {
@@ -1064,16 +1088,23 @@ class StmtFunctionChecker
if (auto chars{
characteristics::Procedure::Characterize(proc, context_)}) {
if (!chars->CanBeCalledViaImplicitInterface()) {
- 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 (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()};
+ }
}
}
}
if (proc.Rank() > 0) {
- return parser::Message(sf_.name(),
- "Statement function '%s' should not reference a function that returns an array"_port_en_US,
- sf_.name());
+ 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 std::nullopt;
}
@@ -1083,9 +1114,12 @@ class StmtFunctionChecker
return result;
}
if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {
- 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());
+ 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 std::nullopt;
@@ -1094,6 +1128,7 @@ class StmtFunctionChecker
private:
const Symbol &sf_;
FoldingContext &context_;
+ std::optional<parser::Severity> severity_;
};
std::optional<parser::Message> CheckStatementFunction(
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index c711b4feaca4831..52655cae8862b52 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2224,12 +2224,15 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
if (const Symbol *whole{
UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) {
if (IsOptional(*whole) || IsAllocatableOrObjectPointer(whole)) {
- if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
- messages.Say(
- "The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_port_en_US);
- } else {
- messages.Say(
- "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);
+ if (context.languageFeatures().ShouldWarn(
+ common::UsageWarning::DimMustBePresent)) {
+ if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
+ messages.Say(
+ "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(
+ "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);
+ }
}
}
}
@@ -3180,28 +3183,37 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
// If there was no exact match with a specific, try to match the related
// generic and convert the result to the specific required type.
- for (auto specIter{specificRange.first}; specIter != specificRange.second;
- ++specIter) {
- // We only need to check the cases with distinct generic names.
- if (const char *genericName{specIter->second->generic}) {
- if (specIter->second->useGenericAndForceResultType) {
- auto genericRange{genericFuncs_.equal_range(genericName)};
- for (auto genIter{genericRange.first}; genIter != genericRange.second;
- ++genIter) {
- if (auto specificCall{
- matchOrBufferMessages(*genIter->second, specificBuffer)}) {
- // Force the call result type to the specific intrinsic result type
- DynamicType newType{GetReturnType(*specIter->second, defaults_)};
- context.messages().Say(
- "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());
- specificCall->specificIntrinsic.name = call.name;
- specificCall->specificIntrinsic.characteristics.value()
- .functionResult.value()
- .SetType(newType);
- return specificCall;
+ if (context.languageFeatures().IsEnabled(common::LanguageFeature::
+ UseGenericIntrinsicWhenSpecificDoesntMatch)) {
+ for (auto specIter{specificRange.first}; specIter != specificRange.second;
+ ++specIter) {
+ // We only need to check the cases with distinct generic names.
+ if (const char *genericName{specIter->second->generic}) {
+ if (specIter->second->useGenericAndForceResultType) {
+ auto genericRange{genericFuncs_.equal_range(genericName)};
+ for (auto genIter{genericRange.first}; genIter != genericRange.second;
+ ++genIter) {
+ if (auto specificCall{
+ matchOrBufferMessages(*genIter->second, specificBuffer)}) {
+ // Force the call result type to the specific intrinsic result
+ // type
+ DynamicType newType{GetReturnType(*specIter->second, defaults_)};
+ if (context.languageFeatures().ShouldWarn(
+ common::LanguageFeature::
+ UseGenericIntrinsicWhenSpecificDoesntMatch)) {
+ context.messages().Say(
+ "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());
+ }
+ specificCall->specificIntrinsic.name = call.name;
+ specificCall->specificIntrinsic.characteristics.value()
+ .functionResult.value()
+ .SetType(newType);
+ return specificCall;
+ }
}
}
}
diff --git a/flang/lib/Frontend/FrontendActions.cpp b/flang/lib/Frontend/FrontendActions.cpp
index 73c00c8679c7ec6..f09e62148e53c53 100644
--- a/flang/lib/Frontend/FrontendActions.cpp
+++ b/flang/lib/Frontend/FrontendActions.cpp
@@ -278,7 +278,8 @@ bool CodeGenAction::beginSourceFileAction() {
ci.getInvocation().getSemanticsContext().targetCharacteristics(),
ci.getParsing().allCooked(), ci.getInvocation().getTargetOpts().triple,
kindMap, ci.getInvocation().getLoweringOpts(),
- ci.getInvocation().getFrontendOpts().envDefaults);
+ ci.getInvocation().getFrontendOpts().envDefaults,
+ ci.getInvocation().getFrontendOpts().features);
// Fetch module from lb, so we can set
mlirModule = std::make_unique<mlir::ModuleOp>(lb.getModule());
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 9875e37393ef869..f64719b64f12e5a 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -4901,7 +4901,8 @@ class FirConverter : public Fortran::lower::AbstractConverter {
Fortran::evaluate::FoldingContext
Fortran::lower::LoweringBridge::createFoldingContext() const {
- return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics()};
+ return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics(),
+ getLanguageFeatures()};
}
void Fortran::lower::LoweringBridge::lower(
@@ -4931,11 +4932,13 @@ Fortran::lower::LoweringBridge::LoweringBridge(
const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
fir::KindMapping &kindMap,
const Fortran::lower::LoweringOptions &loweringOptions,
- const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults)
+ const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,
+ const Fortran::common::LanguageFeatureControl &languageFeatures)
: semanticsContext{semanticsContext}, defaultKinds{defaultKinds},
intrinsics{intrinsics}, targetCharacteristics{targetCharacteristics},
cooked{&cooked}, context{context}, kindMap{kindMap},
- loweringOptions{loweringOptions}, envDefaults{envDefaults} {
+ loweringOptions{loweringOptions}, envDefaults{envDefaults},
+ languageFeatures{languageFeatures} {
// Register the diagnostic handler.
context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {
llvm::raw_ostream &os = llvm::errs();
diff --git a/flang/lib/Parser/expr-parsers.cpp b/flang/lib/Parser/expr-parsers.cpp
index 45e6b2869c02bd4..b27366d02308eb5 100644
--- a/flang/lib/Parser/expr-parsers.cpp
+++ b/flang/lib/Parser/expr-parsers.cpp
@@ -77,10 +77,8 @@ constexpr auto primary{instrumented("primary"_en_US,
construct<Expr>(Parser<StructureConstructor>{}),
construct<Expr>(Parser<ArrayConstructor>{}),
// PGI/XLF extension: COMPLEX constructor (x,y)
- extension<LanguageFeature::ComplexConstructor>(
- "nonstandard usage: generalized COMPLEX constructor"_port_en_US,
- construct<Expr>(parenthesized(
- construct<Expr::ComplexConstructor>(expr, "," >> expr)))),
+ construct<Expr>(parenthesized(
+ construct<Expr::ComplexConstructor>(expr, "," >> expr))),
extension<LanguageFeature::PercentLOC>(
"nonstandard usage: %LOC"_port_en_US,
construct<Expr>("%LOC" >> parenthesized(construct<Expr::PercentLoc>(
diff --git a/flang/lib/Parser/prescan.cpp b/flang/lib/Parser/prescan.cpp
index 1781cc8929f5611..449ea60144424a8 100644
--- a/flang/lib/Parser/prescan.cpp
+++ b/flang/lib/Parser/prescan.cpp
@@ -178,9 +178,11 @@ void Prescanner::Statement() {
while (NextToken(tokens)) {
}
if (continuationLines_ > 255) {
- Say(GetProvenance(statementStart),
- "%d continuation lines is more than the Fortran standard allows"_port_en_US,
- continuationLines_);
+ if (features_.ShouldWarn(common::LanguageFeature::MiscSourceExtensions)) {
+ Say(GetProvenance(statementStart),
+ "%d continuation lines is more than the Fortran standard allows"_port_en_US,
+ continuationLines_);
+ }
}
Provenance newlineProvenance{GetCurrentProvenance()};
@@ -334,8 +336,10 @@ void Prescanner::LabelField(TokenSequence &token) {
token.CloseToken();
SkipToNextSignificantCharacter();
if (IsDecimalDigit(*at_)) {
- Say(GetCurrentProvenance(),
- "Label digit is not in fixed-form label field"_port_en_US);
+ if (features_.ShouldWarn(common::LanguageFeature::MiscSourceExtensions)) {
+ Say(GetCurrentProvenance(),
+ "Label digit is not in fixed-form label field"_port_en_US);
+ }
}
}
@@ -666,8 +670,11 @@ bool Prescanner::NextToken(TokenSequence &tokens) {
} else if (ch == ';' && InFixedFormSource()) {
SkipSpaces();
if (IsDecimalDigit(*at_)) {
- Say(GetProvenanceRange(at_, at_ + 1),
- "Label should be in the label field"_port_en_US);
+ if (features_.ShouldWarn(
+ common::LanguageFeature::MiscSourceExtensions)) {
+ Say(GetProvenanceRange(at_, at_ + 1),
+ "Label should be in the label field"_port_en_US);
+ }
}
}
}
@@ -743,8 +750,11 @@ void Prescanner::QuotedCharacterLiteral(
}
inCharLiteral_ = true;
if (insertASpace_) {
- Say(GetProvenanceRange(at_, end),
- "Repeated quote mark in character literal continuation line should have been preceded by '&'"_port_en_US);
+ if (features_.ShouldWarn(
+ common::LanguageFeature::MiscSourceExtensions)) {
+ Say(GetProvenanceRange(at_, end),
+ "Repeated quote mark in character literal continuation line should have been preceded by '&'"_port_en_US);
+ }
insertASpace_ = false;
}
}
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index ba1161b21f83676..a7244e1c58330a5 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -528,9 +528,11 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
}
// Character length distinction is allowed, with a warning
if (!HaveCompatibleLengths(
- *type_, allocateInfo_.sourceExprType.value())) { // C945
- context.Say(name_.source,
- "Character length of allocatable object in ALLOCATE should be the same as the SOURCE or MOLD"_port_en_US);
+ *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);
+ }
return false;
}
}
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index bf80dbecab009d9..e3321ff532f9833 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -234,7 +234,7 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
const characteristics::TypeAndShape &dummyType,
characteristics::TypeAndShape &actualType,
- parser::ContextualMessages &messages) {
+ parser::ContextualMessages &messages, SemanticsContext &semanticsContext) {
if (dummyType.type().category() == TypeCategory::Integer &&
actualType.type().category() == TypeCategory::Integer &&
dummyType.type().kind() != actualType.type().kind() &&
@@ -245,9 +245,22 @@ static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
CHECK(converted);
actual = std::move(*converted);
if (dummyType.type().kind() < actualType.type().kind()) {
- messages.Say(
- "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());
+ 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 {
+ msg =
+ "Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_port_en_US;
+ }
+ messages.Say(std::move(msg.value()), actualType.type().kind(),
+ dummyType.type().kind());
+ }
}
actualType = dummyType;
}
@@ -312,7 +325,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummy.type.type().category() == actualType.type().category())};
allowActualArgumentConversions &= !typesCompatibleWithIgnoreTKR;
if (allowActualArgumentConversions) {
- ConvertIntegerActual(actual, dummy.type, actualType, messages);
+ ConvertIntegerActual(actual, dummy.type, actualType, messages, context);
ConvertLogicalActual(actual, dummy.type, actualType);
}
bool typesCompatible{typesCompatibleWithIgnoreTKR ||
@@ -322,8 +335,11 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// Extension: pass Hollerith literal to scalar as if it had been BOZ
if (auto converted{evaluate::HollerithToBOZ(
foldingContext, actual, dummy.type.type())}) {
- messages.Say(
- "passing Hollerith or character literal as if it were BOZ"_port_en_US);
+ if (context.ShouldWarn(
+ common::LanguageFeature::HollerithOrCharacterAsBOZ)) {
+ messages.Say(
+ "passing Hollerith or character literal as if it were BOZ"_port_en_US);
+ }
actual = *converted;
actualType.type() = dummy.type.type();
typesCompatible = true;
@@ -907,9 +923,16 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
return;
}
} else if (argProcSymbol->has<ProcBindingDetails>()) {
- evaluate::SayWithDeclaration(messages, *argProcSymbol,
- "Procedure binding '%s' passed as an actual argument"_port_en_US,
- argProcSymbol->name());
+ 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 (auto argChars{characteristics::DummyArgument::FromActual(
@@ -1261,7 +1284,9 @@ static bool CheckElementalConformance(parser::ContextualMessages &messages,
// ASSOCIATED (16.9.16)
static void CheckAssociated(evaluate::ActualArguments &arguments,
- evaluate::FoldingContext &context, const Scope *scope) {
+ SemanticsContext &semanticsContext, const Scope *scope) {
+ evaluate::FoldingContext &foldingContext{semanticsContext.foldingContext()};
+ parser::ContextualMessages &messages{foldingContext.messages()};
bool ok{true};
if (arguments.size() < 2) {
return;
@@ -1269,7 +1294,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
if (const auto &pointerArg{arguments[0]}) {
if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
if (!IsPointer(*pointerExpr)) {
- context.messages().Say(pointerArg->sourceLocation(),
+ messages.Say(pointerArg->sourceLocation(),
"POINTER= argument of ASSOCIATED() must be a pointer"_err_en_US);
return;
}
@@ -1279,19 +1304,21 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
// perhaps unintentionally, excludes function results, including NULL(),
// from being used there, as well as INTENT(IN) dummy pointers.
// Allow this usage as a benign extension with a portability warning.
- if (!evaluate::ExtractDataRef(*pointerExpr) &&
- !evaluate::IsProcedurePointer(*pointerExpr)) {
- context.messages().Say(pointerArg->sourceLocation(),
- "POINTER= argument of ASSOCIATED() should be a pointer"_port_en_US);
- } else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) {
- if (auto whyNot{WhyNotDefinable(pointerArg->sourceLocation().value_or(
- context.messages().at()),
- *scope,
- DefinabilityFlags{DefinabilityFlag::PointerDefinition},
- *pointerExpr)}) {
- if (auto *msg{context.messages().Say(pointerArg->sourceLocation(),
- "POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement"_port_en_US)}) {
- msg->Attach(std::move(*whyNot));
+ if (semanticsContext.ShouldWarn(common::UsageWarning::Portability)) {
+ if (!evaluate::ExtractDataRef(*pointerExpr) &&
+ !evaluate::IsProcedurePointer(*pointerExpr)) {
+ messages.Say(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(
+ pointerArg->sourceLocation().value_or(messages.at()),
+ *scope,
+ DefinabilityFlags{DefinabilityFlag::PointerDefinition},
+ *pointerExpr)}) {
+ if (auto *msg{messages.Say(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));
+ }
}
}
}
@@ -1299,11 +1326,11 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
if (IsProcedurePointer(*pointerExpr) &&
!IsBareNullPointer(pointerExpr)) { // POINTER= is a procedure
if (auto pointerProc{characteristics::Procedure::Characterize(
- *pointerExpr, context)}) {
+ *pointerExpr, foldingContext)}) {
if (IsBareNullPointer(targetExpr)) {
} else if (IsProcedurePointerTarget(*targetExpr)) {
if (auto targetProc{characteristics::Procedure::Characterize(
- *targetExpr, context)}) {
+ *targetExpr, foldingContext)}) {
bool isCall{!!UnwrapProcedureRef(*targetExpr)};
std::string whyNot;
const auto *targetProcDesignator{
@@ -1317,13 +1344,13 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
CheckProcCompatibility(isCall, pointerProc,
&*targetProc, specificIntrinsic, whyNot)}) {
msg->set_severity(parser::Severity::Warning);
- context.messages().Say(std::move(*msg),
+ messages.Say(std::move(*msg),
"pointer '" + pointerExpr->AsFortran() + "'",
targetExpr->AsFortran(), whyNot);
}
}
} else if (!IsNullProcedurePointer(*targetExpr)) {
- context.messages().Say(
+ messages.Say(
"POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US,
pointerExpr->AsFortran(), targetExpr->AsFortran());
}
@@ -1333,8 +1360,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
if (ExtractDataRef(*targetExpr)) {
if (SymbolVector symbols{GetSymbolVector(*targetExpr)};
!evaluate::GetLastTarget(symbols)) {
- parser::Message *msg{context.messages().Say(
- targetArg->sourceLocation(),
+ parser::Message *msg{messages.Say(targetArg->sourceLocation(),
"TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
targetExpr->AsFortran())};
for (SymbolRef ref : symbols) {
@@ -1342,7 +1368,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
} else if (HasVectorSubscript(*targetExpr) ||
ExtractCoarrayRef(*targetExpr)) {
- context.messages().Say(targetArg->sourceLocation(),
+ messages.Say(targetArg->sourceLocation(),
"TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US,
targetExpr->AsFortran());
}
@@ -1353,7 +1379,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
}
} else {
- context.messages().Say(
+ messages.Say(
"POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,
pointerExpr->AsFortran(), targetExpr->AsFortran());
}
@@ -1365,7 +1391,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
ok = false;
}
if (!ok) {
- context.messages().Say(
+ messages.Say(
"Arguments of ASSOCIATED() must be a pointer and an optional valid target"_err_en_US);
}
}
@@ -1441,7 +1467,7 @@ static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments,
SemanticsContext &context, const Scope *scope,
const evaluate::SpecificIntrinsic &intrinsic) {
if (intrinsic.name == "associated") {
- CheckAssociated(arguments, context.foldingContext(), scope);
+ CheckAssociated(arguments, context, scope);
} else if (intrinsic.name == "transfer") {
CheckTransfer(arguments, context, scope);
}
diff --git a/flang/lib/Semantics/check-data.cpp b/flang/lib/Semantics/check-data.cpp
index fe9b2fd222827fe..9d3e8c5a4ea8f73 100644
--- a/flang/lib/Semantics/check-data.cpp
+++ b/flang/lib/Semantics/check-data.cpp
@@ -84,14 +84,30 @@ class DataVarChecker : public evaluate::AllTraverse<DataVarChecker, true> {
return false;
}
if (IsProcedurePointer(symbol)) {
- context_.Say(source_,
- "Procedure pointer '%s' in a DATA statement is not standard"_port_en_US,
- symbol.name());
+ if (!context_.IsEnabled(common::LanguageFeature::DataStmtExtensions)) {
+ context_.Say(source_,
+ "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_,
+ "Procedure pointer '%s' in a DATA statement is not standard"_port_en_US,
+ symbol.name());
+ }
}
if (IsInBlankCommon(symbol)) {
- context_.Say(source_,
- "Blank COMMON object '%s' in a DATA statement is not standard"_port_en_US,
- symbol.name());
+ if (!context_.IsEnabled(common::LanguageFeature::DataStmtExtensions)) {
+ context_.Say(source_,
+ "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_,
+ "Blank COMMON object '%s' in a DATA statement is not standard"_port_en_US,
+ symbol.name());
+ }
}
return true;
}
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 6d69eb187bda089..a9ce1e91ed66331 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -235,10 +235,12 @@ void CheckHelper::Check(
void CheckHelper::Check(const Symbol &symbol) {
if (symbol.name().size() > common::maxNameLen &&
&symbol == &symbol.GetUltimate()) {
- 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);
+ 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);
+ }
}
if (context_.HasError(symbol)) {
return;
@@ -404,8 +406,10 @@ void CheckHelper::Check(const Symbol &symbol) {
}
}
if (IsProcedurePointer(symbol) && IsDummy(symbol)) {
- messages_.Say(
- "A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
+ if (context_.ShouldWarn(common::UsageWarning::Portability)) {
+ messages_.Say(
+ "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.
}
}
@@ -823,8 +827,10 @@ void CheckHelper::CheckObjectEntity(
} else if (IsFunctionResult(symbol)) {
messages_.Say("A function result must not be initialized"_err_en_US);
} else if (IsInBlankCommon(symbol)) {
- WarnIfNotInModuleFile(
- "A variable in blank COMMON should not be initialized"_port_en_US);
+ if (context_.ShouldWarn(common::LanguageFeature::InitBlankCommon)) {
+ WarnIfNotInModuleFile(
+ "A variable in blank COMMON should not be initialized"_port_en_US);
+ }
}
}
if (symbol.owner().kind() == Scope::Kind::BlockData) {
@@ -1190,8 +1196,10 @@ 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)) {
- messages_.Say(
- "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
+ if (context_.ShouldWarn(common::UsageWarning::Portability)) {
+ messages_.Say(
+ "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
+ }
} else {
messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
}
@@ -1217,9 +1225,11 @@ void CheckHelper::CheckProcEntity(
"to procedure pointer '%s'"_err_en_US,
interface->name(), symbol.name());
} else if (IsElementalProcedure(*interface)) {
- messages_.Say(
- "Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
- symbol.name()); // C1517
+ 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
+ }
}
} else if (IsElementalProcedure(*interface)) {
messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
@@ -1343,10 +1353,13 @@ void CheckHelper::CheckSubprogram(
// 15.6.4 p2 weird requirement
if (const Symbol *
host{symbol.owner().parent().FindSymbol(symbol.name())}) {
- 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);
+ 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);
+ }
}
}
if (GetProgramUnitOrBlockConstructContaining(symbol).kind() ==
@@ -1745,18 +1758,22 @@ void CheckHelper::CheckSpecifics(
auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
specific.name().ToString())};
if (intrinsic && !intrinsic->isRestrictedSpecific) {
- 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 (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());
+ }
}
} else {
- 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 (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());
+ }
}
continue;
}
@@ -2127,14 +2144,16 @@ void CheckHelper::CheckContiguous(const Symbol &symbol) {
if (evaluate::IsVariable(symbol) &&
((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||
evaluate::IsAssumedRank(symbol))) {
- } else if (symbol.owner().IsDerivedType()) { // C752
- messages_.Say(
- "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US,
- symbol.name());
- } else {
- messages_.Say(
- "CONTIGUOUS entity '%s' should be an array pointer, assumed-shape, or assumed-rank"_port_en_US,
- symbol.name());
+ } else if (!context_.IsEnabled(
+ common::LanguageFeature::RedundantContiguous) ||
+ context_.ShouldWarn(common::LanguageFeature::RedundantContiguous)) {
+ 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());
}
}
@@ -2415,24 +2434,26 @@ void CheckHelper::Check(const Scope &scope) {
auto iter{scope.find(*name)};
if (iter != scope.end()) {
const char *kind{nullptr};
- 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);
+ 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);
+ }
}
}
}
@@ -2608,13 +2629,17 @@ void CheckHelper::CheckGlobalName(const Symbol &symbol) {
!IsExternalProcedureDefinition(other))) {
// both are procedures/BLOCK DATA, not both definitions
} else if (symbol.has<ModuleDetails>()) {
- messages_.Say(symbol.name(),
- "Module '%s' conflicts with a global name"_port_en_US,
- pair.first->first);
+ if (context_.ShouldWarn(common::LanguageFeature::BenignNameClash)) {
+ messages_.Say(symbol.name(),
+ "Module '%s' conflicts with a global name"_port_en_US,
+ pair.first->first);
+ }
} else if (other.has<ModuleDetails>()) {
- messages_.Say(symbol.name(),
- "Global name '%s' conflicts with a module"_port_en_US,
- pair.first->first);
+ if (context_.ShouldWarn(common::LanguageFeature::BenignNameClash)) {
+ messages_.Say(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)}) {
@@ -2750,17 +2775,19 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
} else if (IsAllocatableOrPointer(symbol) &&
type->category() == DeclTypeSpec::Character &&
type->characterTypeSpec().length().isDeferred()) {
- // ok; F'2018 18.3.6 p2(6)
+ // ok; F'2023 18.3.7 p2(6)
} else if (derived ||
IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
- // F'2018 18.3.6 p2(4,5)
+ // F'2023 18.3.7 p2(4,5)
} else if (type->category() == DeclTypeSpec::Logical) {
- if (IsDummy(symbol)) {
- WarnIfNotInModuleFile(symbol.name(),
- "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
- } else {
- WarnIfNotInModuleFile(symbol.name(),
- "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
+ if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
+ if (IsDummy(symbol)) {
+ WarnIfNotInModuleFile(symbol.name(),
+ "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
+ } else {
+ WarnIfNotInModuleFile(symbol.name(),
+ "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
+ }
}
} else if (symbol.attrs().test(Attr::VALUE)) {
messages_.Say(symbol.name(),
@@ -2773,8 +2800,10 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
}
}
if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
- WarnIfNotInModuleFile(symbol.name(),
- "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
+ if (context_.ShouldWarn(common::UsageWarning::Portability)) {
+ WarnIfNotInModuleFile(symbol.name(),
+ "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
+ }
}
if (IsDescriptor(symbol) && IsPointer(symbol) &&
symbol.attrs().test(Attr::CONTIGUOUS)) {
@@ -2845,12 +2874,16 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
*type, context_.languageFeatures())) {
auto maybeDyType{evaluate::DynamicType::From(*type)};
if (type->category() == DeclTypeSpec::Logical) {
- WarnIfNotInModuleFile(component->name(),
- "A LOGICAL component of a BIND(C) type should have the interoperable KIND=C_BOOL"_port_en_US);
+ if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
+ WarnIfNotInModuleFile(component->name(),
+ "A LOGICAL component of a BIND(C) type should have the interoperable KIND=C_BOOL"_port_en_US);
+ }
} else if (type->category() == DeclTypeSpec::Character &&
maybeDyType && maybeDyType->kind() == 1) {
- WarnIfNotInModuleFile(component->name(),
- "A CHARACTER component of a BIND(C) type should have length 1"_port_en_US);
+ if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
+ WarnIfNotInModuleFile(component->name(),
+ "A CHARACTER component of a BIND(C) type should have length 1"_port_en_US);
+ }
} else {
messages_.Say(component->name(),
"Each component of an interoperable derived type must have an interoperable type"_err_en_US);
@@ -2867,9 +2900,11 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
}
}
}
- if (derived->componentNames().empty()) { // C1805
- WarnIfNotInModuleFile(symbol.name(),
- "A derived type with the BIND attribute is empty"_port_en_US);
+ if (derived->componentNames().empty()) { // F'2023 C1805
+ if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
+ WarnIfNotInModuleFile(symbol.name(),
+ "A derived type with the BIND attribute is empty"_port_en_US);
+ }
}
}
}
diff --git a/flang/lib/Semantics/check-directive-structure.h b/flang/lib/Semantics/check-directive-structure.h
index 9c3aa47e19e5c7c..fec677500722e4c 100644
--- a/flang/lib/Semantics/check-directive-structure.h
+++ b/flang/lib/Semantics/check-directive-structure.h
@@ -423,23 +423,28 @@ DirectiveStructureChecker<D, C, PC, ClauseEnumSize>::ClauseSetToString(
template <typename D, typename C, typename PC, std::size_t ClauseEnumSize>
void DirectiveStructureChecker<D, C, PC,
ClauseEnumSize>::CheckRequireAtLeastOneOf(bool warnInsteadOfError) {
- if (GetContext().requiredClauses.empty())
+ if (GetContext().requiredClauses.empty()) {
return;
+ }
for (auto cl : GetContext().actualClauses) {
- if (GetContext().requiredClauses.test(cl))
+ if (GetContext().requiredClauses.test(cl)) {
return;
+ }
}
// No clause matched in the actual clauses list
- if (warnInsteadOfError)
- context_.Say(GetContext().directiveSource,
- "At least one of %s clause should appear on the %s directive"_port_en_US,
- ClauseSetToString(GetContext().requiredClauses),
- ContextDirectiveAsFortran());
- else
+ 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());
+ }
+ } else {
context_.Say(GetContext().directiveSource,
"At least one of %s clause must appear on the %s directive"_err_en_US,
ClauseSetToString(GetContext().requiredClauses),
ContextDirectiveAsFortran());
+ }
}
template <typename D, typename C, typename PC, std::size_t ClauseEnumSize>
@@ -457,16 +462,20 @@ void DirectiveStructureChecker<D, C, PC, ClauseEnumSize>::CheckAllowed(
!GetContext().allowedOnceClauses.test(clause) &&
!GetContext().allowedExclusiveClauses.test(clause) &&
!GetContext().requiredClauses.test(clause)) {
- if (warnInsteadOfError)
- 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()));
- else
+ 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()));
+ }
+ } else {
context_.Say(GetContext().clauseSource,
"%s clause is not allowed on the %s directive"_err_en_US,
parser::ToUpperCaseLetters(getClauseName(clause).str()),
parser::ToUpperCaseLetters(GetContext().directiveSource.ToString()));
+ }
return;
}
if ((GetContext().allowedOnceClauses.test(clause) ||
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index a1ed4660efde79c..4e8578d0e1daff7 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -650,9 +650,11 @@ class DoContext {
for (auto &ls : localitySpecs) {
if (std::holds_alternative<parser::LocalitySpec::DefaultNone>(ls.u)) {
if (hasDefaultNone) {
- // C1127, you can only have one DEFAULT(NONE)
- context_.Say(currentStatementSourcePosition_,
- "Only one DEFAULT(NONE) may appear"_port_en_US);
+ // 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);
+ }
break;
}
hasDefaultNone = true;
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 12f54fbd51e1c2f..b989d72fa8d0b77 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -610,7 +610,8 @@ void OmpStructureChecker::CheckTargetNest(const parser::OpenMPConstruct &c) {
[&](const auto &c) {},
},
c.u);
- if (!eligibleTarget) {
+ 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,
@@ -2706,15 +2707,17 @@ void OmpStructureChecker::Enter(const parser::OmpClause::Depend &x) {
void OmpStructureChecker::CheckCopyingPolymorphicAllocatable(
SymbolSourceMap &symbols, const llvm::omp::Clause clause) {
- for (auto it{symbols.begin()}; it != symbols.end(); ++it) {
- 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,
- symbol->name(),
- parser::ToUpperCaseLetters(getClauseName(clause).str()));
+ if (context_.ShouldWarn(common::UsageWarning::Portability)) {
+ for (auto it{symbols.begin()}; it != symbols.end(); ++it) {
+ 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,
+ symbol->name(),
+ parser::ToUpperCaseLetters(getClauseName(clause).str()));
+ }
}
}
}
diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp
index 375d2e3f7df376a..2eb3a34ad8065cf 100644
--- a/flang/lib/Semantics/compute-offsets.cpp
+++ b/flang/lib/Semantics/compute-offsets.cpp
@@ -160,9 +160,11 @@ void ComputeOffsetsHelper::DoCommonBlock(Symbol &commonBlock) {
auto errorSite{
commonBlock.name().empty() ? symbol.name() : commonBlock.name()};
if (std::size_t padding{DoSymbol(symbol.GetUltimate())}) {
- context_.Say(errorSite,
- "COMMON block /%s/ requires %zd bytes of padding before '%s' for alignment"_port_en_US,
- commonBlock.name(), padding, symbol.name());
+ 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());
+ }
}
previous.emplace(symbol);
auto eqIter{equivalenceBlock_.end()};
diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp
index 86f5f399310c0f3..c12af1bb0165cd0 100644
--- a/flang/lib/Semantics/data-to-inits.cpp
+++ b/flang/lib/Semantics/data-to-inits.cpp
@@ -435,10 +435,15 @@ bool DataInitializationCompiler<DSV>::InitElement(
// value non-pointer initialization
if (IsBOZLiteral(*expr) &&
designatorType->category() != TypeCategory::Integer) { // 8.6.7(11)
- 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) {
+ 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(
"DATA statement value initializes '%s' of type '%s' with CHARACTER"_port_en_US,
DescribeElement(), designatorType->AsFortran());
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 367414a2b4465ce..8a27e9a987b9051 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -632,6 +632,7 @@ struct IntTypeVisitor {
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,
"negated maximum INTEGER(KIND=%d) literal"_port_en_US, T::kind);
@@ -2047,11 +2048,14 @@ MaybeExpr ExpressionAnalyzer::Analyze(
continue;
}
if (IsNullObjectPointer(*value)) {
- AttachDeclaration(
- Say(expr.source,
- "NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,
- symbol->name()),
- *symbol);
+ 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);
+ }
// proceed to check type & shape
} else {
AttachDeclaration(
@@ -2335,11 +2339,15 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
if (dataRef && dataRef->Rank() > 0) {
if (sym->has<semantics::ProcBindingDetails>() &&
sym->attrs().test(semantics::Attr::NOPASS)) {
- // C1529 seems unnecessary and most compilers don't enforce it.
- AttachDeclaration(
- Say(sc.component.source,
- "Base of NOPASS type-bound procedure reference should be scalar"_port_en_US),
- *sym);
+ // 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);
+ }
} else if (IsProcedurePointer(*sym)) { // C919
Say(sc.component.source,
"Base of procedure component reference must be scalar"_err_en_US);
@@ -3281,6 +3289,10 @@ 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);
+ }
return AnalyzeComplex(Analyze(std::get<0>(z.t).value()),
Analyze(std::get<1>(z.t).value()), "complex constructor");
}
@@ -3882,11 +3894,13 @@ MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
MaybeExpr ExpressionAnalyzer::AnalyzeComplex(
MaybeExpr &&re, MaybeExpr &&im, const char *what) {
- 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 (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 && im) {
ConformabilityCheck(GetContextualMessages(), *re, *im);
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 1343484cb3da87c..0dcaa4e3f2a359c 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -380,7 +380,7 @@ bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
return false;
}
} else if (symbol->has<ProcBindingDetails>() &&
- context_.ShouldWarn(common::UsageWarning::Portability)) {
+ 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());
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 98773a1b9d6ab45..48522046b145f4d 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -3175,23 +3175,27 @@ Symbol &ModuleVisitor::AddGenericUse(
return newSymbol;
}
-// Enforce C1406 as a warning
+// Enforce F'2023 C1406 as a warning
void ModuleVisitor::AddAndCheckModuleUse(SourceName name, bool isIntrinsic) {
if (isIntrinsic) {
if (auto iter{nonIntrinsicUses_.find(name)};
iter != nonIntrinsicUses_.end()) {
- 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 (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);
+ }
}
intrinsicUses_.insert(name);
} else {
if (auto iter{intrinsicUses_.find(name)}; iter != intrinsicUses_.end()) {
- 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 (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);
+ }
}
nonIntrinsicUses_.insert(name);
}
@@ -3501,8 +3505,11 @@ bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) {
return false;
}
if (DoesScopeContain(&ultimate.owner(), currScope())) {
- Say(name,
- "Name '%s' from host scope should have a type declaration before its local statement function definition"_port_en_US);
+ 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);
+ }
MakeSymbol(name, Attrs{}, UnknownDetails{});
} else if (auto *entity{ultimate.detailsIf<EntityDetails>()};
entity && !ultimate.has<ProcEntityDetails>()) {
@@ -7026,10 +7033,12 @@ bool ConstructVisitor::CheckDef(const std::optional<parser::Name> &x) {
if (Symbol * inner{FindInScope(currScope(), *x)}) {
SayAlreadyDeclared(*x, *inner);
} else {
- if (Symbol *
- other{FindInScopeOrBlockConstructs(InclusiveScope(), x->source)}) {
- SayWithDecl(*x, *other,
- "The construct name '%s' should be distinct at the subprogram level"_port_en_US);
+ if (context().ShouldWarn(common::LanguageFeature::BenignNameClash)) {
+ if (Symbol *
+ other{FindInScopeOrBlockConstructs(InclusiveScope(), x->source)}) {
+ SayWithDecl(*x, *other,
+ "The construct name '%s' should be distinct at the subprogram level"_port_en_US);
+ }
}
MakeSymbol(*x, MiscDetails{MiscDetails::Kind::ConstructName});
}
@@ -7234,8 +7243,10 @@ bool ResolveNamesVisitor::Pre(const parser::ImportStmt &x) {
scope.add_importName(name.source);
if (Symbol * symbol{FindInScope(name)}) {
if (outer->GetUltimate() == symbol->GetUltimate()) {
- Say(name,
- "The same '%s' is already present in this scope"_port_en_US);
+ if (context().ShouldWarn(common::LanguageFeature::BenignNameClash)) {
+ Say(name,
+ "The same '%s' is already present in this scope"_port_en_US);
+ }
} else {
Say(name,
"A distinct '%s' is already present in this scope"_err_en_US)
@@ -7322,9 +7333,11 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
}
if (checkIndexUseInOwnBounds_ &&
*checkIndexUseInOwnBounds_ == name.source && !InModuleFile()) {
- Say(name,
- "Implied DO index '%s' uses an object of the same name in its bounds expressions"_port_en_US,
- name.source);
+ 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);
+ }
}
return &name;
}
@@ -8374,9 +8387,11 @@ bool ResolveNamesVisitor::Pre(const parser::Program &x) {
}
modules.emplace(name, &progUnit);
if (auto iter{uses.find(name)}; iter != uses.end()) {
- Say(name,
- "A USE statement referencing module '%s' appears earlier in this compilation unit"_port_en_US)
- .Attach(*iter, "First USE of module"_en_US);
+ if (context().ShouldWarn(common::LanguageFeature::MiscUseExtensions)) {
+ Say(name,
+ "A USE statement referencing module '%s' appears earlier in this compilation unit"_port_en_US)
+ .Attach(*iter, "First USE of module"_en_US);
+ }
disordered = true;
}
}
diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp
index 7176deba27068b6..79a35c57d2d7cd7 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -243,7 +243,8 @@ class CommonBlockMap {
info.initialization = common;
}
}
- if (common.size() != info.biggestSize->size() && !common.name().empty()) {
+ if (common.size() != info.biggestSize->size() && !common.name().empty() &&
+ context.ShouldWarn(common::LanguageFeature::DistinctCommonSizes)) {
context
.Say(common.name(),
"A named COMMON block should have the same size everywhere it appears (%zd bytes here)"_port_en_US,
@@ -312,7 +313,7 @@ SemanticsContext::SemanticsContext(
globalScope_{*this}, intrinsicModulesScope_{globalScope_.MakeScope(
Scope::Kind::IntrinsicModules, nullptr)},
foldingContext_{parser::ContextualMessages{&messages_}, defaultKinds_,
- intrinsics_, targetCharacteristics_} {}
+ intrinsics_, targetCharacteristics_, languageFeatures_} {}
SemanticsContext::~SemanticsContext() {}
diff --git a/flang/test/Evaluate/folding04.f90 b/flang/test/Evaluate/folding04.f90
index 99ee203b29b5c2d..86ae8debd6ef12b 100644
--- a/flang/test/Evaluate/folding04.f90
+++ b/flang/test/Evaluate/folding04.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_folding.py %s %flang_fc1
+! RUN: %python %S/test_folding.py %s %flang_fc1 -pedantic
! Test intrinsic function folding edge case (both expected value and messages)
! These tests make assumptions regarding real(4) extrema.
@@ -57,13 +57,13 @@ module specific_extremums
! specified for f18 (converting the result).
integer(8), parameter :: max_i32_8 = 2_8**31-1
integer, parameter :: expected_min0 = int(min(max_i32_8, 2_8*max_i32_8), 4)
- !WARN: portability: argument types do not match specific intrinsic 'min0' requirements; using 'min' generic instead and converting the result to INTEGER(4) if needed
+ !WARN: portability: Argument types do not match specific intrinsic 'min0' requirements; using 'min' generic instead and converting the result to INTEGER(4) if needed
integer, parameter :: result_min0 = min0(max_i32_8, 2_8*max_i32_8)
! result_min0 would be -2 if arguments were converted to default integer.
logical, parameter :: test_min0 = expected_min0 .EQ. result_min0
real, parameter :: expected_amax0 = real(max(max_i32_8, 2_8*max_i32_8), 4)
- !WARN: portability: argument types do not match specific intrinsic 'amax0' requirements; using 'max' generic instead and converting the result to REAL(4) if needed
+ !WARN: portability: Argument types do not match specific intrinsic 'amax0' requirements; using 'max' generic instead and converting the result to REAL(4) if needed
real, parameter :: result_amax0 = amax0(max_i32_8, 2_8*max_i32_8)
! result_amax0 would be 2.1474836E+09 if arguments were converted to default integer first.
logical, parameter :: test_amax0 = expected_amax0 .EQ. result_amax0
diff --git a/flang/test/Evaluate/folding06.f90 b/flang/test/Evaluate/folding06.f90
index cb954c2ac17ebd5..132407387140ef1 100644
--- a/flang/test/Evaluate/folding06.f90
+++ b/flang/test/Evaluate/folding06.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_folding.py %s %flang_fc1
+! RUN: %python %S/test_folding.py %s %flang_fc1 -pedantic
! Test transformational intrinsic function folding
module m
@@ -7,15 +7,15 @@ module m
integer, pointer :: int_pointer
integer, allocatable :: int_allocatable
logical, parameter :: test_Assoc1 = .not.(associated(null()))
- !WARN: portability: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement
+ !WARN: portability: POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement
!WARN: because: 'NULL()' is a null pointer
logical, parameter :: test_Assoc2 = .not.(associated(null(), null()))
logical, parameter :: test_Assoc3 = .not.(associated(null(int_pointer)))
logical, parameter :: test_Assoc4 = .not.(associated(null(int_allocatable)))
- !WARN: portability: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement
+ !WARN: portability: POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement
!WARN: because: 'NULL()' is a null pointer
logical, parameter :: test_Assoc5 = .not.(associated(null(), null(int_pointer)))
- !WARN: portability: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement
+ !WARN: portability: POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement
!WARN: because: 'NULL()' is a null pointer
logical, parameter :: test_Assoc6 = .not.(associated(null(), null(int_allocatable)))
diff --git a/flang/test/Parser/badlabel.f b/flang/test/Parser/badlabel.f
index ea36ec6faab5cd3..7842803dadd04e9 100644
--- a/flang/test/Parser/badlabel.f
+++ b/flang/test/Parser/badlabel.f
@@ -1,4 +1,4 @@
-! RUN: %flang_fc1 -E -fno-reformat %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -E -fno-reformat -pedantic %s 2>&1 | FileCheck %s
! CHECK: Label digit is not in fixed-form label field
1 continue
! CHECK: Label digit is not in fixed-form label field
diff --git a/flang/test/Parser/continuation-before-quote.f90 b/flang/test/Parser/continuation-before-quote.f90
index 4ae669f5ac2769a..66252010d89c465 100644
--- a/flang/test/Parser/continuation-before-quote.f90
+++ b/flang/test/Parser/continuation-before-quote.f90
@@ -1,4 +1,4 @@
-! RUN: %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fsyntax-only -pedantic %s 2>&1 | FileCheck %s
! Continuation between repeated quotation marks
subroutine test
!CHECK: portability: Repeated quote mark in character literal continuation line should have been preceded by '&'
diff --git a/flang/test/Parser/excessive-continuations.f90 b/flang/test/Parser/excessive-continuations.f90
index e5855cfcbe52637..83becf618dae587 100644
--- a/flang/test/Parser/excessive-continuations.f90
+++ b/flang/test/Parser/excessive-continuations.f90
@@ -1,4 +1,4 @@
-! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fdebug-unparse -pedantic %s 2>&1 | FileCheck %s
! CHECK: portability: 256 continuation lines is more than the Fortran standard allows
! CHECK: LOGICAL, PARAMETER :: c255 = .true._4
program test
diff --git a/flang/test/Semantics/OpenACC/acc-branch.f90 b/flang/test/Semantics/OpenACC/acc-branch.f90
index c05633d2576e2c9..918f2b021c432f1 100644
--- a/flang/test/Semantics/OpenACC/acc-branch.f90
+++ b/flang/test/Semantics/OpenACC/acc-branch.f90
@@ -1,8 +1,8 @@
-! RUN: %python %S/../test_errors.py %s %flang -fopenacc
+! RUN: %python %S/../test_errors.py %s %flang -fopenacc -pedantic
! Check OpenACC restruction in branch in and out of some construct
!
-program openacc_clause_validity
+subroutine openacc_clause_validity
implicit none
@@ -175,4 +175,4 @@ program openacc_clause_validity
!$acc end data
-end program openacc_clause_validity
+end subroutine openacc_clause_validity
diff --git a/flang/test/Semantics/OpenACC/acc-data.f90 b/flang/test/Semantics/OpenACC/acc-data.f90
index 1a7a6f95f3d891e..c05691a9ed4c134 100644
--- a/flang/test/Semantics/OpenACC/acc-data.f90
+++ b/flang/test/Semantics/OpenACC/acc-data.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/../test_errors.py %s %flang -fopenacc
+! RUN: %python %S/../test_errors.py %s %flang -fopenacc -pedantic
! Check OpenACC clause validity for the following construct and directive:
! 2.6.5 Data
diff --git a/flang/test/Semantics/OpenACC/acc-serial.f90 b/flang/test/Semantics/OpenACC/acc-serial.f90
index afcfc00a40ec64d..db4cd7689435c7f 100644
--- a/flang/test/Semantics/OpenACC/acc-serial.f90
+++ b/flang/test/Semantics/OpenACC/acc-serial.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/../test_errors.py %s %flang -fopenacc
+! RUN: %python %S/../test_errors.py %s %flang -fopenacc -pedantic
! Check OpenACC clause validity for the following construct and directive:
! 2.5.2 Serial
diff --git a/flang/test/Semantics/OpenMP/copying.f90 b/flang/test/Semantics/OpenMP/copying.f90
index f95227fd2ce4c70..171e29bf67afbfb 100644
--- a/flang/test/Semantics/OpenMP/copying.f90
+++ b/flang/test/Semantics/OpenMP/copying.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/../test_errors.py %s %flang -fopenmp -Werror
+! RUN: %python %S/../test_errors.py %s %flang -fopenmp -Werror -pedantic
! OpenMP Version 5.0
! 2.19.4.4 firstprivate Clause
! 2.19.4.5 lastprivate Clause
diff --git a/flang/test/Semantics/OpenMP/declare-target03.f90 b/flang/test/Semantics/OpenMP/declare-target03.f90
index bfc20049963c16e..bb1ed90e390f3e9 100644
--- a/flang/test/Semantics/OpenMP/declare-target03.f90
+++ b/flang/test/Semantics/OpenMP/declare-target03.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp
+! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp -pedantic
! OpenMP Version 5.1
! Check OpenMP construct validity for the following directives:
! 2.14.7 Declare Target Directive
diff --git a/flang/test/Semantics/OpenMP/nested-target.f90 b/flang/test/Semantics/OpenMP/nested-target.f90
index c130d806b62ac88..2267f70715d3ed3 100644
--- a/flang/test/Semantics/OpenMP/nested-target.f90
+++ b/flang/test/Semantics/OpenMP/nested-target.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp -Werror
+! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp -Werror -pedantic
! OpenMP Version 5.0
! Check OpenMP construct validity for the following directives:
diff --git a/flang/test/Semantics/OpenMP/threadprivate03.f90 b/flang/test/Semantics/OpenMP/threadprivate03.f90
index 2a59a96ec1cfd50..b466a8e05e9c28f 100644
--- a/flang/test/Semantics/OpenMP/threadprivate03.f90
+++ b/flang/test/Semantics/OpenMP/threadprivate03.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp
+! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp -pedantic
! OpenMP Version 5.1
! Check OpenMP construct validity for the following directives:
! 2.21.2 Threadprivate Directive
diff --git a/flang/test/Semantics/allocate09.f90 b/flang/test/Semantics/allocate09.f90
index 2c7107ccda717b5..c6b3b58773b0286 100644
--- a/flang/test/Semantics/allocate09.f90
+++ b/flang/test/Semantics/allocate09.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Check for semantic errors in ALLOCATE statements
subroutine C946(param_ca_4_assumed, param_ta_4_assumed, param_ca_4_deferred)
diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90
index 1737970ac3988d0..bf8bcf474986336 100644
--- a/flang/test/Semantics/associated.f90
+++ b/flang/test/Semantics/associated.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Tests for the ASSOCIATED() and NULL() intrinsics
subroutine assoc()
@@ -54,6 +54,7 @@ function objPtrFunc(x)
objPtrFunc => x
end
+ !PORTABILITY: nonstandard usage: FUNCTION statement without dummy argument list
function procPtrFunc
procedure(intFunc), pointer :: procPtrFunc
procPtrFunc => intFunc
@@ -117,15 +118,15 @@ subroutine test(assumedRank)
lVar = associated(null(intAllocVar)) !OK
lVar = associated(null()) !OK
lVar = associated(null(intPointerVar1)) !OK
- !PORTABILITY: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement
+ !PORTABILITY: POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement
!BECAUSE: 'NULL()' is a null pointer
lVar = associated(null(), null()) !OK
lVar = associated(intPointerVar1, null(intPointerVar2)) !OK
lVar = associated(intPointerVar1, null()) !OK
- !PORTABILITY: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement
+ !PORTABILITY: POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement
!BECAUSE: 'NULL()' is a null pointer
lVar = associated(null(), null(intPointerVar1)) !OK
- !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ !PORTABILITY: POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer
lVar = associated(null(intPointerVar1), null()) !OK
!ERROR: POINTER= argument of ASSOCIATED() must be a pointer
lVar = associated(intVar)
@@ -174,18 +175,18 @@ subroutine test(assumedRank)
! Functions (other than NULL) returning pointers
lVar = associated(objPtrFunc(targetIntVar1)) ! ok
- !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ !PORTABILITY: POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer
lVar = associated(objPtrFunc(targetIntVar1), targetIntVar1) ! ok
- !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ !PORTABILITY: POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer
lVar = associated(objPtrFunc(targetIntVar1), objPtrFunc(targetIntVar1)) ! ok
lVar = associated(procPtrFunc()) ! ok
lVar = associated(procPtrFunc(), intFunc) ! ok
lVar = associated(procPtrFunc(), procPtrFunc()) ! ok
!ERROR: POINTER= argument 'objptrfunc(targetintvar1)' is an object pointer but the TARGET= argument 'intfunc' is not a variable
- !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ !PORTABILITY: POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer
lVar = associated(objPtrFunc(targetIntVar1), intFunc)
!ERROR: POINTER= argument 'objptrfunc(targetintvar1)' is an object pointer but the TARGET= argument 'procptrfunc()' is not a variable
- !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ !PORTABILITY: POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer
lVar = associated(objPtrFunc(targetIntVar1), procPtrFunc())
!ERROR: POINTER= argument 'procptrfunc()' is a procedure pointer but the TARGET= argument 'objptrfunc(targetintvar1)' is not a procedure or procedure pointer
lVar = associated(procPtrFunc(), objPtrFunc(targetIntVar1))
diff --git a/flang/test/Semantics/bind-c02.f90 b/flang/test/Semantics/bind-c02.f90
index 9ff6cf54bfa033d..d0c794074413135 100644
--- a/flang/test/Semantics/bind-c02.f90
+++ b/flang/test/Semantics/bind-c02.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Check for 8.6.4(1)
! The BIND statement specifies the BIND attribute for a list of variables and
! common blocks.
diff --git a/flang/test/Semantics/bind-c06.f90 b/flang/test/Semantics/bind-c06.f90
index 183eb9e6f1c1162..4c25722cb7752f8 100644
--- a/flang/test/Semantics/bind-c06.f90
+++ b/flang/test/Semantics/bind-c06.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Check for C1801 - C1805
module m
diff --git a/flang/test/Semantics/bind-c11.f90 b/flang/test/Semantics/bind-c11.f90
index 29ae09bd39f893b..54021f68b3d8d02 100644
--- a/flang/test/Semantics/bind-c11.f90
+++ b/flang/test/Semantics/bind-c11.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
module m
!ERROR: A scalar interoperable variable may not be ALLOCATABLE or POINTER
real, allocatable, bind(c) :: x1
diff --git a/flang/test/Semantics/bindings01.f90 b/flang/test/Semantics/bindings01.f90
index 024c3921198dcb7..7f119d4e55bf6f0 100644
--- a/flang/test/Semantics/bindings01.f90
+++ b/flang/test/Semantics/bindings01.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Confirm enforcement of constraints and restrictions in 7.5.7.3
! and C733, C734 and C779, C780, C782, C783, C784, and C785.
diff --git a/flang/test/Semantics/block-data01.f90 b/flang/test/Semantics/block-data01.f90
index 30c39c3212f3687..aa4ede787c17a40 100644
--- a/flang/test/Semantics/block-data01.f90
+++ b/flang/test/Semantics/block-data01.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Test BLOCK DATA subprogram (14.3)
block data foo
!ERROR: IMPORT is not allowed in a BLOCK DATA subprogram
diff --git a/flang/test/Semantics/c_loc01.f90 b/flang/test/Semantics/c_loc01.f90
index 774ebc2f382e92a..7c9e29417299387 100644
--- a/flang/test/Semantics/c_loc01.f90
+++ b/flang/test/Semantics/c_loc01.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
module m
use iso_c_binding
type haslen(L)
diff --git a/flang/test/Semantics/call01.f90 b/flang/test/Semantics/call01.f90
index dda1a7f35b15762..67d14c3800671d4 100644
--- a/flang/test/Semantics/call01.f90
+++ b/flang/test/Semantics/call01.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Confirm enforcement of constraints and restrictions in 15.6.2.1
non_recursive function f01(n) result(res)
@@ -21,7 +21,7 @@ non_recursive function f02(n) result(res)
res = nested()
end if
contains
- integer function nested
+ integer function nested()
!ERROR: NON_RECURSIVE procedure 'f02' cannot call itself
nested = n * f02(n-1) ! 15.6.2.1(3)
end function nested
@@ -111,7 +111,7 @@ function f14(n) result(res)
res = nested()
end if
contains
- character(1) function nested
+ character(1) function nested()
!ERROR: Assumed-length CHARACTER(*) function 'f14' cannot call itself
!ERROR: Assumed-length character function must be defined with a length to be called
nested = f14(n-1) ! 15.6.2.1(3)
diff --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90
index 902b8883b723c22..bc3dd6075969c60 100644
--- a/flang/test/Semantics/call02.f90
+++ b/flang/test/Semantics/call02.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! 15.5.1 procedure reference constraints and restrictions
subroutine s01(elem, subr)
diff --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90
index 0c28e391c937007..b8583ba4a49074e 100644
--- a/flang/test/Semantics/call09.f90
+++ b/flang/test/Semantics/call09.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Test 15.5.2.9(2,3,5) dummy procedure requirements
! C843
! An entity with the INTENT attribute shall be a dummy data object or a
diff --git a/flang/test/Semantics/call31.f90 b/flang/test/Semantics/call31.f90
index 429c3a869bf0592..d9fd2cc60ec338e 100644
--- a/flang/test/Semantics/call31.f90
+++ b/flang/test/Semantics/call31.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Confirm enforcement of constraint C723 in F2018 for procedure pointers
module m
diff --git a/flang/test/Semantics/common-blocks-warn.f90 b/flang/test/Semantics/common-blocks-warn.f90
index e4e486b64fb0666..6ed9296d72dd35f 100644
--- a/flang/test/Semantics/common-blocks-warn.f90
+++ b/flang/test/Semantics/common-blocks-warn.f90
@@ -1,4 +1,4 @@
-! RUN: %flang -fsyntax-only 2>&1 %s | FileCheck %s
+! RUN: %flang -fsyntax-only -pedantic 2>&1 %s | FileCheck %s
! Test that a warning is emitted when a named common block appears in
! several scopes with a different storage size.
diff --git a/flang/test/Semantics/common-blocks.f90 b/flang/test/Semantics/common-blocks.f90
index 89d9fb6e6af08c8..65f17f6d3fe97be 100644
--- a/flang/test/Semantics/common-blocks.f90
+++ b/flang/test/Semantics/common-blocks.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Test check that enforce that a common block is initialized
! only once in a file.
diff --git a/flang/test/Semantics/data06.f90 b/flang/test/Semantics/data06.f90
index 052372afe544091..08b4700028438f0 100644
--- a/flang/test/Semantics/data06.f90
+++ b/flang/test/Semantics/data06.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! DATA statement errors
subroutine s1
type :: t1
diff --git a/flang/test/Semantics/data08.f90 b/flang/test/Semantics/data08.f90
index be56c7efa7ea3bd..7bd70637aabda78 100644
--- a/flang/test/Semantics/data08.f90
+++ b/flang/test/Semantics/data08.f90
@@ -1,4 +1,4 @@
-! RUN: %flang_fc1 -fdebug-dump-symbols %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fdebug-dump-symbols -pedantic %s 2>&1 | FileCheck %s
! CHECK: DATA statement value initializes 'jx' of type 'INTEGER(4)' with CHARACTER
! CHECK: DATA statement value initializes 'jy' of type 'INTEGER(4)' with CHARACTER
! CHECK: DATA statement value initializes 'jz' of type 'INTEGER(4)' with CHARACTER
diff --git a/flang/test/Semantics/data11.f90 b/flang/test/Semantics/data11.f90
index df36abf12ebd551..064e7574fee99ad 100644
--- a/flang/test/Semantics/data11.f90
+++ b/flang/test/Semantics/data11.f90
@@ -1,4 +1,4 @@
-! RUN: %flang_fc1 -fdebug-dump-symbols %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fdebug-dump-symbols -pedantic %s 2>&1 | FileCheck %s
! CHECK: Implied DO index 'j' uses an object of the same name in its bounds expressions
! CHECK: ObjectEntity type: REAL(4) shape: 1_8:5_8 init:[REAL(4)::1._4,2._4,3._4,4._4,5._4]
! Verify that the scope of a DATA statement implied DO loop index does
diff --git a/flang/test/Semantics/data14.f90 b/flang/test/Semantics/data14.f90
index 2e8c39508d922ac..1033599934f9376 100644
--- a/flang/test/Semantics/data14.f90
+++ b/flang/test/Semantics/data14.f90
@@ -1,4 +1,4 @@
-! RUN: %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fsyntax-only -pedantic %s 2>&1 | FileCheck %s
! Verify varnings on nonconforming DATA statements
! As a common extension, C876 violations are not errors.
program main
diff --git a/flang/test/Semantics/declarations04.f90 b/flang/test/Semantics/declarations04.f90
index 6b33578ca9c052d..f0ca568e7a97c34 100644
--- a/flang/test/Semantics/declarations04.f90
+++ b/flang/test/Semantics/declarations04.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! test global name conflicts
subroutine ext1
diff --git a/flang/test/Semantics/dim01.f90 b/flang/test/Semantics/dim01.f90
index 2d56eb5853248c2..aba9a15b95a41be 100644
--- a/flang/test/Semantics/dim01.f90
+++ b/flang/test/Semantics/dim01.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Test warnings and errors about DIM= arguments to transformational intrinsics
module m
diff --git a/flang/test/Semantics/expr-errors05.f90 b/flang/test/Semantics/expr-errors05.f90
index 964511888d5ef65..0328165a7921e94 100644
--- a/flang/test/Semantics/expr-errors05.f90
+++ b/flang/test/Semantics/expr-errors05.f90
@@ -1,6 +1,8 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror -pedantic
+!PORTABILITY: nonstandard usage: generalized COMPLEX constructor
!PORTABILITY: Real part of complex constructor is not scalar
complex, parameter :: z1(*) = ([1.,2.], 3.)
+!PORTABILITY: nonstandard usage: generalized COMPLEX constructor
!PORTABILITY: Imaginary part of complex constructor is not scalar
complex, parameter :: z2(*) = (4., [5.,6.])
real, parameter :: aa(*) = [7.,8.]
diff --git a/flang/test/Semantics/generic06.f90 b/flang/test/Semantics/generic06.f90
index 3e39cc719744776..b47d442f3549e9e 100644
--- a/flang/test/Semantics/generic06.f90
+++ b/flang/test/Semantics/generic06.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
module m
!PORTABILITY: Specific procedure 'sin' of generic interface 'yintercept' should not be INTRINSIC
intrinsic sin
diff --git a/flang/test/Semantics/ignore_tkr01.f90 b/flang/test/Semantics/ignore_tkr01.f90
index bc1d5c8548c9987..a8fc9dadc1d83e7 100644
--- a/flang/test/Semantics/ignore_tkr01.f90
+++ b/flang/test/Semantics/ignore_tkr01.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! !DIR$ IGNORE_TKR tests
!ERROR: !DIR$ IGNORE_TKR directive must appear in a subroutine or function
diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90
index 6c002e4db41da0a..9b5ad1b8427d917 100644
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -83,8 +83,7 @@ module m4
subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg)
!ERROR: Dummy argument 'unit' must be a data object
!ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute
- !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
- procedure(sin), intent(in) :: unit
+ procedure(real), intent(in) :: unit
character(len=*), intent(in) :: iotype
integer, intent(in) :: vlist(:)
integer, intent(out) :: iostat
diff --git a/flang/test/Semantics/long-name.f90 b/flang/test/Semantics/long-name.f90
index 3dca0abe34f5c7a..c406e366f76d4a4 100644
--- a/flang/test/Semantics/long-name.f90
+++ b/flang/test/Semantics/long-name.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror -pedantic
!PORTABILITY: aaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffggg1 has length 64, which is greater than the maximum name length 63
program aaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffggg1
diff --git a/flang/test/Semantics/modfile43.f90 b/flang/test/Semantics/modfile43.f90
index d908546128c501e..1629e053c71163f 100644
--- a/flang/test/Semantics/modfile43.f90
+++ b/flang/test/Semantics/modfile43.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Test intrinsic vs non_intrinsic module coexistence
module iso_fortran_env
integer, parameter :: user_defined_123 = 123
diff --git a/flang/test/Semantics/modfile54.f90 b/flang/test/Semantics/modfile54.f90
index a8efefe127d0337..7605e2ac49b0717 100644
--- a/flang/test/Semantics/modfile54.f90
+++ b/flang/test/Semantics/modfile54.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
!ERROR: Some modules in this compilation unit form one or more cycles of dependence
module m1
use m2
diff --git a/flang/test/Semantics/pointer01.f90 b/flang/test/Semantics/pointer01.f90
index b6a66b61fe25e22..cb860f3a3f437c5 100644
--- a/flang/test/Semantics/pointer01.f90
+++ b/flang/test/Semantics/pointer01.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
module m
real mobj
contains
diff --git a/flang/test/Semantics/procinterface02.f90 b/flang/test/Semantics/procinterface02.f90
index ca0c62c150d44e4..8b1becbe081e597 100644
--- a/flang/test/Semantics/procinterface02.f90
+++ b/flang/test/Semantics/procinterface02.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
subroutine foo(A, B, P)
interface
real elemental function foo_elemental(x)
diff --git a/flang/test/Semantics/procinterface04.f90 b/flang/test/Semantics/procinterface04.f90
index 5bc5413375d90ec..f59e53f90dab132 100644
--- a/flang/test/Semantics/procinterface04.f90
+++ b/flang/test/Semantics/procinterface04.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
subroutine test(dp1, dp2)
intrinsic sin
interface
diff --git a/flang/test/Semantics/resolve05.f90 b/flang/test/Semantics/resolve05.f90
index 736babf07808a47..4e50feb64e4c370 100644
--- a/flang/test/Semantics/resolve05.f90
+++ b/flang/test/Semantics/resolve05.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
program p
!PORTABILITY: Name 'p' declared in a main program should not have the same name as the main program
integer :: p
diff --git a/flang/test/Semantics/resolve106.f90 b/flang/test/Semantics/resolve106.f90
index b8215f723225902..dfc63243d508b61 100644
--- a/flang/test/Semantics/resolve106.f90
+++ b/flang/test/Semantics/resolve106.f90
@@ -1,4 +1,4 @@
-!RUN: %flang -fsyntax-only %s 2>&1 | FileCheck %s
+!RUN: %flang -fsyntax-only -pedantic %s 2>&1 | FileCheck %s
integer, parameter :: j = 10
! CHECK: Implied DO index 'j' uses an object of the same name in its bounds expressions
real :: a(10) = [(j, j=1,j)]
diff --git a/flang/test/Semantics/resolve114.f90 b/flang/test/Semantics/resolve114.f90
index 02923e32a2a148b..6204e5fc2f3f4e9 100644
--- a/flang/test/Semantics/resolve114.f90
+++ b/flang/test/Semantics/resolve114.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Allow the same external or intrinsic procedure to be use-associated
! by multiple paths when they are unambiguous.
module m1
diff --git a/flang/test/Semantics/resolve118.f90 b/flang/test/Semantics/resolve118.f90
index e31175799b028da..11fa18255f0457a 100644
--- a/flang/test/Semantics/resolve118.f90
+++ b/flang/test/Semantics/resolve118.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! USE vs IMPORT
module m1
type t
diff --git a/flang/test/Semantics/resolve20.f90 b/flang/test/Semantics/resolve20.f90
index 239e32ba92a4973..359bc0c1f9a3f76 100644
--- a/flang/test/Semantics/resolve20.f90
+++ b/flang/test/Semantics/resolve20.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
module m
abstract interface
subroutine foo
diff --git a/flang/test/Semantics/resolve46.f90 b/flang/test/Semantics/resolve46.f90
index 784ffa427031c80..0acc20b19f0b75e 100644
--- a/flang/test/Semantics/resolve46.f90
+++ b/flang/test/Semantics/resolve46.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! C1030 - assignment of pointers to intrinsic procedures
! C1515 - interface definition for procedure pointers
! C1519 - initialization of pointers to intrinsic procedures
diff --git a/flang/test/Semantics/resolve59.f90 b/flang/test/Semantics/resolve59.f90
index aae0aff5f072e44..3bdcf67aa958a9b 100644
--- a/flang/test/Semantics/resolve59.f90
+++ b/flang/test/Semantics/resolve59.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Testing 15.6.2.2 point 4 (What function-name refers to depending on the
! presence of RESULT).
diff --git a/flang/test/Semantics/resolve85.f90 b/flang/test/Semantics/resolve85.f90
index b85b7bb052dbc1f..f598456f9830a3e 100644
--- a/flang/test/Semantics/resolve85.f90
+++ b/flang/test/Semantics/resolve85.f90
@@ -1,6 +1,6 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
module m
-! C730 The same type-attr-spec shall not appear more than once in a given
+! C730 The same type-attr-spec shall not appear more than once in a given
! derived-type-stmt.
!
! R727 derived-type-stmt ->
diff --git a/flang/test/Semantics/stmt-func01.f90 b/flang/test/Semantics/stmt-func01.f90
index 185714307180830..fd9b33a52a57c93 100644
--- a/flang/test/Semantics/stmt-func01.f90
+++ b/flang/test/Semantics/stmt-func01.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! C1577
program main
type t1(k,l)
diff --git a/flang/test/Semantics/stmt-func02.f90 b/flang/test/Semantics/stmt-func02.f90
index 5d768903e2cb952..90a89e93530c24b 100644
--- a/flang/test/Semantics/stmt-func02.f90
+++ b/flang/test/Semantics/stmt-func02.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
module m
real, target :: x = 1.
contains
diff --git a/flang/tools/bbc/bbc.cpp b/flang/tools/bbc/bbc.cpp
index 378216bd1e51f8f..8374532571fd3d7 100644
--- a/flang/tools/bbc/bbc.cpp
+++ b/flang/tools/bbc/bbc.cpp
@@ -303,7 +303,7 @@ static mlir::LogicalResult convertFortranSourceToMLIR(
auto burnside = Fortran::lower::LoweringBridge::create(
ctx, semanticsContext, defKinds, semanticsContext.intrinsics(),
semanticsContext.targetCharacteristics(), parsing.allCooked(), "",
- kindMap, loweringOptions, {});
+ kindMap, loweringOptions, {}, semanticsContext.languageFeatures());
burnside.lower(parseTree, semanticsContext);
mlir::ModuleOp mlirModule = burnside.getModule();
if (enableOpenMP) {
diff --git a/flang/unittests/Evaluate/expression.cpp b/flang/unittests/Evaluate/expression.cpp
index 732dc6dba7ff767..49b5beb200dbf18 100644
--- a/flang/unittests/Evaluate/expression.cpp
+++ b/flang/unittests/Evaluate/expression.cpp
@@ -22,8 +22,9 @@ int main() {
Fortran::common::IntrinsicTypeDefaultKinds defaults;
auto intrinsics{Fortran::evaluate::IntrinsicProcTable::Configure(defaults)};
TargetCharacteristics targetCharacteristics;
+ Fortran::common::LanguageFeatureControl languageFeatures;
FoldingContext context{Fortran::parser::ContextualMessages{nullptr}, defaults,
- intrinsics, targetCharacteristics};
+ intrinsics, targetCharacteristics, languageFeatures};
ex1 = Fold(context, std::move(ex1));
MATCH("-10_4", ex1.AsFortran());
MATCH("1_4/2_4", (DefaultIntegerExpr{1} / DefaultIntegerExpr{2}).AsFortran());
diff --git a/flang/unittests/Evaluate/folding.cpp b/flang/unittests/Evaluate/folding.cpp
index fd7e61f1a2dd9b6..9c73422f6afa704 100644
--- a/flang/unittests/Evaluate/folding.cpp
+++ b/flang/unittests/Evaluate/folding.cpp
@@ -49,10 +49,11 @@ void TestHostRuntimeSubnormalFlushing() {
flushingTargetCharacteristics.set_areSubnormalsFlushedToZero(true);
TargetCharacteristics noFlushingTargetCharacteristics;
noFlushingTargetCharacteristics.set_areSubnormalsFlushedToZero(false);
- FoldingContext flushingContext{
- messages, defaults, intrinsics, flushingTargetCharacteristics};
- FoldingContext noFlushingContext{
- messages, defaults, intrinsics, noFlushingTargetCharacteristics};
+ Fortran::common::LanguageFeatureControl languageFeatures;
+ FoldingContext flushingContext{messages, defaults, intrinsics,
+ flushingTargetCharacteristics, languageFeatures};
+ FoldingContext noFlushingContext{messages, defaults, intrinsics,
+ noFlushingTargetCharacteristics, languageFeatures};
DynamicType r4{R4{}.GetType()};
// Test subnormal argument flushing
diff --git a/flang/unittests/Evaluate/intrinsics.cpp b/flang/unittests/Evaluate/intrinsics.cpp
index bb83e0c061547d8..9eb630abc7794d2 100644
--- a/flang/unittests/Evaluate/intrinsics.cpp
+++ b/flang/unittests/Evaluate/intrinsics.cpp
@@ -105,7 +105,9 @@ struct TestCall {
CallCharacteristics call{fName.ToString()};
auto messages{strings.Messages(buffer)};
TargetCharacteristics targetCharacteristics;
- FoldingContext context{messages, defaults, table, targetCharacteristics};
+ common::LanguageFeatureControl languageFeatures;
+ FoldingContext context{
+ messages, defaults, table, targetCharacteristics, languageFeatures};
std::optional<SpecificCall> si{table.Probe(call, args, context)};
if (resultType.has_value()) {
TEST(si.has_value());
More information about the flang-commits
mailing list