Magic-Mirror/llvm-capstone
1
0
Fork 0
mirror of https://github.com/capstone-engine/llvm-capstone.git synced 2024-12-01 01:31:26 +00:00
Code Issues Actions 2 Packages Projects Releases Wiki Activity

[flang] Ensure that portability warnings are conditional (#71857)

Browse Source 
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.
This commit is contained in:
Peter Klausler 2023-11-13 16:13:50 -08:00 committed by GitHub
parent a5eb6bdd8e
commit 1c91d9bdea
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
78 changed files with 568 additions and 347 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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>;

22
flang/include/flang/Evaluate/common.h
View File

@ -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 @@ public:
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 @@ private:
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);

13
flang/include/flang/Lower/Bridge.h
View File

@ -58,10 +58,11 @@ public:
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 @@ public:
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 @@ private:
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 @@ private:
fir::KindMapping &kindMap;
const Fortran::lower::LoweringOptions &loweringOptions;
const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults;
const Fortran::common::LanguageFeatureControl &languageFeatures;
};
} // namespace lower

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

@ -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 @@ public:
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 @@ public:
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 @@ public:
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 @@ public:
private:
const Symbol &sf_;
FoldingContext &context_;
std::optional<parser::Severity> severity_;
};
std::optional<parser::Message> CheckStatementFunction(

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

@ -2225,12 +2225,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);
}
}
}
}
@ -3181,28 +3184,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;
}
}
}
}

3
flang/lib/Frontend/FrontendActions.cpp
View File

@ -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());

9
flang/lib/Lower/Bridge.cpp
View File

@ -4914,7 +4914,8 @@ private:
Fortran::evaluate::FoldingContext
Fortran::lower::LoweringBridge::createFoldingContext() const {
return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics()};
return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics(),
getLanguageFeatures()};
}
void Fortran::lower::LoweringBridge::lower(
@ -4944,11 +4945,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();

6
flang/lib/Parser/expr-parsers.cpp
View File

@ -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>(

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

@ -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;
}
}

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

@ -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;
}
}

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

@ -235,7 +235,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() &&
@ -246,9 +246,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;
}
@ -313,7 +326,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 ||
@ -323,8 +336,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;
@ -913,9 +929,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(
@ -1272,7 +1295,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;
@ -1280,7 +1305,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;
}
@ -1294,19 +1319,21 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
// results, including NULL(), from being used there, as well as
// INTENT(IN) dummy pointers. Detect these conditions and emit
// portability warnings.
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));
}
}
}
}
@ -1314,11 +1341,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{
@ -1332,13 +1359,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());
}
@ -1348,8 +1375,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) {
@ -1357,7 +1383,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());
}
@ -1368,7 +1394,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());
}
@ -1380,7 +1406,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);
}
}
@ -1456,7 +1482,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);
}

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

@ -84,14 +84,30 @@ public:
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;
}

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

@ -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.
}
}
@ -831,8 +835,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) {
@ -1198,8 +1204,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);
}
@ -1225,9 +1233,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,
@ -1351,10 +1361,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() ==
@ -1753,18 +1766,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;
}
@ -2135,14 +2152,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());
}
}
@ -2423,24 +2442,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);
}
}
}
}
@ -2616,13 +2637,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)}) {
@ -2758,17 +2783,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(),
@ -2781,8 +2808,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)) {
@ -2853,12 +2882,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);
@ -2875,9 +2908,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);
}
}
}
}

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

@ -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) ||

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

@ -650,9 +650,11 @@ private:
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;

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

@ -609,7 +609,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,
@ -2769,15 +2770,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()));
}
}
}
}

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

@ -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()};

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

@ -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());

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

@ -641,6 +641,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);
@ -2078,11 +2079,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(
@ -2366,11 +2370,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);
@ -3312,6 +3320,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");
}
@ -3913,11 +3925,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);

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

@ -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());

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

@ -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;
}
}

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

@ -243,7 +243,8 @@ public:
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() {}

6
flang/test/Evaluate/folding04.f90
View File

@ -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

8
flang/test/Evaluate/folding06.f90
View File

@ -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)))

2
flang/test/Parser/badlabel.f
View File

@ -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

2
flang/test/Parser/continuation-before-quote.f90
View File

@ -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 '&'

2
flang/test/Parser/excessive-continuations.f90
View File

@ -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

6
flang/test/Semantics/OpenACC/acc-branch.f90
View File

@ -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

2
flang/test/Semantics/OpenACC/acc-data.f90
View File

@ -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

2
flang/test/Semantics/OpenACC/acc-serial.f90
View File

@ -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

2
flang/test/Semantics/OpenMP/copying.f90
View File

@ -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

2
flang/test/Semantics/OpenMP/declare-target03.f90
View File

@ -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

2
flang/test/Semantics/OpenMP/nested-target.f90
View File

@ -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:

2
flang/test/Semantics/OpenMP/threadprivate03.f90
View File

@ -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

2
flang/test/Semantics/allocate09.f90
View File

@ -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)

17
flang/test/Semantics/associated.f90
View File

@ -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 @@ subroutine assoc()
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 assoc()
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 assoc()
! 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))

2
flang/test/Semantics/bind-c02.f90
View File

@ -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.

2
flang/test/Semantics/bind-c06.f90
View File

@ -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

2
flang/test/Semantics/bind-c11.f90
View File

@ -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

2
flang/test/Semantics/bindings01.f90
View File

@ -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.

2
flang/test/Semantics/block-data01.f90
View File

@ -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

2
flang/test/Semantics/c_loc01.f90
View File

@ -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)

6
flang/test/Semantics/call01.f90
View File

@ -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)

2
flang/test/Semantics/call02.f90
View File

@ -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)

2
flang/test/Semantics/call09.f90
View File

@ -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

2
flang/test/Semantics/call31.f90
View File

@ -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

2
flang/test/Semantics/common-blocks-warn.f90
View File

@ -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.

2
flang/test/Semantics/common-blocks.f90
View File

@ -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.

2
flang/test/Semantics/data06.f90
View File

@ -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

2
flang/test/Semantics/data08.f90
View File

@ -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

2
flang/test/Semantics/data11.f90
View File

@ -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

2
flang/test/Semantics/data14.f90
View File

@ -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

2
flang/test/Semantics/declarations04.f90
View File

@ -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

2
flang/test/Semantics/dim01.f90
View File

@ -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

4
flang/test/Semantics/expr-errors05.f90
View File

@ -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.]

2
flang/test/Semantics/generic06.f90
View File

@ -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

2
flang/test/Semantics/ignore_tkr01.f90
View File

@ -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

3
flang/test/Semantics/io11.f90
View File

@ -83,8 +83,7 @@ contains
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

2
flang/test/Semantics/long-name.f90
View File

@ -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

2
flang/test/Semantics/modfile43.f90
View File

@ -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

2
flang/test/Semantics/modfile54.f90
View File

@ -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

2
flang/test/Semantics/pointer01.f90
View File

@ -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

2
flang/test/Semantics/procinterface02.f90
View File

@ -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)

2
flang/test/Semantics/procinterface04.f90
View File

@ -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

2
flang/test/Semantics/resolve05.f90
View File

@ -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

2
flang/test/Semantics/resolve106.f90
View File

@ -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)]

2
flang/test/Semantics/resolve114.f90
View File

@ -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

2
flang/test/Semantics/resolve118.f90
View File

@ -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

2
flang/test/Semantics/resolve20.f90
View File

@ -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

2
flang/test/Semantics/resolve46.f90
View File

@ -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

2
flang/test/Semantics/resolve59.f90
View File

@ -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).

4
flang/test/Semantics/resolve85.f90
View File

@ -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 ->

2
flang/test/Semantics/stmt-func01.f90
View File

@ -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)

2
flang/test/Semantics/stmt-func02.f90
View File

@ -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

2
flang/tools/bbc/bbc.cpp
View File

@ -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) {

3
flang/unittests/Evaluate/expression.cpp
View File

@ -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());

9
flang/unittests/Evaluate/folding.cpp
View File

@ -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

4
flang/unittests/Evaluate/intrinsics.cpp
View File

@ -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());